diff options
| author | bosch <bosch@138bc75d-0d04-0410-961f-82ee72b054a4> | 2002-03-08 20:11:04 +0000 |
|---|---|---|
| committer | bosch <bosch@138bc75d-0d04-0410-961f-82ee72b054a4> | 2002-03-08 20:11:04 +0000 |
| commit | f15731c43ae5e8cea424ea40f905c19afa1bd2e4 (patch) | |
| tree | b584a79288c93215b05fb451943291ccd039388b /gcc/ada | |
| parent | 1d347c236ad815c77bd345611ed221b0bd6091de (diff) | |
| download | ppe42-gcc-f15731c43ae5e8cea424ea40f905c19afa1bd2e4.tar.gz ppe42-gcc-f15731c43ae5e8cea424ea40f905c19afa1bd2e4.zip | |
* 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]
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@50451 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
471 files changed, 30562 insertions, 24416 deletions
diff --git a/gcc/ada/1ssecsta.adb b/gcc/ada/1ssecsta.adb new file mode 100644 index 00000000000..0bb1f2ac122 --- /dev/null +++ b/gcc/ada/1ssecsta.adb @@ -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; diff --git a/gcc/ada/1ssecsta.ads b/gcc/ada/1ssecsta.ads new file mode 100644 index 00000000000..a2212e5dd67 --- /dev/null +++ b/gcc/ada/1ssecsta.ads @@ -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; diff --git a/gcc/ada/3lsoccon.ads b/gcc/ada/3lsoccon.ads deleted file mode 100644 index 4371e0d3a37..00000000000 --- a/gcc/ada/3lsoccon.ads +++ /dev/null @@ -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; diff --git a/gcc/ada/41intnam.ads b/gcc/ada/41intnam.ads index 8442cc8dc88..40a0132b13c 100644 --- a/gcc/ada/41intnam.ads +++ b/gcc/ada/41intnam.ads @@ -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 diff --git a/gcc/ada/42intnam.ads b/gcc/ada/42intnam.ads index 6e35c55cf29..d95d62a8f02 100644 --- a/gcc/ada/42intnam.ads +++ b/gcc/ada/42intnam.ads @@ -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 diff --git a/gcc/ada/4aintnam.ads b/gcc/ada/4aintnam.ads index b882bcb6abb..c53c51a63d7 100644 --- a/gcc/ada/4aintnam.ads +++ b/gcc/ada/4aintnam.ads @@ -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 diff --git a/gcc/ada/4cintnam.ads b/gcc/ada/4cintnam.ads index 2fd50469848..54823751a5c 100644 --- a/gcc/ada/4cintnam.ads +++ b/gcc/ada/4cintnam.ads @@ -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. diff --git a/gcc/ada/4dintnam.ads b/gcc/ada/4dintnam.ads index 7904e9f8c97..3e8285bb332 100644 --- a/gcc/ada/4dintnam.ads +++ b/gcc/ada/4dintnam.ads @@ -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. diff --git a/gcc/ada/4gintnam.ads b/gcc/ada/4gintnam.ads index 8cc8e7f7f47..be2c19a1fbf 100644 --- a/gcc/ada/4gintnam.ads +++ b/gcc/ada/4gintnam.ads @@ -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. diff --git a/gcc/ada/4hintnam.ads b/gcc/ada/4hintnam.ads index f224b9d6031..f3b5e75c3be 100644 --- a/gcc/ada/4hintnam.ads +++ b/gcc/ada/4hintnam.ads @@ -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. diff --git a/gcc/ada/4lintnam.ads b/gcc/ada/4lintnam.ads index 52c3e95047a..dcb8164d47d 100644 --- a/gcc/ada/4lintnam.ads +++ b/gcc/ada/4lintnam.ads @@ -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. diff --git a/gcc/ada/4mintnam.ads b/gcc/ada/4mintnam.ads index 5ecb26e7da2..60afd6ebdd8 100644 --- a/gcc/ada/4mintnam.ads +++ b/gcc/ada/4mintnam.ads @@ -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. diff --git a/gcc/ada/4pintnam.ads b/gcc/ada/4pintnam.ads index f640d49978c..7c15f146a96 100644 --- a/gcc/ada/4pintnam.ads +++ b/gcc/ada/4pintnam.ads @@ -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. diff --git a/gcc/ada/4rintnam.ads b/gcc/ada/4rintnam.ads index 53173a28dbc..e4f91e22479 100644 --- a/gcc/ada/4rintnam.ads +++ b/gcc/ada/4rintnam.ads @@ -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. diff --git a/gcc/ada/4sintnam.ads b/gcc/ada/4sintnam.ads index b66aa038947..8ebf91b71b4 100644 --- a/gcc/ada/4sintnam.ads +++ b/gcc/ada/4sintnam.ads @@ -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 diff --git a/gcc/ada/4uintnam.ads b/gcc/ada/4uintnam.ads index 80d354c896c..f2f03e36288 100644 --- a/gcc/ada/4uintnam.ads +++ b/gcc/ada/4uintnam.ads @@ -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 diff --git a/gcc/ada/4vcalend.adb b/gcc/ada/4vcalend.adb index 0c29f602548..e0503b59aa9 100644 --- a/gcc/ada/4vcalend.adb +++ b/gcc/ada/4vcalend.adb @@ -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 diff --git a/gcc/ada/4zintnam.ads b/gcc/ada/4zintnam.ads index 7bb4192aee0..3b03c0daf9e 100644 --- a/gcc/ada/4zintnam.ads +++ b/gcc/ada/4zintnam.ads @@ -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; diff --git a/gcc/ada/52system.ads b/gcc/ada/52system.ads index 0ba9d6a5e6c..861fc7be458 100644 --- a/gcc/ada/52system.ads +++ b/gcc/ada/52system.ads @@ -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 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; + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; - Default_Priority : constant Priority := - 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; diff --git a/gcc/ada/5amastop.adb b/gcc/ada/5amastop.adb index 5eac869a052..adbb2d27cec 100644 --- a/gcc/ada/5amastop.adb +++ b/gcc/ada/5amastop.adb @@ -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; diff --git a/gcc/ada/5asystem.ads b/gcc/ada/5asystem.ads index f777d2b916b..1ae0fef716f 100644 --- a/gcc/ada/5asystem.ads +++ b/gcc/ada/5asystem.ads @@ -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; diff --git a/gcc/ada/5ataprop.adb b/gcc/ada/5ataprop.adb index 77fec994842..c586ac0b5ca 100644 --- a/gcc/ada/5ataprop.adb +++ b/gcc/ada/5ataprop.adb @@ -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 Result /= 0 then - Succeeded := False; - return; - end if; + if not Single_Lock then + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, + Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; - 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; - if Result /= 0 then - Succeeded := False; - return; + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); 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 diff --git a/gcc/ada/5atpopsp.adb b/gcc/ada/5atpopsp.adb index 6d8cb87a2c9..cc386d46963 100644 --- a/gcc/ada/5atpopsp.adb +++ b/gcc/ada/5atpopsp.adb @@ -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. - - -- (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.) + -- To make Ada tasks and C threads interoperate better, we have added some + -- functionality to Self. Suppose a C main program (with threads) calls an + -- Ada procedure and the Ada procedure calls the tasking runtime system. + -- Eventually, a call will be made to self. Since the call is not coming + -- from an Ada task, there will be no corresponding ATCB. - -- What we do in Self is to catch references that do not come - -- from recognized Ada tasks, and create an ATCB for the calling - -- thread. + -- 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); diff --git a/gcc/ada/5avxwork.ads b/gcc/ada/5avxwork.ads index eb8612ebe44..6c16373bc72 100644 --- a/gcc/ada/5avxwork.ads +++ b/gcc/ada/5avxwork.ads @@ -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; diff --git a/gcc/ada/5bosinte.adb b/gcc/ada/5bosinte.adb index 79062bb407b..b692a754517 100644 --- a/gcc/ada/5bosinte.adb +++ b/gcc/ada/5bosinte.adb @@ -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; diff --git a/gcc/ada/5bsystem.ads b/gcc/ada/5bsystem.ads index 677db87fd40..bc7a226d316 100644 --- a/gcc/ada/5bsystem.ads +++ b/gcc/ada/5bsystem.ads @@ -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 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; + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; - Default_Priority : constant Priority := - 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; diff --git a/gcc/ada/5esystem.ads b/gcc/ada/5esystem.ads index 052776374d8..2a4d594f893 100644 --- a/gcc/ada/5esystem.ads +++ b/gcc/ada/5esystem.ads @@ -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 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; + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; - Default_Priority : constant Priority := - 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; diff --git a/gcc/ada/5fsystem.ads b/gcc/ada/5fsystem.ads index dca9f664a58..a68767b2a02 100644 --- a/gcc/ada/5fsystem.ads +++ b/gcc/ada/5fsystem.ads @@ -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 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; + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; - Default_Priority : constant Priority := - 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; diff --git a/gcc/ada/5ftaprop.adb b/gcc/ada/5ftaprop.adb index 6a33979a43d..20b21f5ecf8 100644 --- a/gcc/ada/5ftaprop.adb +++ b/gcc/ada/5ftaprop.adb @@ -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); diff --git a/gcc/ada/5ginterr.adb b/gcc/ada/5ginterr.adb index c4db14c98a7..4b7d1a30a1b 100644 --- a/gcc/ada/5ginterr.adb +++ b/gcc/ada/5ginterr.adb @@ -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 diff --git a/gcc/ada/5gmastop.adb b/gcc/ada/5gmastop.adb index 67c6a399cf2..c3b41f93af2 100644 --- a/gcc/ada/5gmastop.adb +++ b/gcc/ada/5gmastop.adb @@ -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; diff --git a/gcc/ada/5gsystem.ads b/gcc/ada/5gsystem.ads index e97781786ae..f3f4c0ff4d3 100644 --- a/gcc/ada/5gsystem.ads +++ b/gcc/ada/5gsystem.ads @@ -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 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; + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; - Default_Priority : constant Priority := - 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; diff --git a/gcc/ada/5gtaprop.adb b/gcc/ada/5gtaprop.adb index 28284745641..c2718ddcc13 100644 --- a/gcc/ada/5gtaprop.adb +++ b/gcc/ada/5gtaprop.adb @@ -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); diff --git a/gcc/ada/5gtasinf.adb b/gcc/ada/5gtasinf.adb index b56675072b6..5eae351aa3a 100644 --- a/gcc/ada/5gtasinf.adb +++ b/gcc/ada/5gtasinf.adb @@ -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); diff --git a/gcc/ada/5gtasinf.ads b/gcc/ada/5gtasinf.ads index 08955d8f0a7..7767023af8e 100644 --- a/gcc/ada/5gtasinf.ads +++ b/gcc/ada/5gtasinf.ads @@ -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); diff --git a/gcc/ada/5hparame.ads b/gcc/ada/5hparame.ads index cdce2ba334d..f7713e9974c 100644 --- a/gcc/ada/5hparame.ads +++ b/gcc/ada/5hparame.ads @@ -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; diff --git a/gcc/ada/5hsystem.ads b/gcc/ada/5hsystem.ads index fef7ae9f3f3..d6b40dce4db 100644 --- a/gcc/ada/5hsystem.ads +++ b/gcc/ada/5hsystem.ads @@ -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 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; + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; - Default_Priority : constant Priority := - 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; diff --git a/gcc/ada/5htaprop.adb b/gcc/ada/5htaprop.adb index 08d2a7ee34c..7efc38806ae 100644 --- a/gcc/ada/5htaprop.adb +++ b/gcc/ada/5htaprop.adb @@ -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; - end if; + 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; - 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; - if Result /= 0 then - Succeeded := False; - return; + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); 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; diff --git a/gcc/ada/5htraceb.adb b/gcc/ada/5htraceb.adb index cbc6680f123..232449258a3 100644 --- a/gcc/ada/5htraceb.adb +++ b/gcc/ada/5htraceb.adb @@ -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; - diff --git a/gcc/ada/5itaprop.adb b/gcc/ada/5itaprop.adb index b1edfd05253..56797f6cbd2 100644 --- a/gcc/ada/5itaprop.adb +++ b/gcc/ada/5itaprop.adb @@ -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; diff --git a/gcc/ada/5ksystem.ads b/gcc/ada/5ksystem.ads index d3d9a66f609..60bbcdb67f6 100644 --- a/gcc/ada/5ksystem.ads +++ b/gcc/ada/5ksystem.ads @@ -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 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; + subtype Any_Priority is Integer range 0 .. 255; + subtype Priority is Any_Priority range 0 .. 245; + subtype Interrupt_Priority is Any_Priority range 246 .. 255; - Default_Priority : constant Priority := - 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; diff --git a/gcc/ada/5kvxwork.ads b/gcc/ada/5kvxwork.ads index 85cbe3d8021..89e64f4318e 100644 --- a/gcc/ada/5kvxwork.ads +++ b/gcc/ada/5kvxwork.ads @@ -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; diff --git a/gcc/ada/5lintman.adb b/gcc/ada/5lintman.adb index 6737f0094ef..678d43aeba0 100644 --- a/gcc/ada/5lintman.adb +++ b/gcc/ada/5lintman.adb @@ -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 diff --git a/gcc/ada/5lsystem.ads b/gcc/ada/5lsystem.ads index 3ea2fc7cc25..8cdd347e9ac 100644 --- a/gcc/ada/5lsystem.ads +++ b/gcc/ada/5lsystem.ads @@ -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 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; + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; - Default_Priority : constant Priority := - 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; diff --git a/gcc/ada/5mvxwork.ads b/gcc/ada/5mvxwork.ads index 2daf08ca222..72be5d142bf 100644 --- a/gcc/ada/5mvxwork.ads +++ b/gcc/ada/5mvxwork.ads @@ -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; diff --git a/gcc/ada/5ninmaop.adb b/gcc/ada/5ninmaop.adb index 11787bbf928..3164c3fddad 100644 --- a/gcc/ada/5ninmaop.adb +++ b/gcc/ada/5ninmaop.adb @@ -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 -- ---------------------------- diff --git a/gcc/ada/5nosinte.ads b/gcc/ada/5nosinte.ads index 1b7d3a813ad..a62a43081f4 100644 --- a/gcc/ada/5nosinte.ads +++ b/gcc/ada/5nosinte.ads @@ -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; diff --git a/gcc/ada/5ntaprop.adb b/gcc/ada/5ntaprop.adb index fa28e368920..c16306cd20f 100644 --- a/gcc/ada/5ntaprop.adb +++ b/gcc/ada/5ntaprop.adb @@ -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. diff --git a/gcc/ada/5ointerr.adb b/gcc/ada/5ointerr.adb index 31726f2acbc..57491bc4cb1 100644 --- a/gcc/ada/5ointerr.adb +++ b/gcc/ada/5ointerr.adb @@ -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; ----------------------- diff --git a/gcc/ada/5omastop.adb b/gcc/ada/5omastop.adb index ee0ba97e0ef..66fee89f758 100644 --- a/gcc/ada/5omastop.adb +++ b/gcc/ada/5omastop.adb @@ -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; diff --git a/gcc/ada/5oosinte.adb b/gcc/ada/5oosinte.adb index 55c34a6fa36..4ae707df55c 100644 --- a/gcc/ada/5oosinte.adb +++ b/gcc/ada/5oosinte.adb @@ -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; diff --git a/gcc/ada/5osystem.ads b/gcc/ada/5osystem.ads index f5110ed20f3..8e3774e6760 100644 --- a/gcc/ada/5osystem.ads +++ b/gcc/ada/5osystem.ads @@ -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 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; + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; - Default_Priority : constant Priority := - 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; diff --git a/gcc/ada/5otaprop.adb b/gcc/ada/5otaprop.adb index b728f0bccda..a71a09db015 100644 --- a/gcc/ada/5otaprop.adb +++ b/gcc/ada/5otaprop.adb @@ -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); - end if; + Thread_Local_Data_Ptr.Lock_Prio_Level := + Thread_Local_Data_Ptr.Lock_Prio_Level + 1; - -- Request the lock and then update the lock owner data + if L.Priority > Old_Priority then + Set_Temporary_Priority (Self_ID, L.Priority); + end if; - Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT)); - L.Owner_Priority := Old_Priority; - L.Owner_ID := Self_ID.all'Address; + -- Request the lock and then update the lock owner data + + Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT)); + L.Owner_Priority := Old_Priority; + L.Owner_ID := Self_ID.all'Address; + end if; end Write_Lock; procedure Write_Lock (T : Task_ID) is begin - -- 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; diff --git a/gcc/ada/5otaspri.ads b/gcc/ada/5otaspri.ads index dd4fc9e9016..e2a575f344b 100644 --- a/gcc/ada/5otaspri.ads +++ b/gcc/ada/5otaspri.ads @@ -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; diff --git a/gcc/ada/5pvxwork.ads b/gcc/ada/5pvxwork.ads index 47deae2da5b..c29f358aaa3 100644 --- a/gcc/ada/5pvxwork.ads +++ b/gcc/ada/5pvxwork.ads @@ -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; diff --git a/gcc/ada/5qparame.ads b/gcc/ada/5qparame.ads deleted file mode 100644 index 1c42fdcd456..00000000000 --- a/gcc/ada/5qparame.ads +++ /dev/null @@ -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; diff --git a/gcc/ada/5qtaprop.adb b/gcc/ada/5qtaprop.adb index a487d5dce40..6d18563e583 100644 --- a/gcc/ada/5qtaprop.adb +++ b/gcc/ada/5qtaprop.adb @@ -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 (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 - 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; diff --git a/gcc/ada/5qvxwork.ads b/gcc/ada/5qvxwork.ads deleted file mode 100644 index 7f3bd8c2393..00000000000 --- a/gcc/ada/5qvxwork.ads +++ /dev/null @@ -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; diff --git a/gcc/ada/5sintman.adb b/gcc/ada/5sintman.adb index 24f68edea17..97cebf1202d 100644 --- a/gcc/ada/5sintman.adb +++ b/gcc/ada/5sintman.adb @@ -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 diff --git a/gcc/ada/5smastop.adb b/gcc/ada/5smastop.adb deleted file mode 100644 index 4dfc8ad8b22..00000000000 --- a/gcc/ada/5smastop.adb +++ /dev/null @@ -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; diff --git a/gcc/ada/5ssystem.ads b/gcc/ada/5ssystem.ads index 2f30306e808..544f96700aa 100644 --- a/gcc/ada/5ssystem.ads +++ b/gcc/ada/5ssystem.ads @@ -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 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; + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; - Default_Priority : constant Priority := - 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; diff --git a/gcc/ada/5staprop.adb b/gcc/ada/5staprop.adb index e0b56c0f54a..a1959d4bcf5 100644 --- a/gcc/ada/5staprop.adb +++ b/gcc/ada/5staprop.adb @@ -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 # - - begin - Last_Proc := Num_Procs - 1; - - if Last_Proc = -1 then + Last_Proc := Num_Procs - 1; - -- 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 - else - Proc := processorid_t'Value (Proc_Acc.all); - - if Proc < -2 or Proc > Last_Proc then - raise Constraint_Error; - - elsif Proc = -2 then + Result := 0; - -- Use the default configuration + while Proc < Last_Proc loop + Proc := Proc + 1; + Result := p_online (Proc, PR_STATUS); + exit when Result = PR_ONLINE; + end loop; - null; + pragma Assert (Result = PR_ONLINE); + Result := processor_bind (P_PID, P_MYID, Proc, null); + pragma Assert (Result = 0); - 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 + 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); diff --git a/gcc/ada/5stpopse.adb b/gcc/ada/5stpopse.adb index c041c16489e..95c03cbec63 100644 --- a/gcc/ada/5stpopse.adb +++ b/gcc/ada/5stpopse.adb @@ -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; diff --git a/gcc/ada/5svxwork.ads b/gcc/ada/5svxwork.ads index 9ddae2f8145..48330b08ec4 100644 --- a/gcc/ada/5svxwork.ads +++ b/gcc/ada/5svxwork.ads @@ -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; diff --git a/gcc/ada/5tosinte.ads b/gcc/ada/5tosinte.ads index b95708a8e5b..de068af97cb 100644 --- a/gcc/ada/5tosinte.ads +++ b/gcc/ada/5tosinte.ads @@ -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; diff --git a/gcc/ada/5uintman.adb b/gcc/ada/5uintman.adb index 9b11d3baa8e..5073fcaec2b 100644 --- a/gcc/ada/5uintman.adb +++ b/gcc/ada/5uintman.adb @@ -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 diff --git a/gcc/ada/5vasthan.adb b/gcc/ada/5vasthan.adb index 25ef26854cf..bf32f29c383 100644 --- a/gcc/ada/5vasthan.adb +++ b/gcc/ada/5vasthan.adb @@ -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 -- ----------------- diff --git a/gcc/ada/5vinmaop.adb b/gcc/ada/5vinmaop.adb index 0077a248161..c3fb9fe596b 100644 --- a/gcc/ada/5vinmaop.adb +++ b/gcc/ada/5vinmaop.adb @@ -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; ---------------------------- diff --git a/gcc/ada/5vinterr.adb b/gcc/ada/5vinterr.adb index 33e6a1da468..798fd80473d 100644 --- a/gcc/ada/5vinterr.adb +++ b/gcc/ada/5vinterr.adb @@ -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. diff --git a/gcc/ada/5vintman.adb b/gcc/ada/5vintman.adb index e47b5351c3c..fd9e774bd6f 100644 --- a/gcc/ada/5vintman.adb +++ b/gcc/ada/5vintman.adb @@ -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 -- --------------------------- diff --git a/gcc/ada/5vmastop.adb b/gcc/ada/5vmastop.adb index 6cdcd38f373..e2eec9e3de2 100644 --- a/gcc/ada/5vmastop.adb +++ b/gcc/ada/5vmastop.adb @@ -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; diff --git a/gcc/ada/5vparame.ads b/gcc/ada/5vparame.ads index 2788e6620c7..e0a6cc61f96 100644 --- a/gcc/ada/5vparame.ads +++ b/gcc/ada/5vparame.ads @@ -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; diff --git a/gcc/ada/5vsystem.ads b/gcc/ada/5vsystem.ads index 41cebb1e749..72466963772 100644 --- a/gcc/ada/5vsystem.ads +++ b/gcc/ada/5vsystem.ads @@ -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 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; + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; - Default_Priority : constant Priority := - 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; diff --git a/gcc/ada/5vtaprop.adb b/gcc/ada/5vtaprop.adb index 93c11968dd4..afe39b643e5 100644 --- a/gcc/ada/5vtaprop.adb +++ b/gcc/ada/5vtaprop.adb @@ -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 Result /= 0 then - Succeeded := False; - return; - end if; + if not Single_Lock then + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); --- 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); + 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; - 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; - if Result /= 0 then - Succeeded := False; - return; + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); 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); diff --git a/gcc/ada/5vtpopde.adb b/gcc/ada/5vtpopde.adb index 8735af58ff1..902a598f246 100644 --- a/gcc/ada/5vtpopde.adb +++ b/gcc/ada/5vtpopde.adb @@ -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; diff --git a/gcc/ada/5wmemory.adb b/gcc/ada/5wmemory.adb index 77e42e5b773..76ce6f00adc 100644 --- a/gcc/ada/5wmemory.adb +++ b/gcc/ada/5wmemory.adb @@ -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; diff --git a/gcc/ada/5wsystem.ads b/gcc/ada/5wsystem.ads index 70e11949afd..de471a8a456 100644 --- a/gcc/ada/5wsystem.ads +++ b/gcc/ada/5wsystem.ads @@ -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 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 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 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; diff --git a/gcc/ada/5wtaprop.adb b/gcc/ada/5wtaprop.adb index 698b745b690..4f37526bef7 100644 --- a/gcc/ada/5wtaprop.adb +++ b/gcc/ada/5wtaprop.adb @@ -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); diff --git a/gcc/ada/5ysystem.ads b/gcc/ada/5ysystem.ads index ca3d9e52c9a..466b142660e 100644 --- a/gcc/ada/5ysystem.ads +++ b/gcc/ada/5ysystem.ads @@ -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; diff --git a/gcc/ada/5zinterr.adb b/gcc/ada/5zinterr.adb index e7422ef614b..dccc143a6c6 100644 --- a/gcc/ada/5zinterr.adb +++ b/gcc/ada/5zinterr.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $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,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). -- -- -- ------------------------------------------------------------------------------ @@ -46,13 +45,6 @@ -- hardware interrupts, which may be masked or unmasked using routined -- interfaced to the relevant VxWorks system calls. --- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any --- other low-level interface that changes the signal action or --- signal mask needs careful consideration. --- One may achieve the effect of system calls first masking RTS blocked --- (by calling Block_Interrupt) for the signal under consideration. --- This will make all the tasks in RTS blocked for the signal. - -- Once we associate a Signal_Server_Task with an signal, the task never -- goes away, and we never remove the association. On the other hand, it -- is more convenient to terminate an associated Interrupt_Server_Task @@ -72,15 +64,13 @@ -- service requests are ensured via user calls to the Interrupt_Manager -- entries. --- This is the VxWorks version of this package, supporting both signals --- and vectored hardware interrupts. +-- This is the VxWorks version of this package, supporting vectored hardware +-- interrupts. with Unchecked_Conversion; with System.OS_Interface; use System.OS_Interface; -with System.VxWorks; - with Interfaces.VxWorks; with Ada.Task_Identification; @@ -89,39 +79,6 @@ with Ada.Task_Identification; with Ada.Exceptions; -- used for Raise_Exception -with System.Task_Primitives; --- used for RTS_Lock --- Self - -with System.Interrupt_Management; --- used for Reserve --- Interrupt_ID --- Interrupt_Mask --- Abort_Task_Interrupt - -with System.Interrupt_Management.Operations; --- used for Thread_Block_Interrupt --- Thread_Unblock_Interrupt --- Install_Default_Action --- Install_Ignore_Action --- Copy_Interrupt_Mask --- Set_Interrupt_Mask --- Empty_Interrupt_Mask --- Fill_Interrupt_Mask --- Add_To_Interrupt_Mask --- Delete_From_Interrupt_Mask --- Interrupt_Wait --- Interrupt_Self_Process --- Get_Interrupt_Mask --- Set_Interrupt_Mask --- IS_Member --- Environment_Mask --- All_Tasks_Mask -pragma Elaborate_All (System.Interrupt_Management.Operations); - -with System.Error_Reporting; --- used for Shutdown - with System.Task_Primitives.Operations; -- used for Write_Lock -- Unlock @@ -130,9 +87,6 @@ with System.Task_Primitives.Operations; -- Sleep -- Initialize_Lock -with System.Task_Primitives.Interrupt_Operations; --- used for Set_Interrupt_ID - with System.Storage_Elements; -- used for To_Address -- To_Integer @@ -152,21 +106,13 @@ with System.Tasking.Rendezvous; -- used for Call_Simple pragma Elaborate_All (System.Tasking.Rendezvous); -with System.Tasking.Initialization; --- used for Defer_Abort --- Undefer_Abort - package body System.Interrupts is use Tasking; - use System.Error_Reporting; use Ada.Exceptions; package PRI renames System.Task_Primitives; package POP renames System.Task_Primitives.Operations; - package PIO renames System.Task_Primitives.Interrupt_Operations; - package IMNG renames System.Interrupt_Management; - package IMOP renames System.Interrupt_Management.Operations; function To_Ada is new Unchecked_Conversion (System.Tasking.Task_ID, Ada.Task_Identification.Task_Id); @@ -178,12 +124,12 @@ 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 Initialize (Mask : IMNG.Interrupt_Mask); + entry Detach_Interrupt_Entries (T : Task_ID); entry Attach_Handler (New_Handler : Parameterless_Handler; @@ -206,18 +152,9 @@ package body System.Interrupts is E : Task_Entry_Index; Interrupt : Interrupt_ID); - entry Detach_Interrupt_Entries (T : Task_ID); - pragma Interrupt_Priority (System.Interrupt_Priority'First); end Interrupt_Manager; - task type Signal_Server_Task (Interrupt : Interrupt_ID) is - pragma Interrupt_Priority (System.Interrupt_Priority'First + 1); - end Signal_Server_Task; - -- Server task for signal handling - - type Signal_Task_Access is access Signal_Server_Task; - task type Interrupt_Server_Task (Interrupt : Interrupt_ID; Int_Sema : SEM_ID) is -- Server task for vectored hardware interrupt handling @@ -275,33 +212,16 @@ package body System.Interrupts is -- is needed to determine whether to create a new Server_Task. Semaphore_ID_Map : array - (Interrupt_ID range 0 .. System.VxWorks.Num_HW_Interrupts) of SEM_ID := - (others => 0); + (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) + of SEM_ID := (others => 0); -- Array of binary semaphores associated with vectored interrupts -- Note that the last bound should be Max_HW_Interrupt, but this will raise -- Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes -- instead. - Signal_Access_Hold : Signal_Task_Access; - -- Variable for allocating a Signal_Server_Task - Interrupt_Access_Hold : Interrupt_Task_Access; -- Variable for allocating an Interrupt_Server_Task - L : aliased PRI.RTS_Lock; - -- L protects the contents of the above tables for interrupts / signals - -- for which Server_ID (I) = Null_Task. - -- - -- If Server_ID (I) /= Null_Task then protection is via the - -- per-task (TCB) lock of Server_ID (I). - -- - -- For deadlock prevention, L should not be locked after - -- any other lock is held, hence we use PO_Level which is the highest - -- lock level for error checking. - - Task_Lock : array (Interrupt_ID) of Boolean := (others => False); - -- Booleans indicating whether the per task lock is used - Default_Handler : array (HW_Interrupt) of Interfaces.VxWorks.VOIDFUNCPTR; -- Vectored interrupt handlers installed prior to program startup. -- These are saved only when the umbrella handler is installed for @@ -319,25 +239,9 @@ package body System.Interrupts is -- Unbind the handlers for hardware interrupt server tasks at program -- termination. - procedure Lock_Interrupt - (Self_ID : Task_ID; - Interrupt : Interrupt_ID); - -- Protect the tables using L or the 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); - -- Unlock interrupt previously locked by Lock_Interrupt - function Is_Registered (Handler : Parameterless_Handler) return Boolean; - -- Needs comment ??? + -- See if Handler has been "pragma"ed using Interrupt_Handler. + -- Always consider a null handler as registered. procedure Notify_Interrupt (Param : System.Address); -- Umbrella handler for vectored interrupts (not signals) @@ -351,9 +255,6 @@ package body System.Interrupts is -- Install the runtime umbrella handler for a vectored hardware -- interrupt - function To_Signal (S : Interrupt_ID) return IMNG.Interrupt_ID; - -- Convert interrupt ID to signal number. - procedure Unimplemented (Feature : String); pragma No_Return (Unimplemented); -- Used to mark a call to an unimplemented function. Raises Program_Error @@ -374,8 +275,7 @@ package body System.Interrupts is procedure Attach_Handler (New_Handler : Parameterless_Handler; Interrupt : Interrupt_ID; - Static : Boolean := False) - is + Static : Boolean := False) is begin Check_Reserved_Interrupt (Interrupt); Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); @@ -395,7 +295,7 @@ package body System.Interrupts is Int_Ref : System.Address) is Interrupt : constant Interrupt_ID := - Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); + Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); begin Check_Reserved_Interrupt (Interrupt); @@ -431,9 +331,7 @@ package body System.Interrupts is --------------------- function Current_Handler - (Interrupt : Interrupt_ID) - return Parameterless_Handler - is + (Interrupt : Interrupt_ID) return Parameterless_Handler is begin Check_Reserved_Interrupt (Interrupt); @@ -457,8 +355,7 @@ package body System.Interrupts is procedure Detach_Handler (Interrupt : Interrupt_ID; - Static : Boolean := False) - is + Static : Boolean := False) is begin Check_Reserved_Interrupt (Interrupt); Interrupt_Manager.Detach_Handler (Interrupt, Static); @@ -489,8 +386,7 @@ package body System.Interrupts is (Old_Handler : out Parameterless_Handler; New_Handler : Parameterless_Handler; Interrupt : Interrupt_ID; - Static : Boolean := False) - is + Static : Boolean := False) is begin Check_Reserved_Interrupt (Interrupt); Interrupt_Manager.Exchange_Handler @@ -525,10 +421,9 @@ package body System.Interrupts is -- Finalize_Interrupt_Servers -- -------------------------------- - -- Restore default handlers for interrupt servers. Signal servers - -- restore the default handlers when they're aborted. This is called - -- by the Interrupt_Manager task when it receives the abort signal - -- during program finalization. + -- Restore default handlers for interrupt servers. + -- This is called by the Interrupt_Manager task when it receives the abort + -- signal during program finalization. procedure Finalize_Interrupt_Servers is begin @@ -554,17 +449,13 @@ package body System.Interrupts is ------------------------------------- function Has_Interrupt_Or_Attach_Handler - (Object : access Dynamic_Interrupt_Protection) - return Boolean - is + (Object : access Dynamic_Interrupt_Protection) return Boolean is begin return True; end Has_Interrupt_Or_Attach_Handler; function Has_Interrupt_Or_Attach_Handler - (Object : access Static_Interrupt_Protection) - return Boolean - is + (Object : access Static_Interrupt_Protection) return Boolean is begin return True; end Has_Interrupt_Or_Attach_Handler; @@ -628,12 +519,11 @@ package body System.Interrupts is is use Interfaces.VxWorks; - Vec : constant Interrupt_Vector := - INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)); + Vec : constant Interrupt_Vector := + INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)); Old_Handler : constant VOIDFUNCPTR := - intVecGet - (INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt))); - Stat : Interfaces.VxWorks.STATUS; + intVecGet (INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt))); + Stat : Interfaces.VxWorks.STATUS; begin -- Only install umbrella handler when no Ada handler has already been @@ -692,9 +582,6 @@ package body System.Interrupts is -- Is_Registered -- ------------------- - -- See if 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; @@ -725,7 +612,6 @@ package body System.Interrupts is end loop; return False; - end Is_Registered; ----------------- @@ -734,63 +620,12 @@ package body System.Interrupts is function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is begin - if Interrupt < System.VxWorks.Num_HW_Interrupts then - return False; - else - return IMNG.Reserve (To_Signal (Interrupt)); - end if; + return False; end Is_Reserved; - -------------------- - -- 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 - pragma Assert (Server_ID (Interrupt) /= null, - "Task_Lock is true for null server task"); - pragma Assert - (not Ada.Task_Identification.Is_Terminated - (To_Ada (Server_ID (Interrupt))), - "Attempt to lock per task lock of terminated server: " & - "Task_Lock => True"); - - POP.Unlock (L'Access); - POP.Write_Lock (Server_ID (Interrupt)); - - elsif Server_ID (Interrupt) /= Null_Task then - pragma Assert - (not Ada.Task_Identification.Is_Terminated - (To_Ada (Server_ID (Interrupt))), - "Attempt to lock per task lock of terminated server: " & - "Task_Lock => False"); - - Task_Lock (Interrupt) := True; - POP.Unlock (L'Access); - POP.Write_Lock (Server_ID (Interrupt)); - end if; - - end Lock_Interrupt; - - ------------------------ - -- Notify_Interrupt -- - ------------------------ + ---------------------- + -- Notify_Interrupt -- + ---------------------- -- Umbrella handler for vectored hardware interrupts (as opposed to -- signals and exceptions). As opposed to the signal implementation, @@ -859,15 +694,6 @@ package body System.Interrupts is end if; end Register_Interrupt_Handler; - --------------- - -- To_Signal -- - --------------- - - function To_Signal (S : Interrupt_ID) return IMNG.Interrupt_ID is - begin - return IMNG.Interrupt_ID (S - System.VxWorks.Num_HW_Interrupts); - end To_Signal; - ----------------------- -- Unblock_Interrupt -- ----------------------- @@ -908,28 +734,6 @@ package body System.Interrupts is Feature & " not implemented on VxWorks"); end Unimplemented; - ---------------------- - -- Unlock_Interrupt -- - ---------------------- - - procedure Unlock_Interrupt - (Self_ID : Task_ID; - Interrupt : Interrupt_ID) is - begin - if Task_Lock (Interrupt) then - pragma Assert - (not Ada.Task_Identification.Is_Terminated - (To_Ada (Server_ID (Interrupt))), - "Attempt to unlock per task lock of terminated server"); - - POP.Unlock (Server_ID (Interrupt)); - else - POP.Unlock (L'Access); - end if; - - Initialization.Undefer_Abort (Self_ID); - end Unlock_Interrupt; - ----------------------- -- Interrupt_Manager -- ----------------------- @@ -939,9 +743,7 @@ package body System.Interrupts is -- Local Variables -- --------------------- - Intwait_Mask : aliased IMNG.Interrupt_Mask; - Old_Mask : aliased IMNG.Interrupt_Mask; - Self_ID : Task_ID := POP.Self; + Self_Id : constant Task_ID := POP.Self; -------------------- -- Local Routines -- @@ -957,10 +759,6 @@ package body System.Interrupts is -- Otherwise, we have to interrupt Server_Task for status change -- through an abort signal. - -- The following two procedures are labelled Unprotected... in order to - -- indicate that Lock/Unlock_Interrupt operations are needed around - -- around calls to them. - procedure Unprotected_Exchange_Handler (Old_Handler : out Parameterless_Handler; New_Handler : Parameterless_Handler; @@ -978,24 +776,8 @@ package body System.Interrupts is procedure Bind_Handler (Interrupt : Interrupt_ID) is begin - if Interrupt < System.VxWorks.Num_HW_Interrupts then - Install_Umbrella_Handler - (HW_Interrupt (Interrupt), Notify_Interrupt'Access); - - else - -- Mask this task for the given signal so that all tasks - -- are masked for the signal and the actual delivery of the - -- signal will be caught using "sigwait" by the - -- corresponding Server_Task. - - IMOP.Thread_Block_Interrupt (To_Signal (Interrupt)); - -- We have installed a handler or an entry before we called - -- this procedure. If the handler task is waiting to be - -- awakened, do it here. Otherwise, the signal will be - -- discarded. - - POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep); - end if; + Install_Umbrella_Handler + (HW_Interrupt (Interrupt), Notify_Interrupt'Access); end Bind_Handler; -------------------- @@ -1004,44 +786,17 @@ package body System.Interrupts is procedure Unbind_Handler (Interrupt : Interrupt_ID) is S : STATUS; - Ret_Interrupt : IMNG.Interrupt_ID; - - use type IMNG.Interrupt_ID; use type STATUS; begin - if Interrupt < System.VxWorks.Num_HW_Interrupts then - - -- Hardware interrupt + -- Hardware interrupt - Install_Default_Action (HW_Interrupt (Interrupt)); - - -- Flush server task off semaphore, allowing it to terminate - - S := semFlush (Semaphore_ID_Map (Interrupt)); - pragma Assert (S = 0); - - else - -- Currently, there is a handler or an entry attached and - -- the corresponding Server_Task is waiting on "sigwait." - -- We have to wake up the Server_Task and make it - -- wait on a condition variable by sending an - -- Abort_Task_Interrupt + Install_Default_Action (HW_Interrupt (Interrupt)); - -- Make sure corresponding Server_Task is out of its own - -- sigwait state. + -- Flush server task off semaphore, allowing it to terminate - POP.Abort_Task (Server_ID (Interrupt)); - Ret_Interrupt := IMOP.Interrupt_Wait (Intwait_Mask'Access); - pragma Assert (Ret_Interrupt = IMNG.Abort_Task_Interrupt); - - IMOP.Install_Default_Action (To_Signal (Interrupt)); - - -- Unmake the Interrupt for this task in order to allow default - -- action again. - - IMOP.Thread_Unblock_Interrupt (To_Signal (Interrupt)); - end if; + S := semFlush (Semaphore_ID_Map (Interrupt)); + pragma Assert (S = 0); end Unbind_Handler; -------------------------------- @@ -1055,11 +810,9 @@ package body System.Interrupts is Old_Handler : Parameterless_Handler; begin if User_Entry (Interrupt).T /= Null_Task then - -- If an interrupt entry is installed raise -- Program_Error. (propagate it to the caller). - Unlock_Interrupt (Self_ID, Interrupt); Raise_Exception (Program_Error'Identity, "An interrupt entry is already installed"); end if; @@ -1069,11 +822,9 @@ package body System.Interrupts is -- status of the Current_Handler. if not Static and then User_Handler (Interrupt).Static then - -- Trying to detach a static Interrupt Handler. -- raise Program_Error. - Unlock_Interrupt (Self_ID, Interrupt); Raise_Exception (Program_Error'Identity, "Trying to detach a static Interrupt Handler"); end if; @@ -1088,7 +839,6 @@ package body System.Interrupts is if Old_Handler /= null then Unbind_Handler (Interrupt); end if; - end Unprotected_Detach_Handler; ---------------------------------- @@ -1103,13 +853,12 @@ package body System.Interrupts is Restoration : Boolean := False) is begin if User_Entry (Interrupt).T /= Null_Task then - -- If an interrupt entry is already installed, raise -- Program_Error. (propagate it to the caller). - Unlock_Interrupt (Self_ID, Interrupt); - Raise_Exception (Program_Error'Identity, - "An interrupt is already installed"); + Raise_Exception + (Program_Error'Identity, + "An interrupt is already installed"); end if; -- Note : A null handler with Static = True will @@ -1122,15 +871,14 @@ package body System.Interrupts is if not Restoration and then not Static and then (User_Handler (Interrupt).Static - -- Trying to overwrite a static Interrupt Handler with a - -- dynamic Handler + -- Trying to overwrite a static Interrupt Handler with a + -- dynamic Handler - -- The new handler is not specified as an - -- Interrupt Handler by a pragma. + -- The new handler is not specified as an + -- Interrupt Handler by a pragma. - or else not Is_Registered (New_Handler)) + 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 " & @@ -1165,46 +913,23 @@ package body System.Interrupts is Ada.Task_Identification.Is_Terminated (To_Ada (Server_ID (Interrupt)))) then - -- When a new Server_Task is created, it should have its - -- signal mask set to the All_Tasks_Mask. - - IMOP.Set_Interrupt_Mask - (IMOP.All_Tasks_Mask'Access, Old_Mask'Access); - - if Interrupt < System.VxWorks.Num_HW_Interrupts then - - -- Vectored hardware interrupt - - Interrupt_Access_Hold := - new Interrupt_Server_Task - (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY)); - Server_ID (Interrupt) := - To_System (Interrupt_Access_Hold.all'Identity); - - else - -- Signal - - Signal_Access_Hold := new Signal_Server_Task (Interrupt); - Server_ID (Interrupt) := - To_System (Signal_Access_Hold.all'Identity); - end if; - - IMOP.Set_Interrupt_Mask (Old_Mask'Access); + Interrupt_Access_Hold := + new Interrupt_Server_Task + (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY)); + Server_ID (Interrupt) := + To_System (Interrupt_Access_Hold.all'Identity); end if; if (New_Handler = null) and then Old_Handler /= null then - -- Restore default handler Unbind_Handler (Interrupt); elsif Old_Handler = null then - -- Save default handler Bind_Handler (Interrupt); end if; - end Unprotected_Exchange_Handler; -- Start of processing for Interrupt_Manager @@ -1215,56 +940,6 @@ package body System.Interrupts is System.Tasking.Utilities.Make_Independent; - -- Environment task gets its own interrupt mask, saves it, - -- and then masks all signals except the Keep_Unmasked set. - - -- During rendezvous, the Interrupt_Manager receives the old - -- signal mask of the environment task, and sets its own - -- signal mask to that value. - - -- The environment task will call this entry of Interrupt_Manager - -- during elaboration of the body of this package. - - accept Initialize (Mask : IMNG.Interrupt_Mask) do - declare - The_Mask : aliased IMNG.Interrupt_Mask; - - begin - IMOP.Copy_Interrupt_Mask (The_Mask, Mask); - IMOP.Set_Interrupt_Mask (The_Mask'Access); - end; - end Initialize; - - -- Note: All tasks in RTS will have all reserved signals - -- being masked (except the Interrupt_Manager) and Keep_Unmasked - -- signals unmasked when created. - - -- Abort_Task_Interrupt is one of the signals unmasked - -- in all tasks. We mask the signal in this particular task - -- so that "sigwait" is can catch an explicit - -- Abort_Task_Interrupt from a Server_Task. - - -- This sigwaiting is needed to ensure that a Signal_Server_Task is - -- out of its own sigwait state. This extra synchronization is - -- necessary to prevent following scenarios: - - -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to a - -- Signal_Server_Task then changes its own signal mask (OS level). - -- If a signal (corresponding to the Signal_Server_Task) arrives - -- in the meantime, we have the Interrupt_Manager umnasked and - -- the Signal_Server_Task waiting on sigwait. - - -- 2) For unbinding a handler, we install a default action in the - -- Interrupt_Manager. POSIX.1c states that the result of using - -- "sigwait" and "sigaction" simultaneously on the same signal - -- is undefined. Therefore, we need to be informed from the - -- Signal_Server_Task that it is out of its sigwait stage. - - IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); - IMOP.Add_To_Interrupt_Mask - (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt); - IMOP.Thread_Block_Interrupt (IMNG.Abort_Task_Interrupt); - loop -- A block is needed to absorb Program_Error exception @@ -1273,142 +948,108 @@ package body System.Interrupts is begin select - accept Attach_Handler (New_Handler : Parameterless_Handler; Interrupt : Interrupt_ID; Static : Boolean; Restoration : 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 - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : 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 : Interrupt_ID; - Static : 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 - (T : Task_ID; - 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; - - User_Entry (Interrupt) := Entry_Assoc' (T => T, E => E); - - -- Indicate the attachment of interrupt entry in the ATCB. - -- This is needed so when an interrupt entry task terminates - -- the binding can be cleaned. The call to unbinding must be - -- make by the task before it terminates. - - T.Interrupt_Entry := True; - - -- Invoke a corresponding Server_Task if not yet created. - -- Place Task_ID info in Server_ID array. - - if Server_ID (Interrupt) = Null_Task or else - Ada.Task_Identification.Is_Terminated - (To_Ada (Server_ID (Interrupt))) then - - -- When a new Server_Task is created, it should have its - -- signal mask set to the All_Tasks_Mask. - - IMOP.Set_Interrupt_Mask - (IMOP.All_Tasks_Mask'Access, Old_Mask'Access); - - if Interrupt < System.VxWorks.Num_HW_Interrupts then - Interrupt_Access_Hold := new Interrupt_Server_Task - (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY)); - Server_ID (Interrupt) := - To_System (Interrupt_Access_Hold.all'Identity); + or + accept Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + end Exchange_Handler; - else - Signal_Access_Hold := new Signal_Server_Task (Interrupt); - Server_ID (Interrupt) := - To_System (Signal_Access_Hold.all'Identity); + or + accept Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean) + do + Unprotected_Detach_Handler (Interrupt, Static); + end Detach_Handler; + or + accept Bind_Interrupt_To_Entry + (T : Task_ID; + E : Task_Entry_Index; + Interrupt : Interrupt_ID) + do + -- If there is a binding already (either a procedure or an + -- entry), raise Program_Error (propagate it to the caller). + + if User_Handler (Interrupt).H /= null + or else User_Entry (Interrupt).T /= Null_Task + then + Raise_Exception + (Program_Error'Identity, + "A binding for this interrupt is already present"); end if; - IMOP.Set_Interrupt_Mask (Old_Mask'Access); - end if; + User_Entry (Interrupt) := Entry_Assoc' (T => T, E => E); - Bind_Handler (Interrupt); - Unlock_Interrupt (Self_ID, Interrupt); - end Bind_Interrupt_To_Entry; + -- Indicate the attachment of interrupt entry in the ATCB. + -- This is needed so when an interrupt entry task terminates + -- the binding can be cleaned. The call to unbinding must be + -- make by the task before it terminates. - or accept Detach_Interrupt_Entries (T : Task_ID) - do - for Int in Interrupt_ID'Range loop - if not Is_Reserved (Int) then - Lock_Interrupt (Self_ID, Int); + T.Interrupt_Entry := True; - if User_Entry (Int).T = T then + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_ID info in Server_ID array. - User_Entry (Int) := Entry_Assoc' - (T => Null_Task, E => Null_Task_Entry); - Unbind_Handler (Int); - end if; - - Unlock_Interrupt (Self_ID, Int); + if Server_ID (Interrupt) = Null_Task + or else + Ada.Task_Identification.Is_Terminated + (To_Ada (Server_ID (Interrupt))) + then + Interrupt_Access_Hold := new Interrupt_Server_Task + (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY)); + Server_ID (Interrupt) := + To_System (Interrupt_Access_Hold.all'Identity); end if; - end loop; - -- Indicate in ATCB that no interrupt entries are attached. + Bind_Handler (Interrupt); + end Bind_Interrupt_To_Entry; + + or + accept Detach_Interrupt_Entries (T : Task_ID) do + for Int in Interrupt_ID'Range loop + if not Is_Reserved (Int) then + if User_Entry (Int).T = T then + User_Entry (Int) := Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (Int); + end if; + end if; + end loop; - T.Interrupt_Entry := False; - end Detach_Interrupt_Entries; + -- Indicate in ATCB that no interrupt entries are attached. + T.Interrupt_Entry := False; + end Detach_Interrupt_Entries; end select; exception - -- If there is a Program_Error we just want to propagate it to -- the caller and do not want to stop this task. when Program_Error => null; - when E : others => - pragma Assert - (Shutdown ("Interrupt_Manager---exception not expected" & - ASCII.LF & - Exception_Information (E))); + when others => + pragma Assert (False); null; end; end loop; - pragma Assert (Shutdown ("Interrupt_Manager---should not get here")); exception when Standard'Abort_Signal => -- Flush interrupt server semaphores, so they can terminate @@ -1416,149 +1057,6 @@ package body System.Interrupts is raise; end Interrupt_Manager; - ------------------------ - -- Signal_Server_Task -- - ------------------------ - - task body Signal_Server_Task is - Intwait_Mask : aliased IMNG.Interrupt_Mask; - Ret_Interrupt : IMNG.Interrupt_ID; - Self_ID : Task_ID := Self; - Tmp_Handler : Parameterless_Handler; - Tmp_ID : Task_ID; - Tmp_Entry_Index : Task_Entry_Index; - - use type IMNG.Interrupt_ID; - - begin - -- By making this task independent of master, when the process - -- goes away, the Server_Task will terminate gracefully. - - System.Tasking.Utilities.Make_Independent; - - -- Install default action in system level. - - IMOP.Install_Default_Action (To_Signal (Interrupt)); - - -- Note: All tasks in RTS will have all reserved signals - -- masked (except the Interrupt_Manager) and Keep_Unmasked - -- unmasked when created. - - -- Abort_Task_Interrupt is one of the signals unmasked - -- in all tasks. We mask it in this particular task - -- so that "sigwait" can catch an explicit - -- Abort_Task_Interrupt from the Interrupt_Manager. - - -- There are two signals that this task catches through - -- "sigwait." One is the signal it is designated to catch - -- in order to execute an user handler or entry. The other is - -- Abort_Task_Interrupt. This signal is sent from the - -- Interrupt_Manager to inform of status changes (e.g: become Blocked, - -- or a handler or entry is to be detached). - - -- Prepare the mask to be used for sigwait. - - IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); - - IMOP.Add_To_Interrupt_Mask - (Intwait_Mask'Access, To_Signal (Interrupt)); - - IMOP.Add_To_Interrupt_Mask - (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt); - - IMOP.Thread_Block_Interrupt (IMNG.Abort_Task_Interrupt); - - PIO.Set_Interrupt_ID (To_Signal (Interrupt), Self_ID); - - loop - System.Tasking.Initialization.Defer_Abort (Self_ID); - POP.Write_Lock (Self_ID); - - if User_Handler (Interrupt).H = null - and then User_Entry (Interrupt).T = Null_Task - then - - -- No signal binding. If a signal is received, - -- Interrupt_Manager will take the default action. - - Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep; - POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep); - Self_ID.Common.State := Runnable; - - else - -- A handler or an entry is installed. At this point all tasks - -- mask for the signal is masked. Catch it using - -- sigwait. - - -- This task may wake up from sigwait by receiving a signal - -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding - -- a procedure handler or an entry. Or it could be a wake up - -- from status change (Unblocked -> Blocked). If that is not - -- the case, we should execute the attached procedure or entry. - - POP.Unlock (Self_ID); - - Ret_Interrupt := IMOP.Interrupt_Wait (Intwait_Mask'Access); - - if Ret_Interrupt = IMNG.Abort_Task_Interrupt then - -- Inform the Interrupt_Manager of wakeup from above sigwait. - - POP.Abort_Task (Interrupt_Manager_ID); - POP.Write_Lock (Self_ID); - - else - POP.Write_Lock (Self_ID); - - -- Even though we have received a signal, the status may - -- have changed before we got the Self_ID lock above. - -- Therefore we make sure a handler or an entry is still - -- bound and make appropriate call. - -- If there is no call to make we need to regenerate the - -- signal in order not to lose it. - - if User_Handler (Interrupt).H /= null then - - Tmp_Handler := User_Handler (Interrupt).H; - - -- RTS calls should not be made with self being locked. - - POP.Unlock (Self_ID); - - Tmp_Handler.all; - POP.Write_Lock (Self_ID); - - elsif User_Entry (Interrupt).T /= Null_Task then - - Tmp_ID := User_Entry (Interrupt).T; - Tmp_Entry_Index := User_Entry (Interrupt).E; - - -- RTS calls should not be made with self being locked. - - POP.Unlock (Self_ID); - - System.Tasking.Rendezvous.Call_Simple - (Tmp_ID, Tmp_Entry_Index, System.Null_Address); - - POP.Write_Lock (Self_ID); - else - -- This is a situation where this task woke up receiving a - -- signal and before it got the lock the signal was blocked. - -- We do not want to lose the signal so we regenerate it at - -- the process level. - - IMOP.Interrupt_Self_Process (Ret_Interrupt); - end if; - end if; - end if; - - POP.Unlock (Self_ID); - System.Tasking.Initialization.Undefer_Abort (Self_ID); - - -- Undefer abort here to allow a window for this task - -- to be aborted at the time of system shutdown. - end loop; - end Signal_Server_Task; - --------------------------- -- Interrupt_Server_Task -- --------------------------- @@ -1566,7 +1064,7 @@ package body System.Interrupts is -- Server task for vectored hardware interrupt handling task body Interrupt_Server_Task is - Self_ID : Task_ID := Self; + Self_Id : constant Task_ID := Self; Tmp_Handler : Parameterless_Handler; Tmp_ID : Task_ID; Tmp_Entry_Index : Task_Entry_Index; @@ -1607,7 +1105,7 @@ package body System.Interrupts is -- Wait for the Interrupt_Manager to complete its work - POP.Write_Lock (Self_ID); + POP.Write_Lock (Self_Id); -- Delete the associated semaphore @@ -1618,9 +1116,8 @@ package body System.Interrupts is -- Set status for the Interrupt_Manager Semaphore_ID_Map (Interrupt) := 0; - Task_Lock (Interrupt) := False; Server_ID (Interrupt) := Null_Task; - POP.Unlock (Self_ID); + POP.Unlock (Self_Id); exit; end if; @@ -1628,31 +1125,7 @@ package body System.Interrupts is end Interrupt_Server_Task; begin - -- Elaboration code for package System.Interrupts - -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent. Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); - - -- Initialize the lock L. - - Initialization.Defer_Abort (Self); - POP.Initialize_Lock (L'Access, POP.PO_Level); - Initialization.Undefer_Abort (Self); - - -- During the elaboration of this package body we want the RTS to - -- inherit its signal mask from the Environment Task. - - -- The Environment Task should have gotten its mask from - -- the enclosing process during the RTS start up. (See - -- in s-inmaop.adb). Pass the Interrupt_Mask of the Environment - -- task to the Interrupt_Manager. - - -- Note : At this point we know that all tasks (including - -- RTS internal servers) are masked for non-reserved signals - -- (see s-taprop.adb). Only the Interrupt_Manager will have - -- masks set up differently, inheriting the original Environment - -- Task's mask. - - Interrupt_Manager.Initialize (IMOP.Environment_Mask); end System.Interrupts; diff --git a/gcc/ada/5zintman.adb b/gcc/ada/5zintman.adb index 2f58cc2b86f..d49da4dc85c 100644 --- a/gcc/ada/5zintman.adb +++ b/gcc/ada/5zintman.adb @@ -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; diff --git a/gcc/ada/5zosinte.adb b/gcc/ada/5zosinte.adb index c578234c712..747022bf584 100644 --- a/gcc/ada/5zosinte.adb +++ b/gcc/ada/5zosinte.adb @@ -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; - - -- Option flags for taskSpawn - - VX_UNBREAKABLE : constant := 16#0002#; - VX_FP_TASK : constant := 16#0008#; - VX_FP_PRIVATE_ENV : constant := 16#0080#; - VX_NO_STACK_FILL : constant := 16#0100#; - - function taskSpawn - (name : System.Address; -- Pointer to task name - priority : int; - options : int; - stacksize : size_t; - start_routine : 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"); + use type Interfaces.C.int; - function taskPriorityGet - (tid : pthread_t; - pPriority : access int) - return int; - pragma Import (C, taskPriorityGet, "taskPriorityGet"); + Low_Priority : constant := 255; + -- VxWorks native (default) lowest scheduling priority. - 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); diff --git a/gcc/ada/5zosinte.ads b/gcc/ada/5zosinte.ads index 5eddd7296fa..e4cc5585211 100644 --- a/gcc/ada/5zosinte.ads +++ b/gcc/ada/5zosinte.ads @@ -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 -- - ------------------------- - - -- Scheduling policies. - SCHED_FIFO : constant := 1; - SCHED_RR : constant := 2; - SCHED_OTHER : constant := 4; + type ULONG is new unsigned_long; - ------------- - -- Threads -- - ------------- + procedure tickSet (ticks : ULONG); + pragma Import (C, tickSet, "tickSet"); - type Thread_Body is access - function (arg : System.Address) return System.Address; + function tickGet return ULONG; + pragma Import (C, tickGet, "tickGet"); - type pthread_t is private; - subtype Thread_Id is pthread_t; + ----------------------------------------------------- + -- Convenience routine to convert between VxWorks -- + -- priority and Ada priority. -- + ----------------------------------------------------- - null_pthread : constant pthread_t; + function To_VxWorks_Priority (Priority : in int) return int; + pragma Inline (To_VxWorks_Priority); - 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. + -------------------------- + -- VxWorks specific API -- + -------------------------- - 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 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Inline (pthread_mutexattr_init); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Inline (pthread_mutexattr_destroy); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Inline (pthread_mutex_init); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Inline (pthread_mutex_destroy); - - 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. + -- Option flags for taskSpawn + + VX_UNBREAKABLE : constant := 16#0002#; + VX_FP_TASK : constant := 16#0008#; + VX_FP_PRIVATE_ENV : constant := 16#0080#; + VX_NO_STACK_FILL : constant := 16#0100#; + + function taskSpawn + (name : System.Address; -- Pointer to task name + priority : int; + options : int; + stacksize : size_t; + start_routine : System.Address; + arg1 : System.Address; + arg2 : int := 0; + arg3 : int := 0; + arg4 : int := 0; + arg5 : int := 0; + arg6 : int := 0; + arg7 : int := 0; + arg8 : int := 0; + arg9 : int := 0; + arg10 : int := 0) return t_id; + pragma Import (C, taskSpawn, "taskSpawn"); + + procedure taskDelete (tid : t_id); + pragma Import (C, taskDelete, "taskDelete"); + + function kernelTimeSlice (ticks : int) return int; + pragma Import (C, kernelTimeSlice, "kernelTimeSlice"); + + function taskPrioritySet + (tid : t_id; newPriority : int) return int; + pragma Import (C, taskPrioritySet, "taskPrioritySet"); 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. - - function semBCreate (Options : int; Initial_State : int) return SEM_ID; - -- Create a binary semaphore. Returns ID, or 0 if memory could not - -- be allocated + -- Error codes (errno). The lower level 16 bits are the + -- error code, with the upper 16 bits representing the + -- module number in which the error occurred. By convention, + -- the module number is 0 for UNIX errors. VxWorks reserves + -- module numbers 1-500, with the remaining module numbers + -- being available for user applications. + + M_objLib : constant := 61 * 2**16; + -- semTake() failure with ticks = NO_WAIT + S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2; + -- semTake() timeout with ticks > NO_WAIT + S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4; + + type SEM_ID is new System.Address; + -- typedef struct semaphore *SEM_ID; + + -- We use two different kinds of VxWorks semaphores: mutex + -- and binary semaphores. A null ID is returned when + -- a semaphore cannot be created. + + function semBCreate (options : int; initial_state : int) return SEM_ID; + -- Create a binary semaphore. Return ID, or 0 if memory could not + -- be allocated. pragma Import (C, semBCreate, "semBCreate"); - function 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; diff --git a/gcc/ada/5zparame.ads b/gcc/ada/5zparame.ads deleted file mode 100644 index e515df18354..00000000000 --- a/gcc/ada/5zparame.ads +++ /dev/null @@ -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; diff --git a/gcc/ada/5zsystem.ads b/gcc/ada/5zsystem.ads index 3bdb5688a1d..341b60dce31 100644 --- a/gcc/ada/5zsystem.ads +++ b/gcc/ada/5zsystem.ads @@ -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 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 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 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; + 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; Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; Signed_Zeros : constant Boolean := True; - Long_Shifts_Inlined : constant Boolean := False; - High_Integrity_Mode : constant Boolean := False; - Functions_Return_By_DSP : constant Boolean := False; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; ZCX_By_Default : constant Boolean := False; GCC_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False; diff --git a/gcc/ada/5ztaprop.adb b/gcc/ada/5ztaprop.adb index ba273d9cb5a..6dacbd3b7c2 100644 --- a/gcc/ada/5ztaprop.adb +++ b/gcc/ada/5ztaprop.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $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). -- -- -- ------------------------------------------------------------------------------ @@ -46,10 +45,6 @@ pragma Polling (Off); with System.Tasking.Debug; -- used for Known_Tasks -with Interfaces.C; --- used for int --- size_t - with System.Interrupt_Management; -- used for Keep_Unmasked -- Abort_Task_Interrupt @@ -78,11 +73,7 @@ with System.Tasking; with System.Task_Info; -- used for Task_Image -with System.OS_Primitives; --- used for Delay_Modes - -with System.VxWorks; --- used for TASK_DESC +with Interfaces.C; with Unchecked_Conversion; with Unchecked_Deallocation; @@ -92,25 +83,31 @@ package body System.Task_Primitives.Operations is use System.Tasking.Debug; use System.Tasking; use System.Task_Info; - use Interfaces.C; use System.OS_Interface; use System.Parameters; - use System.OS_Primitives; + use type Interfaces.C.int; package SSL renames System.Soft_Links; - ------------------ - -- Local Data -- - ------------------ + subtype int is System.OS_Interface.int; + + Relative : constant := 0; + + ---------------- + -- Local Data -- + ---------------- -- The followings are logically constants, but need to be initialized -- at run time. - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_ID associated with a VxWorks task. + Current_Task : aliased Task_ID; + pragma Export (Ada, Current_Task); + -- Task specific value used to store the Ada Task_ID. - 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. @@ -132,10 +129,7 @@ package body System.Task_Primitives.Operations is FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; -- Indicates whether FIFO_Within_Priorities is set. - Mutex_Protocol : Interfaces.C.int; - - Stack_Limit : aliased System.Address; - pragma Import (C, Stack_Limit, "__gnat_stack_limit"); + Mutex_Protocol : Priority_Type; ----------------------- -- Local Subprograms -- @@ -143,8 +137,6 @@ package body System.Task_Primitives.Operations is procedure Abort_Handler (signo : Signal); - function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); - function To_Address is new Unchecked_Conversion (Task_ID, System.Address); ------------------- @@ -153,13 +145,13 @@ package body System.Task_Primitives.Operations is procedure Abort_Handler (signo : Signal) is Self_ID : constant Task_ID := Self; - Result : Interfaces.C.int; + Result : int; Old_Set : aliased sigset_t; begin if Self_ID.Deferral_Level = 0 - and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level and then - not Self_ID.Aborting + and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + and then not Self_ID.Aborting then Self_ID.Aborting := True; @@ -178,17 +170,9 @@ package body System.Task_Primitives.Operations is ----------------- procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - Task_Descriptor : aliased System.VxWorks.TASK_DESC; - Result : Interfaces.C.int; - begin - if On then - Result := taskInfoGet (T.Common.LL.Thread, - Task_Descriptor'Unchecked_Access); - pragma Assert (Result = 0); - - Stack_Limit := Task_Descriptor.td_pStackLimit; - end if; + -- Nothing needed. + null; end Stack_Guard; ------------------- @@ -205,12 +189,9 @@ 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); - return To_Task_ID (Result); + pragma Assert (Current_Task /= null); + return Current_Task; end Self; ----------------------------- @@ -218,13 +199,13 @@ package body System.Task_Primitives.Operations is ----------------------------- procedure Install_Signal_Handlers; - pragma Inline (Install_Signal_Handlers); + -- Install the default signal handlers for the current task. procedure Install_Signal_Handlers is act : aliased struct_sigaction; old_act : aliased struct_sigaction; Tmp_Set : aliased sigset_t; - Result : Interfaces.C.int; + Result : int; begin act.sa_flags := 0; @@ -248,76 +229,20 @@ package body System.Task_Primitives.Operations is -- Initialize_Lock -- --------------------- - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : access Lock) - is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; + procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_setprotocol - (Attributes'Access, Mutex_Protocol); - pragma Assert (Result = 0); - - Result := pthread_mutexattr_setprioceiling - (Attributes'Access, Interfaces.C.int (Prio)); - pragma Assert (Result = 0); - - Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); + L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); + L.Prio_Ceiling := int (Prio); + L.Protocol := Mutex_Protocol; + pragma Assert (L.Mutex /= 0); end Initialize_Lock; procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_setprotocol - (Attributes'Access, Mutex_Protocol); - pragma Assert (Result = 0); - - Result := pthread_mutexattr_setprioceiling - (Attributes'Access, - Interfaces.C.int (System.Any_Priority'Last)); - pragma Assert (Result = 0); - - Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); + L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); + L.Prio_Ceiling := int (System.Any_Priority'Last); + L.Protocol := Mutex_Protocol; + pragma Assert (L.Mutex /= 0); end Initialize_Lock; ------------------- @@ -325,18 +250,16 @@ package body System.Task_Primitives.Operations is ------------------- procedure Finalize_Lock (L : access Lock) is - Result : Interfaces.C.int; - + Result : int; begin - Result := pthread_mutex_destroy (L); + Result := semDelete (L.Mutex); pragma Assert (Result = 0); end Finalize_Lock; procedure Finalize_Lock (L : access RTS_Lock) is - Result : Interfaces.C.int; - + Result : int; begin - Result := pthread_mutex_destroy (L); + Result := semDelete (L.Mutex); pragma Assert (Result = 0); end Finalize_Lock; @@ -345,31 +268,39 @@ package body System.Task_Primitives.Operations is ---------------- procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - Result : Interfaces.C.int; - + Result : int; begin - Result := pthread_mutex_lock (L); - - -- Assume that the cause of EINVAL is a priority ceiling violation + if L.Protocol = Prio_Protect + and then int (Self.Common.Current_Priority) > L.Prio_Ceiling + then + Ceiling_Violation := True; + return; + else + Ceiling_Violation := False; + end if; - Ceiling_Violation := (Result = EINVAL); - pragma Assert (Result = 0 or else Result = EINVAL); + Result := semTake (L.Mutex, WAIT_FOREVER); + pragma Assert (Result = 0); end Write_Lock; - procedure Write_Lock (L : access RTS_Lock) is - Result : Interfaces.C.int; - + procedure Write_Lock + (L : access RTS_Lock; Global_Lock : Boolean := False) + is + Result : int; begin - Result := pthread_mutex_lock (L); - pragma Assert (Result = 0); + if not Single_Lock or else Global_Lock then + Result := semTake (L.Mutex, WAIT_FOREVER); + pragma Assert (Result = 0); + end if; end Write_Lock; procedure Write_Lock (T : Task_ID) is - Result : Interfaces.C.int; - + Result : int; begin - Result := pthread_mutex_lock (T.Common.LL.L'Access); - pragma Assert (Result = 0); + if not Single_Lock then + Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER); + pragma Assert (Result = 0); + end if; end Write_Lock; --------------- @@ -386,45 +317,82 @@ package body System.Task_Primitives.Operations is ------------ procedure Unlock (L : access Lock) is - Result : Interfaces.C.int; - + Result : int; begin - Result := pthread_mutex_unlock (L); + Result := semGive (L.Mutex); pragma Assert (Result = 0); end Unlock; - procedure Unlock (L : access RTS_Lock) is - Result : Interfaces.C.int; - + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + Result : int; begin - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); + if not Single_Lock or else Global_Lock then + Result := semGive (L.Mutex); + pragma Assert (Result = 0); + end if; end Unlock; procedure Unlock (T : Task_ID) is - Result : Interfaces.C.int; - + Result : int; begin - Result := pthread_mutex_unlock (T.Common.LL.L'Access); - pragma Assert (Result = 0); + if not Single_Lock then + Result := semGive (T.Common.LL.L.Mutex); + pragma Assert (Result = 0); + end if; end Unlock; - ------------- - -- Sleep -- - ------------- - - procedure Sleep (Self_ID : Task_ID; - Reason : System.Tasking.Task_States) is - Result : Interfaces.C.int; + ----------- + -- Sleep -- + ----------- + procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is + Result : int; begin pragma Assert (Self_ID = Self); - Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access); - -- EINTR is not considered a failure. + -- Disable task scheduling. + + Result := taskLock; + + -- Release the mutex before sleeping. + + if Single_Lock then + Result := semGive (Single_RTS_Lock.Mutex); + else + Result := semGive (Self_ID.Common.LL.L.Mutex); + end if; + + pragma Assert (Result = 0); + + -- Indicate that there is another thread waiting on the CV. + + Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.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 (Self_ID.Common.LL.CV.Sem, WAIT_FOREVER); + + if Result /= 0 then + Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting - 1; + pragma Assert (False); + end if; + + -- Take the mutex back. + + if Single_Lock then + Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); + else + Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); + end if; + + pragma Assert (Result = 0); + + -- Reenable task scheduling. - pragma Assert (Result = 0 or else Result = EINTR); + Result := taskUnlock; end Sleep; ----------------- @@ -443,42 +411,78 @@ package body System.Task_Primitives.Operations is Timedout : out Boolean; Yielded : out Boolean) is - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; + Ticks : int; + Result : int; begin Timedout := True; - Yielded := False; + Yielded := True; if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + -- Systematically add one since the first tick will delay + -- *at most* 1 / Rate_Duration seconds, so we need to add one to + -- be on the safe side. + + Ticks := To_Clock_Ticks (Time) + 1; else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + Ticks := To_Clock_Ticks (Time - Monotonic_Clock); end if; - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; + if Ticks > 0 then + -- Disable task scheduling. + + Result := taskLock; + + -- Release the mutex before sleeping. + + if Single_Lock then + Result := semGive (Single_RTS_Lock.Mutex); + else + Result := semGive (Self_ID.Common.LL.L.Mutex); + end if; + + pragma Assert (Result = 0); - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); - Yielded := True; - exit when Abs_Time <= Monotonic_Clock; + -- Indicate that there is another thread waiting on the CV. - if Result = 0 or Result = EINTR then + Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting + 1; - -- Somebody may have called Wakeup for us + -- Perform a blocking operation to take the CV semaphore. + -- Note that a blocking operation in VxWorks will reenable + -- task scheduling. When we are no longer blocked and control + -- is returned, task scheduling will again be disabled. + Result := semTake (Self_ID.Common.LL.CV.Sem, Ticks); + + if Result = 0 then + -- Somebody may have called Wakeup for us + + Timedout := False; + + else + Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting - 1; + + if errno /= S_objLib_OBJ_TIMEOUT then Timedout := False; - exit; end if; + end if; - pragma Assert (Result = ETIMEDOUT); - end loop; + -- Take the mutex back. + + if Single_Lock then + Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); + else + Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); + end if; + + pragma Assert (Result = 0); + + -- Reenable task scheduling. + + Result := taskUnlock; + + else + taskDelay (0); end if; end Timed_Sleep; @@ -487,36 +491,48 @@ package body System.Task_Primitives.Operations is ----------------- -- This is for use in implementing delay statements, so - -- we assume the caller is abort-deferred but is holding - -- no locks. + -- we assume the caller is holding no locks. procedure Timed_Delay (Self_ID : Task_ID; Time : Duration; Mode : ST.Delay_Modes) is - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - Yielded : Boolean := False; + Orig : constant Duration := Monotonic_Clock; + Absolute : Duration; + Ticks : int; + Timedout : Boolean; + Result : int; + begin + SSL.Abort_Defer.all; - -- Only the little window between deferring abort and - -- locking Self_ID is the reason we need to - -- check for pending abort and priority change below! :( + if Single_Lock then + Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); + else + Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); + end if; - SSL.Abort_Defer.all; - Write_Lock (Self_ID); + pragma Assert (Result = 0); if Mode = Relative then - Abs_Time := Time + Check_Time; + Absolute := Orig + Time; + + Ticks := To_Clock_Ticks (Time); + + if Ticks > 0 then + -- The first tick will delay anytime between 0 and + -- 1 / sysClkRateGet seconds, so we need to add one to + -- be on the safe side. + + Ticks := Ticks + 1; + end if; else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + Absolute := Time; + Ticks := To_Clock_Ticks (Time - Orig); end if; - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); + if Ticks > 0 then Self_ID.Common.State := Delay_Sleep; loop @@ -528,24 +544,61 @@ 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); - Yielded := True; - exit when Abs_Time <= Monotonic_Clock; + Timedout := False; + Result := taskLock; + + if Single_Lock then + Result := semGive (Single_RTS_Lock.Mutex); + else + Result := semGive (Self_ID.Common.LL.L.Mutex); + end if; + + pragma Assert (Result = 0); + + -- Indicate that there is another thread waiting on the CV. + + Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting + 1; + + Result := semTake (Self_ID.Common.LL.CV.Sem, Ticks); + + if Result /= 0 then + Self_ID.Common.LL.CV.Waiting := + Self_ID.Common.LL.CV.Waiting - 1; + + if errno = S_objLib_OBJ_TIMEOUT then + Timedout := True; + else + Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); + end if; + end if; + + if Single_Lock then + Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); + else + Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); + end if; + + pragma Assert (Result = 0); - pragma Assert (Result = 0 - or else Result = ETIMEDOUT - or else Result = EINTR); + -- Reenable task scheduling. + + Result := taskUnlock; + + exit when Timedout; end loop; Self_ID.Common.State := Runnable; + else + taskDelay (0); end if; - Unlock (Self_ID); - - if not Yielded then - Result := sched_yield; + if Single_Lock then + Result := semGive (Single_RTS_Lock.Mutex); + else + Result := semGive (Self_ID.Common.LL.L.Mutex); end if; + + pragma Assert (Result = 0); SSL.Abort_Undefer.all; end Timed_Delay; @@ -555,7 +608,8 @@ package body System.Task_Primitives.Operations is function Monotonic_Clock return Duration is TS : aliased timespec; - Result : Interfaces.C.int; + Result : int; + begin Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); pragma Assert (Result = 0); @@ -576,11 +630,30 @@ package body System.Task_Primitives.Operations is ------------ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is - Result : Interfaces.C.int; - + Result : int; begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); + -- Disable task scheduling. + + Result := 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 T.Common.LL.CV.Waiting > 0 then + Result := semGive (T.Common.LL.CV.Sem); + + -- One less thread waiting on the CV. + + T.Common.LL.CV.Waiting := T.Common.LL.CV.Waiting - 1; + + pragma Assert (Result = 0); + end if; + + -- Reenable task scheduling. + + Result := taskUnlock; end Wakeup; ----------- @@ -588,10 +661,9 @@ package body System.Task_Primitives.Operations is ----------- procedure Yield (Do_Yield : Boolean := True) is - Result : Interfaces.C.int; - + Result : int; begin - Result := sched_yield; + Result := taskDelay (0); end Yield; ------------------ @@ -613,25 +685,15 @@ package body System.Task_Primitives.Operations is Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is - Param : aliased struct_sched_param; Array_Item : Integer; - Result : Interfaces.C.int; + Result : int; begin - Param.sched_priority := Interfaces.C.int (Prio); - - if Time_Slice_Val <= 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); - else - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); - end if; - + Result := taskPrioritySet + (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); pragma Assert (Result = 0); if FIFO_Within_Priorities then - -- Annex D requirement [RM D.2.2 par. 9]: -- If the task drops its priority due to the loss of inherited -- priority, it is added at the head of the ready queue for its @@ -676,18 +738,16 @@ package body System.Task_Primitives.Operations is ---------------- procedure Enter_Task (Self_ID : Task_ID) is - Result : Interfaces.C.int; + Result : int; procedure Init_Float; pragma Import (C, Init_Float, "__gnat_init_float"); -- Properly initializes the FPU for PPC/MIPS systems. begin - Self_ID.Common.LL.Thread := pthread_self; - - Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID)); - pragma Assert (Result = 0); - + Self_ID.Common.LL.Thread := taskIdSelf; + Result := taskVarAdd (0, Current_Task'Address); + Current_Task := Self_ID; Init_Float; -- Install the signal handlers. @@ -696,17 +756,17 @@ package body System.Task_Primitives.Operations is Install_Signal_Handlers; - Lock_All_Tasks_List; + Lock_RTS; - for T in Known_Tasks'Range loop - if Known_Tasks (T) = null then - Known_Tasks (T) := Self_ID; - Self_ID.Known_Tasks_Index := T; + 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; -------------- @@ -718,70 +778,25 @@ 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; - begin - Self_ID.Common.LL.Thread := null_pthread; - - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); + Self_ID.Common.LL.CV.Sem := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY); + Self_ID.Common.LL.CV.Waiting := 0; + Self_ID.Common.LL.Thread := 0; - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_mutexattr_setprotocol - (Mutex_Attr'Access, Mutex_Protocol); - 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 + if Self_ID.Common.LL.CV.Sem = 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; - 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); - Succeeded := False; - end if; + Succeeded := True; - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); + if not Single_Lock then + Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); + end if; + end if; end Initialize_TCB; ----------------- @@ -797,22 +812,17 @@ package body System.Task_Primitives.Operations is is use type System.Task_Info.Task_Image_Type; - Adjusted_Stack_Size : Interfaces.C.size_t; - Attributes : aliased pthread_attr_t; - Result : Interfaces.C.int; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); + Adjusted_Stack_Size : size_t; begin if Stack_Size = Unspecified_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); + Adjusted_Stack_Size := size_t (Default_Stack_Size); elsif Stack_Size < Minimum_Stack_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); + Adjusted_Stack_Size := size_t (Minimum_Stack_Size); else - Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); + Adjusted_Stack_Size := size_t (Stack_Size); end if; -- Ask for 4 extra bytes of stack space so that the ATCB @@ -821,7 +831,7 @@ package body System.Task_Primitives.Operations is -- gets the amount of stack requested exclusive of the needs -- of the runtime. -- - -- We also have to allocate 10 more bytes for the task name + -- We also have to allocate n more bytes for the task name -- storage and enough space for the Wind Task Control Block -- which is around 0x778 bytes. VxWorks also seems to carve out -- additional space, so use 2048 as a nice round number. @@ -832,59 +842,43 @@ package body System.Task_Primitives.Operations is -- set the task name to something appropriate. Adjusted_Stack_Size := Adjusted_Stack_Size + 2048; - Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); - pragma Assert (Result = 0); - - Result := pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); - pragma Assert (Result = 0); - - -- Let's check to see if the task has an image string and - -- use that as the VxWorks task name. - if T.Common.Task_Image /= null then + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + if T.Common.Task_Image = null then + T.Common.LL.Thread := taskSpawn + (System.Null_Address, + To_VxWorks_Priority (int (Priority)), + VX_FP_TASK, + Adjusted_Stack_Size, + Wrapper, + To_Address (T)); + else declare - Task_Name : aliased constant String := - T.Common.Task_Image.all & ASCII.NUL; + Name : aliased String (1 .. T.Common.Task_Image'Length + 1); begin - Result := pthread_attr_setname_np - (Attributes'Access, Task_Name'Address); - - -- Since the initial signal mask of a thread is inherited from the - -- creator, and the Environment task has all its signals masked, - -- we do not need to manipulate caller's signal mask at this - -- point. All tasks in RTS will have All_Tasks_Mask initially. - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), + Name (1 .. Name'Last - 1) := T.Common.Task_Image.all; + Name (Name'Last) := ASCII.NUL; + + T.Common.LL.Thread := taskSpawn + (Name'Address, + To_VxWorks_Priority (int (Priority)), + VX_FP_TASK, + Adjusted_Stack_Size, + Wrapper, To_Address (T)); end; - else - -- No specified task name - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); end if; - pragma Assert (Result = 0); - Succeeded := Result = 0; - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result = 0); + if T.Common.LL.Thread = -1 then + Succeeded := False; + else + Succeeded := True; + end if; Task_Creation_Hook (T.Common.LL.Thread); - Set_Priority (T, Priority); end Create_Task; @@ -893,19 +887,21 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_ID) is - Result : Interfaces.C.int; + Result : int; Tmp : Task_ID := T; procedure Free is new Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); begin - T.Common.LL.Thread := null_pthread; + if Single_Lock then + Result := semDelete (T.Common.LL.L.Mutex); + pragma Assert (Result = 0); + end if; - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); + T.Common.LL.Thread := 0; - Result := pthread_cond_destroy (T.Common.LL.CV'Access); + Result := semDelete (T.Common.LL.CV.Sem); pragma Assert (Result = 0); if T.Known_Tasks_Index /= -1 then @@ -922,7 +918,7 @@ package body System.Task_Primitives.Operations is procedure Exit_Task is begin Task_Termination_Hook; - pthread_exit (System.Null_Address); + taskDelete (0); end Exit_Task; ---------------- @@ -930,7 +926,7 @@ package body System.Task_Primitives.Operations is ---------------- procedure Abort_Task (T : Task_ID) is - Result : Interfaces.C.int; + Result : int; begin Result := kill (T.Common.LL.Thread, Signal (Interrupt_Management.Abort_Task_Interrupt)); @@ -941,7 +937,7 @@ package body System.Task_Primitives.Operations is -- Check_Exit -- ---------------- - -- Dummy versions. The only currently working versions is for solaris + -- Dummy versions. The only currently working version is for solaris -- (native). function Check_Exit (Self_ID : ST.Task_ID) return Boolean is @@ -967,23 +963,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 -- @@ -993,7 +989,7 @@ package body System.Task_Primitives.Operations is (T : ST.Task_ID; Thread_Self : Thread_Id) return Boolean is begin - if T.Common.LL.Thread /= null_pthread + if T.Common.LL.Thread /= 0 and then T.Common.LL.Thread /= Thread_Self then return taskSuspend (T.Common.LL.Thread) = 0; @@ -1010,7 +1006,7 @@ package body System.Task_Primitives.Operations is (T : ST.Task_ID; Thread_Self : Thread_Id) return Boolean is begin - if T.Common.LL.Thread /= null_pthread + if T.Common.LL.Thread /= 0 and then T.Common.LL.Thread /= Thread_Self then return taskResume (T.Common.LL.Thread) = 0; @@ -1029,45 +1025,30 @@ 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); end Initialize; begin declare - Result : Interfaces.C.int; - + Result : int; begin if Locking_Policy = 'C' then - Mutex_Protocol := PTHREAD_PRIO_PROTECT; + Mutex_Protocol := Prio_Protect; + elsif Locking_Policy = 'I' then + Mutex_Protocol := Prio_Inherit; else - -- We default to VxWorks native priority inheritence - -- and inversion safe mutexes with no ceiling checks. - Mutex_Protocol := PTHREAD_PRIO_INHERIT; + Mutex_Protocol := Prio_None; end if; if Time_Slice_Val > 0 then - Result := pthread_sched_rr_set_interval - (Interfaces.C.int (Time_Slice_Val)); + Result := kernelTimeSlice + (To_Clock_Ticks + (Duration (Time_Slice_Val) / Duration (1_000_000.0))); end if; - -- Prepare the set of signals that should unblocked in all tasks - Result := sigemptyset (Unblocked_Signal_Mask'Access); pragma Assert (Result = 0); - - for J in Interrupt_Management.Interrupt_ID loop - if Interrupt_Management.Keep_Unmasked (J) then - Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); - pragma Assert (Result = 0); - end if; - end loop; - - Result := pthread_key_create (ATCB_Key'Access, null); - pragma Assert (Result = 0); - - Result := taskVarAdd (getpid, Stack_Limit'Access); - pragma Assert (Result = 0); end; end System.Task_Primitives.Operations; diff --git a/gcc/ada/6vcpp.adb b/gcc/ada/6vcpp.adb index 40dac7bb8dc..33fcd32839c 100644 --- a/gcc/ada/6vcpp.adb +++ b/gcc/ada/6vcpp.adb @@ -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 -- --------------------------------------------- diff --git a/gcc/ada/6vcstrea.adb b/gcc/ada/6vcstrea.adb index 1c4e00c2e0d..cc9e91bd1a3 100644 --- a/gcc/ada/6vcstrea.adb +++ b/gcc/ada/6vcstrea.adb @@ -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 ------------ diff --git a/gcc/ada/7sintman.adb b/gcc/ada/7sintman.adb index dcd56df2a6d..b2dccbadb05 100644 --- a/gcc/ada/7sintman.adb +++ b/gcc/ada/7sintman.adb @@ -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 diff --git a/gcc/ada/7staprop.adb b/gcc/ada/7staprop.adb index 82bffbc2b4c..b34292d9d4f 100644 --- a/gcc/ada/7staprop.adb +++ b/gcc/ada/7staprop.adb @@ -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; - end if; + if Result = 0 then + Result := pthread_mutexattr_setprotocol + (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT); + 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_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; - 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; - if Result /= 0 then - Succeeded := False; - return; + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); 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; diff --git a/gcc/ada/7stpopsp.adb b/gcc/ada/7stpopsp.adb index 03fcdedaca8..c8c13669d79 100644 --- a/gcc/ada/7stpopsp.adb +++ b/gcc/ada/7stpopsp.adb @@ -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)); diff --git a/gcc/ada/9drpc.adb b/gcc/ada/9drpc.adb index 4f9d314d000..8edba9e46fb 100644 --- a/gcc/ada/9drpc.adb +++ b/gcc/ada/9drpc.adb @@ -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_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_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. 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 + 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 - select + -- Wait_On for Do_RPC calls + + -- Wake_Up called by environment task when a Do_RPC receives + -- the result of its remote call - accept New_Request - (Request : out Request_Id_Type) do + select + 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 + 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"); diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2c9d3fd77ec..3791b448461 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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> diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in index e8b128ac28e..1cd8ff6dba6 100644 --- a/gcc/ada/Make-lang.in +++ b/gcc/ada/Make-lang.in @@ -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) - -# use host-gcc + $(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 + +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) - -# use target-gcc + $(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 + 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) ] ; \ @@ -410,6 +378,17 @@ ada.install-common: 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 \ $(RM) $(bindir)/$(target_alias)-gnatprep$(exeext); \ @@ -440,21 +419,6 @@ ada.install-common: 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) ] ; \ then \ $(RM) $(bindir)/$(target_alias)-gnatxref$(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: diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 84f1b0f305e..cd2fb22122a 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -1,5 +1,5 @@ # Makefile for GNU Ada Compiler (GNAT). -# Copyright (C) 1994-2001 Free Software Foundation, Inc. +# Copyright (C) 1994-2002 Free Software Foundation, Inc. #This file is part of GNU CC. @@ -63,7 +63,6 @@ # Variables that exist for you to override. # See below for how to change them for certain systems. -ALLOCA = # Various ways of specifying flags for compilations: # CFLAGS is for the user to override to, e.g., do a bootstrap with -O2. # BOOT_CFLAGS is the value of CFLAGS to pass @@ -114,16 +113,20 @@ INSTALL_DATA_DATE = cp -p MAKEINFO = makeinfo TEXI2DVI = texi2dvi GNATBIND = $(STAGE_PREFIX)gnatbind -C +GNATBIND_FLAGS = -static -x ADA_CFLAGS = ADAFLAGS = -W -Wall -gnatpg -gnata SOME_ADAFLAGS =-gnata FORCE_DEBUG_ADAFLAGS = -g GNATLIBFLAGS = -gnatpg -GNATLIBCFLAGS= -g -O2 -ALL_ADAFLAGS = $(ADA_CFLAGS) $(X_ADAFLAGS) $(T_ADAFLAGS) $(ADAFLAGS) -MOST_ADAFLAGS = $(ADA_CFLAGS) $(X_ADAFLAGS) $(T_ADAFLAGS) $(SOME_ADAFLAGS) -THREAD_KIND=native -GMEM_LIB= +GNATLIBCFLAGS = -g -O2 +GNATLIBCFLAGS_FOR_C = $(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS) -fexceptions \ + -DIN_RTS +ALL_ADAFLAGS = $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) +MOST_ADAFLAGS = $(CFLAGS) $(ADA_CFLAGS) $(SOME_ADAFLAGS) +THREAD_KIND = native +THREADSLIB = +GMEM_LIB = MISCLIB = objext = .o @@ -149,7 +152,7 @@ P = # This is used instead of ALL_CFLAGS when compiling with GCC_FOR_TARGET. # It omits XCFLAGS, and specifies -B./. # It also specifies -B$(tooldir)/ to find as and ld for a cross compiler. -GCC_CFLAGS=$(INTERNAL_CFLAGS) $(X_CFLAGS) $(T_CFLAGS) $(CFLAGS) +GCC_CFLAGS = $(INTERNAL_CFLAGS) $(X_CFLAGS) $(T_CFLAGS) $(CFLAGS) # Tools to use when building a cross-compiler. # These are used because `configure' appends `cross-make' @@ -165,6 +168,7 @@ target=@target@ target_alias=@target_alias@ xmake_file=@dep_host_xmake_file@ tmake_file=@dep_tmake_file@ +host_canonical=@host_canonical@ #version=`sed -e 's/.*\"\([^ \"]*\)[ \"].*/\1/' < $(srcdir)/version.c` #mainversion=`sed -e 's/.*\"\([0-9]*\.[0-9]*\).*/\1/' < $(srcdir)/version.c` @@ -178,16 +182,17 @@ TREE_H = $(srcdir)/../tree.h $(srcdir)/../real.h $(srcdir)/../tree.def \ $(MACHMODE_H) $(srcdir)/../tree-check.h $(srdir)/../version.h \ $(srcdir)/../builtins.def -fsrcdir:=$(shell cd $(srcdir);pwd) -fsrcpfx:=$(shell cd $(srcdir);pwd)/ -fcurdir:=$(shell pwd) -fcurpfx:=$(shell pwd)/ +fsrcdir := $(shell cd $(srcdir);pwd) +fsrcpfx := $(shell cd $(srcdir);pwd)/ +fcurdir := $(shell pwd) +fcurpfx := $(shell pwd)/ # Top build directory, relative to here. top_builddir = .. # Internationalization library. INTLLIBS = @INTLLIBS@ +INTLDEPS = @INTLDEPS@ # Any system libraries needed just for GNAT. SYSLIBS = @GNAT_LIBEXC@ @@ -236,15 +241,15 @@ ALL_CFLAGS = $(INTERNAL_CFLAGS) $(X_CFLAGS) $(T_CFLAGS) $(LOOSE_CFLAGS) \ # Likewise. ALL_CPPFLAGS = $(CPPFLAGS) $(X_CPPFLAGS) $(T_CPPFLAGS) -# Even if ALLOCA is set, don't use it if compiling with GCC. - # This is where we get libiberty.a from. LIBIBERTY = ../../libiberty/libiberty.a # How to link with both our special library facilities # and the system's installed libraries. LIBS = $(INTLLIBS) $(LIBIBERTY) $(SYSLIBS) -LIBDEPS = $(INTLLIBS) $(LIBIBERTY) +LIBDEPS = $(INTLDEPS) $(LIBIBERTY) +TOOLS_LIBS = ../../prefix.o $(LIBGNAT) ../../../libiberty/libiberty.a \ + $(SYSLIBS) # Specify the directories to be searched for header files. # Both . and srcdir are used, in that order, @@ -281,8 +286,8 @@ ADA_INCLUDES_FOR_SUBDIR = -I. -I$(fsrcdir) # Languages-specific object files for Ada. # Object files for gnat1 from C sources. -GNAT1_C_OBJS = b_gnat1.o adaint.o cstreams.o cio.o targtyps.o decl.o \ - misc.o utils.o utils2.o trans.o cuintp.o argv.o raise.o \ +GNAT1_C_OBJS = b_gnat1.o adadecode.o adaint.o cstreams.o cio.o targtyps.o \ + decl.o misc.o utils.o utils2.o trans.o cuintp.o argv.o raise.o \ init.o tracebak.o # Object files from Ada sources that are used by gnat1 @@ -301,7 +306,7 @@ GNAT_ADA_OBJS = \ hlo.o hostparm.o impunit.o \ interfac.o itypes.o inline.o krunch.o lib.o \ layout.o lib-load.o lib-util.o lib-xref.o lib-writ.o live.o \ - namet.o nlists.o nmake.o opt.o osint.o output.o par.o \ + namet.o nlists.o nmake.o opt.o osint.o osint-c.o output.o par.o \ repinfo.o restrict.o rident.o rtsfind.o \ s-assert.o s-parame.o s-stache.o s-stalib.o \ s-imgenu.o s-stoele.o s-soflin.o \ @@ -313,450 +318,60 @@ GNAT_ADA_OBJS = \ sem_elab.o sem_elim.o sem_eval.o sem_intr.o \ sem_maps.o sem_mech.o sem_prag.o sem_res.o \ sem_smem.o sem_type.o sem_util.o sem_vfpt.o sem_warn.o \ - sinfo-cn.o sinfo.o sinput.o sinput-l.o snames.o sprint.o stand.o stringt.o \ - style.o switch.o stylesw.o validsw.o system.o \ + sinfo-cn.o sinfo.o sinput.o sinput-d.o sinput-l.o snames.o sprint.o stand.o \ + stringt.o style.o switch.o switch-c.o stylesw.o validsw.o system.o \ table.o targparm.o tbuild.o tree_gen.o tree_io.o treepr.o treeprs.o \ ttypef.o ttypes.o types.o uintp.o uname.o urealp.o usage.o widechar.o # Object files for gnat executables GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) back_end.o gnat1drv.o + GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) $(EXTRA_GNAT1_OBJS) + GNATBIND_OBJS = \ link.o ada.o adaint.o cstreams.o cio.o ali.o ali-util.o \ - alloc.o bcheck.o binde.o \ + alloc.o a-tags.o a-stream.o bcheck.o binde.o \ binderr.o bindgen.o bindusg.o \ butil.o casing.o csets.o \ - debug.o fmap.o fname.o gnat.o g-hesora.o g-htable.o \ - g-os_lib.o gnatbind.o gnatvsn.o hostparm.o \ - krunch.o namet.o opt.o osint.o output.o rident.o s-crc32.o s-assert.o \ + debug.o fname.o gnat.o g-hesora.o g-htable.o \ + g-os_lib.o s-crc32.o fmap.o gnatbind.o gnatvsn.o hostparm.o \ + krunch.o namet.o opt.o osint.o osint-b.o output.o rident.o s-assert.o \ s-parame.o s-sopco3.o s-sopco4.o s-sopco5.o s-stache.o s-stalib.o \ s-stoele.o s-imgenu.o s-strops.o s-soflin.o s-wchcon.o s-wchjis.o \ - sdefault.o switch.o stylesw.o validsw.o \ + sdefault.o switch.o switch-b.o stylesw.o validsw.o \ system.o table.o tree_io.o types.o widechar.o \ raise.o exit.o argv.o init.o final.o s-wchcnv.o s-exctab.o \ a-except.o s-memory.o s-traceb.o tracebak.o s-mastop.o s-except.o \ - s-secsta.o $(EXTRA_GNATBIND_OBJS) - -GNATCHOP_RTL_OBJS = adaint.o argv.o cio.o cstreams.o exit.o \ - final.o init.o raise.o sysdep.o ada.o a-comlin.o gnat.o a-string.o \ - a-stmaco.o a-strsea.o a-charac.o a-chlat1.o g-except.o s-io.o \ - a-chahan.o a-strunb.o a-strfix.o a-strmap.o g-casuti.o g-comlin.o hostparm.o \ - g-dirope.o g-hesora.o g-htable.o g-regexp.o interfac.o system.o s-assert.o \ - s-parame.o i-cstrea.o s-exctab.o a-ioexce.o s-except.o s-stache.o s-stoele.o \ - s-imgint.o a-tags.o a-stream.o s-strops.o s-sopco3.o s-bitops.o \ - s-sopco4.o s-sopco5.o s-imgenu.o s-soflin.o s-secsta.o a-except.o \ - s-mastop.o s-stalib.o g-os_lib.o s-unstyp.o s-stratt.o s-finroo.o s-finimp.o \ - tracebak.o s-memory.o s-traceb.o a-finali.o a-filico.o s-ficobl.o s-fileio.o \ - a-textio.o s-valuti.o s-valuns.o s-valint.o s-arit64.o - -GNATCHOP_OBJS = gnatchop.o gnatvsn.o \ - $(GNATCHOP_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) - -GNATCMD_RTL_OBJS = adaint.o argv.o raise.o exit.o final.o init.o \ - ada.o a-charac.o a-chahan.o a-comlin.o cstreams.o cio.o \ - a-except.o tracebak.o s-memory.o s-traceb.o s-mastop.o s-except.o \ - a-finali.o a-filico.o a-ioexce.o a-stream.o \ - a-string.o a-strmap.o a-stmaco.o g-htable.o \ - sysdep.o a-tags.o a-textio.o gnat.o g-hesora.o g-os_lib.o \ - interfac.o i-cstrea.o system.o s-assert.o s-bitops.o g-except.o s-exctab.o \ - s-ficobl.o s-fileio.o s-finimp.o s-finroo.o s-imgint.o s-imguns.o \ - s-parame.o s-secsta.o s-stalib.o s-imgenu.o s-stoele.o s-stratt.o \ - s-stache.o s-sopco3.o s-sopco4.o s-sopco5.o \ - s-strops.o s-soflin.o s-wchcon.o s-wchcnv.o s-wchjis.o s-unstyp.o - -GNATCMD_OBJS = alloc.o debug.o fmap.o fname.o gnatcmd.o gnatvsn.o hostparm.o \ - krunch.o namet.o opt.o osint.o casing.o csets.o widechar.o \ - output.o sdefault.o switch.o stylesw.o validsw.o table.o tree_io.o types.o \ - $(GNATCMD_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) - -GNATKR_RTL_OBJS = ada.o a-charac.o a-chahan.o a-chlat1.o a-comlin.o \ - cstreams.o a-finali.o \ - a-string.o a-strmap.o a-stmaco.o a-stream.o a-tags.o \ - gnat.o g-hesora.o g-htable.o interfac.o \ - system.o s-bitops.o g-except.o s-finimp.o s-io.o s-parame.o s-secsta.o \ - s-stopoo.o s-sopco3.o s-sopco4.o s-sopco5.o s-stache.o \ - s-stoele.o s-soflin.o s-stalib.o s-unstyp.o adaint.o \ - raise.o exit.o argv.o cio.o init.o final.o s-finroo.o \ - a-except.o tracebak.o s-memory.o s-traceb.o s-mastop.o s-except.o \ - a-filico.o s-strops.o s-stratt.o s-imgenu.o a-ioexce.o s-exctab.o -GNATKR_OBJS = gnatkr.o gnatvsn.o \ - krunch.o hostparm.o $(GNATKR_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) - -GNATLINK_RTL_OBJS = \ - adaint.o argv.o cio.o cstreams.o \ - exit.o init.o final.o raise.o tracebak.o \ - ada.o a-comlin.o a-except.o \ - gnat.o g-hesora.o g-htable.o g-os_lib.o \ - interfac.o i-cstrea.o \ - system.o s-assert.o s-except.o s-exctab.o s-mastop.o \ - s-parame.o s-secsta.o s-soflin.o s-sopco3.o s-sopco4.o \ - s-stache.o s-stalib.o s-stoele.o s-imgenu.o s-strops.o \ - s-memory.o s-traceb.o s-wchcnv.o s-wchcon.o s-wchjis.o + s-secsta.o \ + atree.o scans.o einfo.o sinfo.o scn.o sinput.o sinput-l.o targparm.o \ + errout.o style.o stand.o lib.o uintp.o elists.o nlists.o stringt.o snames.o \ + uname.o urealp.o \ + $(EXTRA_GNATBIND_OBJS) GNATLINK_OBJS = gnatlink.o link.o \ - alloc.o debug.o fmap.o gnatvsn.o hostparm.o namet.o \ - opt.o osint.o output.o sdefault.o stylesw.o validsw.o \ - switch.o table.o tree_io.o types.o widechar.o \ - $(GNATLINK_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) - -GNATLS_RTL_OBJS = \ - ada.o \ - adaint.o \ - argv.o \ - a-charac.o \ - a-chahan.o \ - cio.o \ - a-comlin.o \ - cstreams.o \ - a-except.o \ - exit.o \ - a-filico.o \ - final.o \ - a-finali.o \ - init.o \ - a-ioexce.o \ - raise.o \ - a-stmaco.o \ - a-stream.o \ - a-strfix.o \ - a-string.o \ - a-strmap.o \ - a-strsea.o \ - a-strunb.o \ - sysdep.o \ - a-tags.o \ - a-textio.o \ - tracebak.o \ - gnat.o \ - g-casuti.o \ - g-dirope.o \ - g-except.o \ - g-hesora.o \ - g-htable.o \ - g-os_lib.o \ - g-regexp.o \ - interfac.o \ - i-cstrea.o \ - system.o \ - s-assert.o \ - s-bitops.o \ - s-crc32.o \ - s-except.o \ - s-exctab.o \ - s-finroo.o \ - s-finimp.o \ - s-ficobl.o \ - s-fileio.o \ - s-imgenu.o \ - s-imgint.o \ - s-io.o \ - s-mastop.o \ - s-parame.o \ - s-secsta.o \ - s-soflin.o \ - s-sopco3.o \ - s-sopco4.o \ - s-sopco5.o \ - s-stache.o \ - s-stalib.o \ - s-stoele.o \ - s-stratt.o \ - s-strops.o \ - s-memory.o \ - s-traceb.o \ - s-valenu.o \ - s-valuti.o \ - s-wchcnv.o \ - s-wchcon.o \ - s-wchjis.o - -GNATLS_OBJS = \ - ali.o \ - ali-util.o \ - alloc.o \ - atree.o \ - binderr.o \ - butil.o \ - casing.o \ - csets.o \ - debug.o \ - einfo.o \ - elists.o \ - errout.o \ - fmap.o \ - fname.o \ - gnatls.o \ - gnatvsn.o \ - hostparm.o \ - krunch.o \ - lib.o \ - mlib.o \ - mlib-fil.o \ - mlib-tgt.o \ - mlib-utl.o \ - namet.o \ - nlists.o \ - opt.o \ - osint.o \ - output.o \ - prj.o \ - prj-attr.o \ - prj-com.o \ - prj-dect.o \ - prj-env.o \ - prj-ext.o \ - prj-nmsc.o \ - prj-pars.o \ - prj-part.o \ - prj-proc.o \ - prj-strt.o \ - prj-tree.o \ - prj-util.o \ - rident.o \ - scans.o \ - scn.o \ - sdefault.o \ - sinfo.o \ - sinfo-cn.o \ - sinput.o \ - sinput-p.o \ - snames.o \ - stand.o \ - stringt.o \ - style.o \ - stylesw.o \ - validsw.o \ - switch.o \ - table.o \ - tree_io.o \ - uintp.o \ - uname.o \ - urealp.o \ - types.o \ - widechar.o $(GNATLS_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) - -GNATMAKE_RTL_OBJS = adaint.o argv.o raise.o exit.o a-comlin.o \ - cio.o cstreams.o a-except.o s-mastop.o s-except.o final.o init.o \ - a-finali.o a-filico.o s-finroo.o s-finimp.o s-ficobl.o\ - a-charac.o a-chahan.o a-string.o a-strfix.o a-strmap.o a-strunb.o \ - a-stmaco.o a-strsea.o a-textio.o s-bitops.o sysdep.o \ - s-imgint.o s-stratt.o \ - a-tags.o a-stream.o \ - a-ioexce.o \ - tracebak.o s-memory.o s-traceb.o \ - gnat.o g-dirope.o g-os_lib.o g-hesora.o g-except.o \ - i-cstrea.o \ - s-parame.o s-stache.o s-stalib.o s-wchcon.o s-wchjis.o \ - s-imgenu.o s-assert.o s-secsta.o s-stoele.o s-soflin.o s-fileio.o \ - s-valenu.o s-valuti.o g-casuti.o \ - system.o s-exctab.o s-strops.o s-sopco3.o s-sopco4.o s-sopco5.o \ - g-htable.o s-io.o g-regexp.o s-crc32.o s-wchcnv.o + ali.o alloc.o butil.o casing.o csets.o debug.o fmap.o fname.o gnatvsn.o \ + hostparm.o namet.o opt.o osint.o output.o rident.o sdefault.o stylesw.o \ + switch.o table.o tree_io.o types.o validsw.o widechar.o GNATMAKE_OBJS = ali.o ali-util.o \ alloc.o atree.o binderr.o butil.o casing.o csets.o debug.o einfo.o elists.o \ errout.o fmap.o fname.o fname-uf.o fname-sf.o \ gnatmake.o gnatvsn.o hostparm.o krunch.o lib.o make.o makeusg.o \ mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o mlib-utl.o \ - namet.o nlists.o opt.o osint.o output.o \ + namet.o nlists.o opt.o osint.o osint-m.o output.o \ prj.o prj-attr.o prj-com.o prj-dect.o prj-env.o prj-ext.o prj-nmsc.o \ prj-pars.o prj-part.o prj-proc.o prj-strt.o prj-tree.o prj-util.o \ rident.o scans.o scn.o sdefault.o sfn_scan.o sinfo.o sinfo-cn.o \ sinput.o sinput-l.o sinput-p.o \ - snames.o stand.o stringt.o style.o stylesw.o validsw.o switch.o\ - table.o tree_io.o types.o \ - uintp.o uname.o urealp.o usage.o widechar.o \ - $(GNATMAKE_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) - -GNATMEM_RTL_OBJS = \ -adaint.o \ -argv.o \ -cio.o \ -cstreams.o \ -exit.o \ -final.o \ -init.o \ -raise.o \ -sysdep.o \ -ada.o \ -a-comlin.o \ -a-except.o \ -a-filico.o \ -a-finali.o \ -a-flteio.o \ -a-inteio.o \ -a-ioexce.o \ -a-stream.o \ -a-tags.o \ -a-textio.o \ -a-tiflau.o \ -a-tigeau.o \ -a-tiinau.o \ -a-tiocst.o \ -gnat.o \ -g-casuti.o \ -g-hesora.o \ -g-htable.o \ -g-os_lib.o \ -gnatvsn.o \ -interfac.o \ -i-cstrea.o \ -system.o \ -s-assert.o \ -s-except.o \ -s-exctab.o \ -s-exngen.o \ -s-exnllf.o \ -s-fatllf.o \ -s-ficobl.o \ -s-fileio.o \ -s-finimp.o \ -s-finroo.o \ -s-imgbiu.o \ -s-imgenu.o \ -s-imgint.o \ -s-imgllb.o \ -s-imglli.o \ -s-imgllu.o \ -s-imgllw.o \ -s-imgrea.o \ -s-imguns.o \ -s-imgwiu.o \ -tracebak.o \ -s-memory.o \ -s-traceb.o \ -s-mastop.o \ -s-parame.o \ -s-powtab.o \ -s-secsta.o \ -s-sopco3.o \ -s-sopco4.o \ -s-sopco5.o \ -s-stache.o \ -s-stalib.o \ -s-stoele.o \ -s-stratt.o \ -s-strops.o \ -s-soflin.o \ -s-unstyp.o \ -s-valllu.o \ -s-vallli.o \ -s-valint.o \ -s-valrea.o \ -s-valuns.o \ -s-valuti.o -GNATMEM_OBJS = gnatmem.o memroot.o gmem.o \ - $(GNATMEM_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) - -GNATPREP_RTL_OBJS = adaint.o argv.o raise.o exit.o final.o init.o \ - ada.o a-charac.o a-chahan.o a-comlin.o cstreams.o cio.o \ - a-except.o tracebak.o s-memory.o s-traceb.o s-mastop.o s-except.o \ - a-finali.o a-filico.o a-ioexce.o a-stream.o a-string.o a-strmap.o \ - a-stmaco.o a-strfix.o s-imgenu.o a-strsea.o a-strunb.o \ - sysdep.o a-tags.o a-textio.o gnat.o g-hesora.o s-io.o \ - g-casuti.o g-dirope.o g-os_lib.o g-regexp.o g-comlin.o i-cstrea.o \ - system.o s-bitops.o g-except.o s-exctab.o s-ficobl.o s-fileio.o s-finimp.o \ - s-finroo.o s-imgint.o s-parame.o s-secsta.o s-stache.o s-stalib.o \ - s-stoele.o s-sopco3.o s-sopco4.o s-sopco5.o s-arit64.o \ - s-stratt.o s-strops.o s-soflin.o s-unstyp.o - -GNATPREP_OBJS = gnatprep.o gnatvsn.o \ - hostparm.o $(GNATPREP_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) - -GNATPSTA_RTL_OBJS = adaint.o argv.o cstreams.o cio.o \ - deftarg.o a-except.o targtyps.o tracebak.o s-memory.o s-traceb.o \ - s-mastop.o s-except.o exit.o a-filico.o final.o a-finali.o init.o \ - a-ioexce.o raise.o a-stream.o get_targ.o gnat.o g-hesora.o \ - sysdep.o a-tags.o a-textio.o i-cstrea.o system.o s-assert.o \ - s-exctab.o s-fatllf.o s-ficobl.o s-fileio.o s-finimp.o s-finroo.o \ - s-imgint.o s-imgrea.o s-imglli.o s-imgllu.o s-imguns.o s-parame.o \ - s-powtab.o s-sopco3.o s-sopco4.o s-sopco5.o s-secsta.o s-stache.o \ - s-stalib.o s-stoele.o s-stratt.o s-strops.o s-soflin.o \ - s-imgenu.o g-htable.o - -GNATPSTA_OBJS = gnatpsta.o types.o ttypes.o \ - gnatvsn.o ttypef.o $(GNATPSTA_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) - -GNATPSYS_RTL_OBJS = adaint.o argv.o cstreams.o cio.o \ - a-except.o tracebak.o s-memory.o s-traceb.o s-mastop.o s-except.o exit.o \ - a-filico.o final.o a-finali.o init.o a-ioexce.o \ - raise.o a-stream.o \ - sysdep.o a-tags.o a-textio.o i-cstrea.o system.o s-assert.o \ - gnat.o g-hesora.o g-htable.o s-imgenu.o \ - s-exctab.o s-fatllf.o s-ficobl.o s-fileio.o s-finimp.o s-finroo.o \ - s-imgint.o s-imgrea.o s-imglli.o s-imgllu.o s-imguns.o s-parame.o \ - s-powtab.o s-secsta.o s-stache.o s-stalib.o s-stoele.o s-stratt.o \ - s-strops.o s-soflin.o s-sopco3.o s-sopco4.o s-sopco5.o - -GNATPSYS_OBJS = gnatpsys.o \ - gnatvsn.o $(GNATPSYS_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) - -GNATXREF_RTL_OBJS = \ - adaint.o argv.o cio.o cstreams.o \ - exit.o init.o final.o raise.o sysdep.o tracebak.o \ - ada.o a-charac.o a-chlat1.o gnat.o g-casuti.o g-hesora.o \ - g-htable.o interfac.o system.o i-cstrea.o s-parame.o s-exctab.o \ - a-ioexce.o a-string.o s-assert.o s-except.o \ - s-imgenu.o s-stoele.o s-mastop.o \ - s-imgint.o a-comlin.o s-soflin.o s-stache.o s-secsta.o s-stalib.o \ - g-os_lib.o s-strops.o a-tags.o a-stream.o s-sopco3.o s-sopco4.o \ - s-sopco5.o s-memory.o s-traceb.o a-except.o s-unstyp.o a-strmap.o \ - a-stmaco.o s-io.o \ - a-chahan.o a-strsea.o a-strfix.o s-stratt.o s-finroo.o g-except.o \ - s-bitops.o s-finimp.o a-finali.o a-filico.o a-strunb.o g-dirope.o \ - g-comlin.o s-ficobl.o s-fileio.o a-textio.o g-regexp.o g-io_aux.o \ - s-valuti.o s-valuns.o s-valint.o s-wchcon.o s-wchjis.o s-wchcnv.o - -GNATXREF_OBJS = gnatxref.o xr_tabls.o xref_lib.o \ - alloc.o debug.o fmap.o gnatvsn.o hostparm.o types.o output.o \ - sdefault.o stylesw.o validsw.o tree_io.o opt.o table.o osint.o \ - switch.o widechar.o namet.o \ - $(GNATXREF_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) - -GNATFIND_RTL_OBJS = \ - adaint.o argv.o cio.o cstreams.o \ - exit.o init.o final.o raise.o sysdep.o tracebak.o \ - ada.o a-chahan.o a-charac.o a-chlat1.o a-comlin.o a-except.o \ - a-filico.o a-finali.o a-ioexce.o a-stmaco.o a-stream.o \ - a-strfix.o a-string.o a-strmap.o a-strsea.o a-strunb.o \ - a-tags.o a-textio.o \ - gnat.o g-casuti.o g-comlin.o g-dirope.o g-except.o \ - g-hesora.o g-htable.o g-io_aux.o g-os_lib.o g-regexp.o \ - interfac.o i-cstrea.o s-io.o \ - system.o s-assert.o s-bitops.o s-except.o s-exctab.o \ - s-imgenu.o s-ficobl.o s-fileio.o s-finimp.o s-finroo.o s-imgint.o \ - s-mastop.o s-parame.o s-secsta.o s-soflin.o s-sopco3.o \ - s-sopco4.o s-sopco5.o s-stache.o s-stalib.o s-stoele.o \ - s-stratt.o s-strops.o s-memory.o s-traceb.o s-unstyp.o s-valint.o \ - s-valuns.o s-valuti.o s-wchcnv.o s-wchcon.o s-wchjis.o - -GNATFIND_OBJS = gnatfind.o xr_tabls.o xref_lib.o \ - alloc.o debug.o fmap.o gnatvsn.o hostparm.o namet.o opt.o \ - osint.o output.o sdefault.o stylesw.o validsw.o switch.o table.o \ - tree_io.o types.o widechar.o \ - $(GNATFIND_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) - -GNATDLL_RTL_OBJS = \ - adaint.o argv.o cio.o cstreams.o \ - exit.o init.o final.o raise.o sysdep.o tracebak.o \ - a-charac.o a-chlat1.o a-chahan.o a-comlin.o a-except.o a-filico.o \ - a-finali.o a-ioexce.o a-stream.o a-strfix.o a-string.o a-strmap.o \ - a-strsea.o a-stmaco.o a-strunb.o a-tags.o a-textio.o ada.o \ - g-casuti.o g-comlin.o g-dirope.o g-except.o g-hesora.o g-htable.o \ - g-os_lib.o g-regexp.o gnat.o \ - i-cstrea.o interfac.o s-io.o \ - s-bitops.o s-except.o s-exctab.o s-ficobl.o s-fileio.o s-finimp.o \ - s-finroo.o s-imgint.o s-mastop.o s-parame.o s-secsta.o s-soflin.o \ - s-sopco3.o s-sopco4.o s-stache.o s-stalib.o s-stoele.o s-stratt.o \ - s-strops.o s-memory.o s-traceb.o s-unstyp.o system.o - -GNATDLL_OBJS = \ - gnatdll.o gnatvsn.o mdll.o mdllfile.o mdlltool.o sdefault.o types.o \ - $(GNATDLL_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) + snames.o stand.o stringt.o style.o stylesw.o validsw.o switch.o switch-m.o \ + switch-c.o table.o targparm.o tree_io.o types.o \ + uintp.o uname.o urealp.o usage.o widechar.o # Convert the target variable into a space separated list of architecture, # manufacturer, and operating system and assign each of those to its own # variable. +host:=$(subst -, ,$(host_canonical)) targ:=$(subst -, ,$(target)) arch:=$(word 1,$(targ)) ifeq ($(words $(targ)),2) @@ -787,15 +402,15 @@ s-taspri.ads<5ntaspri.ads # option will always be present and last in this flag, so that we can have # $(SO_OPTS)libgnat-x.xx -SO_OPTS=-Wl,-soname, +SO_OPTS = -Wl,-soname, # Default gnatlib-shared target. # This is needed on some targets to use a different gnatlib-shared target, e.g # gnatlib-shared-dual -GNATLIB_SHARED=gnatlib-shared-default +GNATLIB_SHARED = gnatlib-shared-default # default value for gnatmake's target dependent file -MLIB_TGT=mlib-tgt +MLIB_TGT = mlib-tgt # $(filter-out PATTERN...,TEXT) removes all PATTERN words from TEXT. # $(strip STRING) removes leading and trailing spaces from STRING. @@ -826,11 +441,13 @@ ifeq ($(strip $(filter-out %86 os2 OS2 os2_emx,$(arch) $(osys))),) i-os2thr.o endif -ifeq ($(strip $(filter-out %86 interix,$(arch) $(osys))),) +ifeq ($(strip $(filter-out %86 interix%,$(arch) $(osys))),) LIBGNAT_TARGET_PAIRS = \ + a-excpol.adb<4hexcpol.adb \ a-intnam.ads<4pintnam.ads \ a-numaux.adb<86numaux.adb \ a-numaux.ads<86numaux.ads \ + g-soccon.ads<3psoccon.ads \ s-inmaop.adb<7sinmaop.adb \ s-intman.adb<7sintman.adb \ s-mastop.adb<5omastop.adb \ @@ -838,25 +455,17 @@ ifeq ($(strip $(filter-out %86 interix,$(arch) $(osys))),) s-osinte.ads<5posinte.ads \ s-osprim.adb<5posprim.adb \ s-taprop.adb<7staprop.adb \ + system.ads<5psystem.ads \ s-taspri.ads<7staspri.ads \ s-tpopsp.adb<7stpopsp.adb - THREADSLIB=-lgthreads -lmalloc - -# Work around for gcc optimization bug wrt cxa5a09 -a-numaux.o : a-numaux.adb a-numaux.ads - $(ADAC) -c $(ALL_ADAFLAGS) -O2 $(ADA_INCLUDES) $< - -# Work around for gcc optimization bug wrt cxf3a01 -a-teioed.o : a-teioed.adb a-teioed.ads - $(ADAC) -c $(ALL_ADAFLAGS) -O0 $(ADA_INCLUDES) $< - + THREADSLIB = -lgthreads -lmalloc endif # sysv5uw is SCO UnixWare 7 ifeq ($(strip $(filter-out %86 sysv5uw%,$(arch) $(osys))),) LIBGNAT_TARGET_PAIRS = \ - a-excpol.adb<4hexcpol.adb \ + a-excpol.adb<4wexcpol.adb \ a-intnam.ads<41intnam.ads \ a-numaux.adb<86numaux.adb \ a-numaux.ads<86numaux.ads \ @@ -869,62 +478,16 @@ ifeq ($(strip $(filter-out %86 sysv5uw%,$(arch) $(osys))),) s-taprop.adb<7staprop.adb \ s-taspri.ads<7staspri.ads \ s-tpopsp.adb<5atpopsp.adb \ + system.ads<51system.ads \ g-soccon.ads<31soccon.ads \ g-soliop.ads<31soliop.ads - THREADSLIB=-lthread - SO_OPTS=-Wl,-h, - GNATLIB_SHARED=gnatlib-shared-dual + THREADSLIB = -lthread + SO_OPTS = -Wl,-h, + GNATLIB_SHARED = gnatlib-shared-dual LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/')) endif -ifeq ($(strip $(filter-out sparc sun sunos4%,$(targ))),) - LIBGNAT_TARGET_PAIRS = \ - a-intnam.ads<4uintnam.ads \ - s-inmaop.adb<7sinmaop.adb \ - s-intman.adb<5uintman.adb \ - s-osinte.adb<7sosinte.adb \ - s-osinte.ads<5uosinte.ads \ - s-osprim.adb<5posprim.adb \ - s-taprop.adb<7staprop.adb \ - s-taspri.ads<7staspri.ads \ - s-tpopsp.adb<7stpopsp.adb -endif - -ifeq ($(strip $(filter-out alpha% dec vms%,$(targ))),) - LIBGNAT_TARGET_PAIRS = \ - a-caldel.adb<4vcaldel.adb \ - a-calend.adb<4vcalend.adb \ - a-calend.ads<4vcalend.ads \ - a-excpol.adb<4wexcpol.adb \ - a-intnam.ads<4vintnam.ads \ - i-cstrea.adb<6vcstrea.adb \ - i-cpp.adb<6vcpp.adb \ - interfac.ads<6vinterf.ads \ - s-asthan.adb<5vasthan.adb \ - s-inmaop.adb<5vinmaop.adb \ - s-interr.adb<5vinterr.adb \ - s-intman.adb<5vintman.adb \ - s-intman.ads<5vintman.ads \ - s-mastop.adb<5vmastop.adb \ - s-osinte.adb<5vosinte.adb \ - s-osinte.ads<5vosinte.ads \ - s-osprim.adb<5vosprim.adb \ - s-osprim.ads<5vosprim.ads \ - s-parame.ads<5vparame.ads \ - s-taprop.adb<5vtaprop.adb \ - s-taspri.ads<5vtaspri.ads \ - s-tpopde.adb<5vtpopde.adb \ - s-tpopde.ads<5vtpopde.ads \ - s-vaflop.adb<5vvaflop.adb \ - system.ads<5vsystem.ads - - GNATLIB_SHARED=gnatlib-shared-vms - EXTRA_LIBGNAT_SRCS=vmshandler.asm - EXTRA_LIBGNAT_OBJS=vmshandler.o - EXTRA_GNATRTL_TASKING_OBJS=s-tpopde.o -endif - ifeq ($(strip $(filter-out alpha% dec vx%,$(targ))),) LIBGNAT_TARGET_PAIRS = \ a-sytaco.ads<4zsytaco.ads \ @@ -938,11 +501,14 @@ ifeq ($(strip $(filter-out alpha% dec vx%,$(targ))),) s-osinte.ads<5zosinte.ads \ s-osprim.adb<5zosprim.adb \ s-taprop.adb<5ztaprop.adb \ - s-taspri.ads<7staspri.ads \ + s-taspri.ads<5ztaspri.ads \ s-vxwork.ads<5avxwork.ads \ + g-soccon.ads<3zsoccon.ads \ + g-socthi.ads<3zsocthi.ads \ + g-socthi.adb<3zsocthi.adb \ system.ads<5zsystem.ads - EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o + EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o endif @@ -958,18 +524,25 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(targ))),) s-osinte.adb<5zosinte.adb \ s-osinte.ads<5zosinte.ads \ s-osprim.adb<5zosprim.adb \ - s-parame.ads<5zparame.ads \ s-taprop.adb<5ztaprop.adb \ - s-taspri.ads<7staspri.ads \ + s-taspri.ads<5ztaspri.ads \ s-vxwork.ads<5kvxwork.ads \ + g-soccon.ads<3zsoccon.ads \ + g-socthi.ads<3zsocthi.ads \ + g-socthi.adb<3zsocthi.adb \ system.ads<5ksystem.ads - EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o + EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o -# ??? work around a gcc -O2 bug on m68k -s-interr.o : s-interr.adb s-interr.ads - $(ADAC) -c $(ALL_ADAFLAGS) -O1 $(ADA_INCLUDES) $< + ifeq ($(strip $(filter-out yes,$(TRACE))),) + LIBGNAT_TARGET_PAIRS += \ + s-traces.adb<7straces.adb \ + s-tratas.adb<7stratas.adb \ + s-trafor.adb<7strafor.adb \ + s-trafor.ads<7strafor.ads \ + s-tfsetr.adb<5ztfsetr.adb + endif endif ifeq ($(strip $(filter-out powerpc% wrs vx%,$(targ))),) @@ -985,28 +558,13 @@ ifeq ($(strip $(filter-out powerpc% wrs vx%,$(targ))),) s-osinte.ads<5zosinte.ads \ s-osprim.adb<5zosprim.adb \ s-taprop.adb<5ztaprop.adb \ - s-taspri.ads<7staspri.ads \ + s-taspri.ads<5ztaspri.ads \ s-vxwork.ads<5pvxwork.ads \ + g-soccon.ads<3zsoccon.ads \ + g-socthi.ads<3zsocthi.ads \ + g-socthi.adb<3zsocthi.adb \ system.ads<5ysystem.ads - ifeq ($(strip $(filter-out vxworks6% vxworksae%,$(osys))),) - LIBGNAT_TARGET_PAIRS = \ - a-sytaco.ads<4zsytaco.ads \ - a-sytaco.adb<4zsytaco.adb \ - a-intnam.ads<4zintnam.ads \ - a-numaux.ads<4znumaux.ads \ - s-inmaop.adb<7sinmaop.adb \ - s-interr.adb<5zinterr.adb \ - s-intman.adb<5zintman.adb \ - s-osinte.adb<5zosinte.adb \ - s-osinte.ads<5zosinte.ads \ - s-osprim.adb<5zosprim.adb \ - s-taprop.adb<5ztaprop.adb \ - s-taspri.ads<7staspri.ads \ - s-vxwork.ads<5qvxwork.ads \ - system.ads<5ysystem.ads - endif - EXTRA_RAVEN_SOURCES=i-vxwork.ads s-vxwork.ads EXTRA_RAVEN_OBJS=i-vxwork.o s-vxwork.o EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o @@ -1073,11 +631,12 @@ ifeq ($(strip $(filter-out sparc sun solaris2% sunos5%,$(targ))),) g-soliop.ads<3ssoliop.ads \ system.ads<5ssystem.ads - THREADSLIB=-lposix4 -lthread - MISCLIB=-laddr2line -lbfd -lposix4 -lnsl -lsocket - SO_OPTS=-Wl,-h, - GNATLIB_SHARED=gnatlib-shared-dual - GMEM_LIB=gmemlib + THREADSLIB = -lposix4 -lthread + MISCLIB = -lposix4 -lnsl -lsocket + SYMLIB = -laddr2line -lbfd $(INTLLIBS) + SO_OPTS = -Wl,-h, + GNATLIB_SHARED = gnatlib-shared-dual + GMEM_LIB = gmemlib LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/')) ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),) @@ -1095,7 +654,7 @@ ifeq ($(strip $(filter-out sparc sun solaris2% sunos5%,$(targ))),) g-soliop.ads<3ssoliop.ads \ system.ads<5ssystem.ads - THREADSLIB=-lgthreads -lmalloc + THREADSLIB = -lgthreads -lmalloc endif ifeq ($(strip $(filter-out pthread PTHREAD,$(THREAD_KIND))),) @@ -1113,7 +672,7 @@ ifeq ($(strip $(filter-out sparc sun solaris2% sunos5%,$(targ))),) g-soliop.ads<3ssoliop.ads \ system.ads<5ssystem.ads - THREADSLIB=-lposix4 -lpthread + THREADSLIB = -lposix4 -lpthread endif endif @@ -1138,15 +697,11 @@ ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),) g-soliop.ads<3ssoliop.ads \ system.ads<5esystem.ads - THREADSLIB=-lposix4 -lthread - MISCLIB=-lposix4 -lnsl -lsocket - SO_OPTS=-Wl,-h, - GNATLIB_SHARED=gnatlib-shared-dual + THREADSLIB = -lposix4 -lthread + MISCLIB = -lposix4 -lnsl -lsocket + SO_OPTS = -Wl,-h, + GNATLIB_SHARED = gnatlib-shared-dual LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/')) - -# ??? work around a gcc -O3 bug on x86 -a-numaux.o : a-numaux.adb a-numaux.ads - $(ADAC) -c $(ALL_ADAFLAGS) -O2 $(ADA_INCLUDES) $< endif ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) @@ -1162,13 +717,14 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) s-osprim.adb<7sosprim.adb \ s-taprop.adb<5itaprop.adb \ s-taspri.ads<5itaspri.ads \ + s-tpopsp.adb<5atpopsp.adb \ system.ads<5lsystem.ads - MLIB_TGT=5lml-tgt - MISCLIB=-laddr2line -lbfd - THREADSLIB=-lpthread - GNATLIB_SHARED=gnatlib-shared-dual - GMEM_LIB=gmemlib + TOOLS_TARGET_PAIRS = mlib-tgt.adb<5lml-tgt.adb + SYMLIB = -laddr2line -lbfd $(INTLLIBS) + THREADSLIB = -lpthread + GNATLIB_SHARED = gnatlib-shared-dual + GMEM_LIB = gmemlib LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/')) ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),) @@ -1187,7 +743,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) s-tpopsp.adb<7stpopsp.adb \ system.ads<5lsystem.ads - THREADSLIB=-lgthreads -lmalloc + THREADSLIB = -lgthreads -lmalloc endif ifeq ($(strip $(filter-out rt-linux RT-LINUX,$(THREAD_KIND))),) @@ -1198,14 +754,12 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) s-osinte.adb<5qosinte.adb \ s-osinte.ads<5qosinte.ads \ s-osprim.adb<5qosprim.adb \ - s-parame.ads<5qparame.ads \ s-stache.adb<5qstache.adb \ s-taprop.adb<5qtaprop.adb \ s-taspri.ads<5qtaspri.ads \ system.ads<5lsystem.ads - - THREADSLIB= - RT_FLAGS=-D__RT__ + + RT_FLAGS = -D__RT__ endif endif @@ -1224,13 +778,11 @@ ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),) s-taprop.adb<5ftaprop.adb \ s-tasinf.ads<5ftasinf.ads \ s-taspri.ads<7staspri.ads \ - s-tpgetc.adb<5gtpgetc.adb \ s-traceb.adb<7straceb.adb \ g-soccon.ads<3gsoccon.ads \ system.ads<5gsystem.ads - THREADSLIB=-lpthread - GMEM_LIB=gmemlib + THREADSLIB = -lpthread else LIBGNAT_TARGET_PAIRS = \ @@ -1248,30 +800,17 @@ ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),) s-tasinf.adb<5gtasinf.adb \ s-tasinf.ads<5gtasinf.ads \ s-taspri.ads<7staspri.ads \ - s-tpgetc.adb<5gtpgetc.adb \ s-traceb.adb<7straceb.adb \ g-soccon.ads<3gsoccon.ads \ system.ads<5fsystem.ads - THREADSLIB=-lathread + THREADSLIB = -lathread endif - EXTRA_GNATRTL_TASKING_OBJS=s-tpgetc.o a-tcbinf.o - MISCLIB=-lexc -laddr2line -lbfd - SO_OPTS=-Wl,-all,-set_version,sgi1.0,-update_registry,../so_locations,-soname, + TGT_LIB = -lexc + MISCLIB = -lexc + SO_OPTS = -Wl,-all,-set_version,sgi1.0,-update_registry,../so_locations,-soname, LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/')) - -a-tcbinf.o: s-tpgetc.ali - ../../gnatbind -nostdlib -I- -I. s-tpgetc.ali - ../../gnatlink --GCC="../../xgcc -B../../" s-tpgetc.ali -o gen_tcbinf \ - $(LIBGNAT_OBJS) - ./gen_tcbinf - $(CC) -c -g a-tcbinf.c - $(RM) gen_tcbinf - -# force debug info so that workshop can find the All_Tasks_List symbol -s-taskin.o: s-taskin.adb s-taskin.ads - $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) $< endif ifeq ($(strip $(filter-out hppa% hp hpux%,$(targ))),) @@ -1290,10 +829,12 @@ ifeq ($(strip $(filter-out hppa% hp hpux%,$(targ))),) g-soccon.ads<3hsoccon.ads \ system.ads<5hsystem.ads - THREADSLIB=-lpthread -lc_r - soext=.sl - SO_OPTS=-Wl,+h, - GNATLIB_SHARED=gnatlib-shared-dual + TGT_LIB = /usr/lib/libcl.a -lpthread + THREADSLIB = -lpthread -lc_r + SYMLIB = -laddr2line -lbfd $(INTLLIBS) + soext = .sl + SO_OPTS = -Wl,+h, + GNATLIB_SHARED = gnatlib-shared-dual ifeq ($(strip $(filter-out dce DCE,$(THREAD_KIND))),) LIBGNAT_TARGET_PAIRS = \ @@ -1306,13 +847,12 @@ ifeq ($(strip $(filter-out hppa% hp hpux%,$(targ))),) s-osinte.ads<5hosinte.ads \ s-parame.ads<5hparame.ads \ s-osprim.adb<7sosprim.adb \ - s-traceb.adb<5htraceb.adb \ s-taprop.adb<5htaprop.adb \ s-taspri.ads<5htaspri.ads \ g-soccon.ads<3hsoccon.ads \ system.ads<5hsystem.ads - THREADSLIB=-lcma + THREADSLIB = -lcma endif endif @@ -1330,7 +870,7 @@ ifeq ($(strip $(filter-out ibm aix4%,$(manu) $(osys))),) g-soccon.ads<3bsoccon.ads \ system.ads<5bsystem.ads - THREADSLIB=-lpthreads + THREADSLIB = -lpthreads ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<4cintnam.ads \ @@ -1345,7 +885,7 @@ ifeq ($(strip $(filter-out ibm aix4%,$(manu) $(osys))),) g-soccon.ads<3bsoccon.ads \ system.ads<5bsystem.ads - THREADSLIB=-lgthreads -lmalloc + THREADSLIB = -lgthreads -lmalloc endif endif @@ -1377,8 +917,8 @@ ifeq ($(strip $(filter-out lynxos,$(osys))),) s-osinte.adb<56osinte.adb \ s-osinte.ads<56osinte.ads \ s-osprim.adb<7sosprim.adb \ - s-taprop.adb<7staprop.adb \ - s-taspri.ads<7staspri.ads \ + s-taprop.adb<56taprop.adb \ + s-taspri.ads<56taspri.ads \ s-tpopsp.adb<5atpopsp.adb \ system.ads<52system.ads endif @@ -1388,12 +928,12 @@ ifeq ($(strip $(filter-out lynxos,$(osys))),) a-intnam.ads<42intnam.ads \ s-inmaop.adb<7sinmaop.adb \ s-intman.adb<7sintman.adb \ - s-osinte.adb<52osinte.adb \ - s-osinte.ads<52osinte.ads \ + s-osinte.adb<56osinte.adb \ + s-osinte.ads<56osinte.ads \ s-osprim.adb<7sosprim.adb \ - s-taprop.adb<7staprop.adb \ - s-taspri.ads<7staspri.ads \ - s-tpopsp.adb<7stpopsp.adb \ + s-taprop.adb<56taprop.adb \ + s-taspri.ads<56taspri.ads \ + s-tpopsp.adb<5atpopsp.adb \ system.ads<52system.ads endif endif @@ -1442,22 +982,64 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),) g-soccon.ads<3asoccon.ads \ system.ads<5asystem.ads - MISCLIB=-laddr2line -lbfd - THREADSLIB=-lpthread -lmach -lexc -lrt + THREADSLIB = -lpthread -lmach -lexc -lrt + SYMLIB = -laddr2line -lbfd $(INTLLIBS) LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/')) endif -ifeq ($(strip $(filter-out ppc mac machten,$(targ))),) +ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(host))),) + +EXTRA_GNAT1_OBJS = ../prefix.o vmshandler.o +EXTRA_GNATBIND_OBJS = ../prefix.o vmshandler.o + +endif + +ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),) + +ifeq ($(strip $(filter-out alpha64% dec vms% openvms% alphavms%,$(targ))),) + LIBGNAT_TARGET_PAIRS_AUX = +else +ifeq ($(strip $(filter-out express EXPRESS,$(THREAD_KIND))),) + LIBGNAT_TARGET_PAIRS_AUX = \ + s-parame.ads<5xparame.ads +else + LIBGNAT_TARGET_PAIRS_AUX = \ + s-parame.ads<5vparame.ads +endif +endif + LIBGNAT_TARGET_PAIRS = \ - a-intnam.ads<4mintnam.ads \ - s-inmaop.adb<7sinmaop.adb \ - s-intman.adb<7sintman.adb \ - s-osinte.adb<7sosinte.adb \ - s-osinte.ads<5mosinte.ads \ - s-osprim.adb<7sosprim.adb \ - s-taprop.adb<7staprop.adb \ - s-taspri.ads<7staspri.ads \ - s-tpopsp.adb<7stpopsp.adb + a-caldel.adb<4vcaldel.adb \ + a-calend.adb<4vcalend.adb \ + a-calend.ads<4vcalend.ads \ + a-excpol.adb<4wexcpol.adb \ + a-intnam.ads<4vintnam.ads \ + g-enblsp.adb<3venblsp.adb \ + i-cstrea.adb<6vcstrea.adb \ + i-cpp.adb<6vcpp.adb \ + interfac.ads<6vinterf.ads \ + s-asthan.adb<5vasthan.adb \ + s-inmaop.adb<5vinmaop.adb \ + s-interr.adb<5vinterr.adb \ + s-intman.adb<5vintman.adb \ + s-intman.ads<5vintman.ads \ + s-osinte.adb<5vosinte.adb \ + s-osinte.ads<5vosinte.ads \ + s-osprim.adb<5vosprim.adb \ + s-osprim.ads<5vosprim.ads \ + s-taprop.adb<5vtaprop.adb \ + s-taspri.ads<5vtaspri.ads \ + s-tpopde.adb<5vtpopde.adb \ + s-tpopde.ads<5vtpopde.ads \ + s-vaflop.adb<5vvaflop.adb \ + system.ads<5xsystem.ads \ + $(LIBGNAT_TARGET_PAIRS_AUX) + + GNATLIB_SHARED=gnatlib-shared-vms + EXTRA_LIBGNAT_SRCS=vmshandler.asm + EXTRA_LIBGNAT_OBJS=vmshandler.o + EXTRA_GNATRTL_TASKING_OBJS=s-tpopde.o + EXTRA_GNATTOOLS_OBJS = ../prefix.o vmshandler.o endif ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) @@ -1483,14 +1065,11 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) g-soliop.ads<3wsoliop.ads \ system.ads<5wsystem.ads - MISCLIB = -laddr2line -lbfd -lwsock32 - GMEM_LIB=gmemlib - EXTRA_GNATTOOLS = ../gnatdll$(exeext) + MISCLIB = -lwsock32 + SYMLIB = -laddr2line -lbfd $(INTLLIBS) + GMEM_LIB = gmemlib + EXTRA_GNATTOOLS = ../../gnatdll$(exeext) EXTRA_GNATRTL_NONTASKING_OBJS = g-regist.o - -# ??? work around a gcc -O3 bug on x86 -a-numaux.o : a-numaux.adb a-numaux.ads - $(ADAC) -c $(ALL_ADAFLAGS) -O2 $(ADA_INCLUDES) $< endif # The runtime library for gnat comprises two directories. One contains the @@ -1504,12 +1083,12 @@ endif # subdirectory and copied. LIBGNAT_SRCS = ada.h adaint.c adaint.h argv.c cio.c cstreams.c \ errno.c exit.c cal.c \ - raise.h raise.c sysdep.c types.h io-aux.c init.c \ - final.c tracebak.c expect.c $(EXTRA_LIBGNAT_SRCS) + raise.h raise.c sysdep.c types.h aux-io.c init.c \ + final.c tracebak.c expect.c mkdir.c $(EXTRA_LIBGNAT_SRCS) LIBGNAT_OBJS = adaint.o argv.o cio.o cstreams.o errno.o exit.o \ - raise.o sysdep.o io-aux.o init.o cal.o final.o \ - tracebak.o expect.o ../../prefix.o $(EXTRA_LIBGNAT_OBJS) + raise.o sysdep.o aux-io.o init.o cal.o final.o \ + tracebak.o expect.o mkdir.o $(EXTRA_LIBGNAT_OBJS) # NOTE ??? - when the -I option for compiling Ada code is made to work, # the library installation will change and there will be a @@ -1554,7 +1133,8 @@ GNATRTL_TASKING_OBJS= \ s-tpinop.o \ s-tpoben.o \ s-tpobop.o \ - s-tposen.o $(EXTRA_GNATRTL_TASKING_OBJS) + s-tposen.o \ + s-tratas.o $(EXTRA_GNATRTL_TASKING_OBJS) # Objects needed for non-tasking. GNATRTL_NONTASKING_OBJS= \ @@ -1563,10 +1143,12 @@ GNATRTL_NONTASKING_OBJS= \ a-chahan.o \ a-charac.o \ a-chlat1.o \ + a-chlat9.o \ a-colien.o \ a-colire.o \ a-comlin.o \ a-cwila1.o \ + a-cwila9.o \ a-decima.o \ a-einuoc.o \ a-except.o \ @@ -1675,6 +1257,7 @@ GNATRTL_NONTASKING_OBJS= \ g-io.o \ g-io_aux.o \ g-locfil.o \ + g-md5.o \ g-moreex.o \ g-os_lib.o \ g-regexp.o \ @@ -1692,7 +1275,6 @@ GNATRTL_NONTASKING_OBJS= \ g-sptavs.o \ g-tasloc.o \ g-traceb.o \ - g-trasym.o \ gnat.o \ i-c.o \ i-cexten.o \ @@ -1849,6 +1431,7 @@ GNATRTL_NONTASKING_OBJS= \ s-soflin.o \ s-memory.o \ s-traceb.o \ + s-traces.o \ s-unstyp.o \ s-vaflop.o \ s-valboo.o \ @@ -1882,7 +1465,7 @@ GNATRTL_NONTASKING_OBJS= \ system.o \ text_io.o $(EXTRA_GNATRTL_NONTASKING_OBJS) -GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) +GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) g-trasym.o # Files which are suitable in no run time/hi integrity mode @@ -1992,88 +1575,198 @@ ADA_INCLUDE_SRCS =\ s-[a-o]*.adb s-[p-z]*.adb \ s-[a-o]*.ads s-[p-z]*.ads -# Files specific to the C interpreter bytecode compiler(s). -BC_OBJS = ../bc-emit.o ../bc-optab.o - # Language-independent object files. BACKEND = ../main.o ../attribs.o ../libbackend.a -Makefile: $(srcdir)/Makefile.in $(srcdir)/../configure - cd ..; $(SHELL) config.status - -native: ../gnat1$(exeext) +LIBGNAT=../rts/libgnat.a +TOOLS_FLAGS_TO_PASS= \ + "CC=$(CC)" \ + "CFLAGS=$(CFLAGS)" \ + "LDFLAGS=$(LDFLAGS)" \ + "ADAFLAGS=$(ADAFLAGS)" \ + "INCLUDES=$(INCLUDES_FOR_SUBDIR)"\ + "ADA_INCLUDES=$(ADA_INCLUDES) $(ADA_INCLUDES_FOR_SUBDIR)"\ + "libsubdir=$(libsubdir)" \ + "exeext=$(exeext)" \ + "srcdir=$(fsrcdir)" \ + "TOOLS_LIBS=$(TOOLS_LIBS) $(TGT_LIB)" \ + "GNATMAKE=$(GNATMAKE)" \ + "GNATLINK=$(GNATLINK)" \ + "GNATBIND=$(GNATBIND)" + +# Build directory for the tools. Let's copy the target dependent +# sources using the same mechanism as for gnatlib. The other sources are +# accessed using the vpath directive below + +../stamp-tools: + -$(RM) tools/* + -$(RMDIR) tools + -$(MKDIR) tools + -(cd tools; $(LN_S) ../sdefault.adb .) + -$(foreach PAIR,$(TOOLS_TARGET_PAIRS), \ + $(RM) tools/$(word 1,$(subst <, ,$(PAIR)));\ + $(LN_S) $(fsrcdir)/$(word 2,$(subst <, ,$(PAIR))) \ + tools/$(word 1,$(subst <, ,$(PAIR)));) + touch ../stamp-tools + +# when compiling the tools, the runtime has to be first on the path so that +# it hides the runtime files lying with the rest of the sources +ifeq ($(TOOLSCASE),native) + vpath %.ads ../rts ../ + vpath %.adb ../rts ../ + vpath %.c ../rts ../ + vpath %.h ../rts ../ +endif -compiler: ../gnat1$(exeext) +# in the cross tools case, everything is compiled with the native +# gnatmake/link. Therefore only -I needs to be modified in ADA_INCLUDES +ifeq ($(TOOLSCASE),cross) + vpath %.ads ../ + vpath %.adb ../ + vpath %.c ../ + vpath %.h ../ +endif -tools: ../gnatbl$(exeext) ../gnatchop$(exeext) ../gnatcmd$(exeext)\ - ../gnatkr$(exeext) ../gnatlink$(exeext) ../gnatlbr$(exeext) \ - ../gnatls$(exeext) ../gnatmake$(exeext) \ - ../gnatprep$(exeext) ../gnatpsta$(exeext) ../gnatpsys$(exeext) \ - ../gnatxref$(exeext) ../gnatfind$(exeext) +# gnatmake/link tools cannot always be built with gnatmake/link for bootstrap +# reasons: gnatmake should be built with a recent compiler, a recent compiler +# may not generate ALI files compatible with an old gnatmake so it is important +# to be able to build gnatmake without a version of gnartmake around. Once +# everything has been compiled once, gnatmake can be recompiled with itself +# (see target gnattools1-re) +gnattools1: ../stamp-tools ../stamp-gnatlib + $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \ + TOOLSCASE=native \ + ../../gnatmake$(exeext) ../../gnatlink$(exeext) ../../gnatbl$(exeext) + +# gnatmake/link can be build with recent gnatmake/link if they are available. +# This is especially convenient for building cross tools or for rebuilding +# the tools when the original bootstrap has already be done. +gnattools1-re: ../stamp-tools + $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \ + TOOLSCASE=cross INCLUDES="" gnatmake-re gnatlink-re + +# these tools are built with gnatmake & are common to native and cross +gnattools2: ../stamp-tools + $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \ + TOOLSCASE=native \ + ../../gnatchop$(exeext) ../../gnat$(exeext) ../../gnatkr$(exeext) \ + ../../gnatls$(exeext) ../../gnatprep$(exeext) \ + ../../gnatpsta$(exeext) ../../gnatxref$(exeext) \ + ../../gnatfind$(exeext) ../../gnatname$(exeext) + +# These tools are only built for the native version. +gnattools3: ../stamp-tools + $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \ + TOOLSCASE=native \ + top_builddir=../.. ../../gnatmem$(exeext) $(EXTRA_GNATTOOLS) + +../../gnatchop$(exeext): + $(GNATMAKE) -c $(ADA_INCLUDES) gnatchop --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatchop + $(GNATLINK) -v gnatchop -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \ + $(TOOLS_LIBS) + +../../gnat$(exeext): + $(GNATMAKE) -c $(ADA_INCLUDES) gnatcmd --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatcmd + $(GNATLINK) -v gnatcmd -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \ + $(TOOLS_LIBS) + +../../gnatkr$(exeext): + $(GNATMAKE) -c $(ADA_INCLUDES) gnatkr --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatkr + $(GNATLINK) -v gnatkr -o $@ --GCC="$(CC) $(ADA_INCLUDES)" $(TOOLS_LIBS) + +../../gnatls$(exeext): + $(GNATMAKE) -c $(ADA_INCLUDES) gnatls --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatls + $(GNATLINK) -v gnatls -o $@ --GCC="$(CC) $(ADA_INCLUDES)" $(TOOLS_LIBS) + +../../gnatname$(exeext): + $(GNATMAKE) -c $(ADA_INCLUDES) gnatname --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatname + $(GNATLINK) -v gnatname -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \ + $(TOOLS_LIBS) + +../../gnatprep$(exeext): + $(GNATMAKE) -c $(ADA_INCLUDES) gnatprep --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatprep + $(GNATLINK) -v gnatprep -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \ + $(TOOLS_LIBS) + +../../gnatpsta$(exeext): deftarg.o + $(GNATMAKE) -c $(ADA_INCLUDES) gnatpsta --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatpsta + $(GNATLINK) -v gnatpsta -o $@ --GCC="$(CC) $(ADA_INCLUDES)"\ + ../targtyps.o deftarg.o $(TOOLS_LIBS) + +../../gnatxref$(exeext): + $(GNATMAKE) -c $(ADA_INCLUDES) gnatxref --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatxref + $(GNATLINK) -v gnatxref -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \ + $(TOOLS_LIBS) + +../../gnatfind$(exeext): + $(GNATMAKE) -c $(ADA_INCLUDES) gnatfind --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatfind + $(GNATLINK) -v gnatfind -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \ + $(TOOLS_LIBS) + +../../gnatmem$(exeext): gmem.o $(SYMDEPS) + $(GNATMAKE) -c $(ADA_INCLUDES) gnatmem --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatmem + $(GNATLINK) -v gnatmem -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \ + gmem.o $(SYMLIB) $(TOOLS_LIBS) + +../../gnatdll$(exeext): + $(GNATMAKE) -c $(ADA_INCLUDES) gnatdll --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) $(GNATBIND_FLAGS) gnatdll + $(GNATLINK) -v gnatdll -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \ + $(TOOLS_LIBS) + +gnatmake-re: + $(GNATMAKE) $(ADA_INCLUDES) -u sdefault --GCC="$(CC) $(MOST_ADA_FLAGS)" + $(GNATMAKE) -c $(ADA_INCLUDES) gnatmake --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatmake + $(GNATLINK) -v gnatmake -o ../../gnatmake$(exeext) \ + --GCC="$(CC) $(ADA_INCLUDES)" $(TOOLS_LIBS) + +# Note the use of the "mv" command in order to allow gnatlink to be linked with +# with the former version of gnatlink itself which cannot override itself. +gnatlink-re: link.o + $(GNATMAKE) -c $(ADA_INCLUDES) gnatlink --GCC="$(CC) $(ALL_ADAFLAGS)" + $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatlink + $(GNATLINK) -v gnatlink -o ../../gnatlinknew$(exeext) \ + --GCC="$(CC) $(ADA_INCLUDES)" link.o $(TOOLS_LIBS) + $(MV) ../../gnatlinknew$(exeext) ../../gnatlink$(exeext) + # Needs to be built with CC=gcc # Since the RTL should be built with the latest compiler, remove the # stamp target in the parent directory whenever gnat1 is rebuilt -../gnat1$(exeext): $(P) $(GNAT1_OBJS) $(BACKEND) $(LIBDEPS) $(TARGET_ADA_SRCS) +# Likewise for the tools +../gnat1$(exeext): $(P) $(TARGET_ADA_SRCS) $(GNAT1_OBJS) $(BACKEND) $(LIBDEPS) $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ $(GNAT1_OBJS) $(BACKEND) $(LIBS) - $(RM) ../stamp-gnatlib2 + $(RM) ../stamp-gnatlib2 ../stamp-tools ../gnatbind$(exeext): $(P) b_gnatb.o $(GNATBIND_OBJS) $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatb.o $(GNATBIND_OBJS) \ $(LIBIBERTY) $(LIBS) -../gnatchop$(exeext): $(P) b_gnatch.o $(GNATCHOP_OBJS) - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatch.o $(GNATCHOP_OBJS) \ - $(LIBS) - -../gnatmake$(exeext): $(P) b_gnatm.o $(GNATMAKE_OBJS) - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatm.o $(GNATMAKE_OBJS) $(LIBS) - -gnatbl.o: gnatbl.c adaint.h - $(CC) $(ALL_CFLAGS) $(INCLUDES) -c $< - -../gnatbl$(exeext): gnatbl.o adaint.o - $(CC) -o $@ $(ALL_CFLAGS) $(LDFLAGS) gnatbl.o adaint.o $(LIBS) - -../gnatcmd$(exeext): $(P) b_gnatc.o $(GNATCMD_OBJS) - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatc.o $(GNATCMD_OBJS) $(LIBS) - -../gnatkr$(exeext): $(P) b_gnatkr.o $(GNATKR_OBJS) - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatkr.o $(GNATKR_OBJS) $(LIBS) - -../gnatlink$(exeext): $(P) b_gnatl.o $(GNATLINK_OBJS) - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatl.o $(GNATLINK_OBJS) $(LIBS) - -../gnatls$(exeext): $(P) b_gnatls.o $(GNATLS_OBJS) - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatls.o $(GNATLS_OBJS) $(LIBS) +../../gnatmake$(exeext): $(P) b_gnatm.o $(GNATMAKE_OBJS) + $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatm.o $(GNATMAKE_OBJS) \ + $(TOOLS_LIBS) -../gnatmem$(exeext): $(P) b_gnatmem.o $(GNATMEM_OBJS) - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatmem.o $(GNATMEM_OBJS) \ - $(MISCLIB) $(LIBS) +../../gnatlink$(exeext): $(P) b_gnatl.o $(GNATLINK_OBJS) + $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatl.o $(GNATLINK_OBJS) \ + $(TOOLS_LIBS) -../gnatprep$(exeext): $(P) b_gnatp.o $(GNATPREP_OBJS) - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatp.o $(GNATPREP_OBJS) $(LIBS) - -../gnatpsta$(exeext): $(P) b_gnatpa.o $(GNATPSTA_OBJS) - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatpa.o $(GNATPSTA_OBJS) \ - $(LIBS) - -../gnatpsys$(exeext): $(P) b_gnatps.o $(GNATPSYS_OBJS) - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatps.o $(GNATPSYS_OBJS) \ - $(LIBS) - -../gnatxref$(exeext): $(P) b_gnatxref.o $(GNATXREF_OBJS) - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatxref.o $(GNATXREF_OBJS) \ - $(LIBS) - -../gnatfind$(exeext): $(P) b_gnatfind.o $(GNATFIND_OBJS) - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatfind.o $(GNATFIND_OBJS) \ - $(LIBS) - -../gnatdll$(exeext): $(P) b_gnatdll.o $(GNATDLL_OBJS) - $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatdll.o $(GNATDLL_OBJS) \ - $(LIBS) +../../gnatbl$(exeext): gnatbl.o + $(CC) -o $@ $(ALL_CFLAGS) $(LDFLAGS) gnatbl.o $(TOOLS_LIBS) +gnatbl.o: gnatbl.c adaint.h + $(CC) $(ALL_CFLAGS) $(INCLUDES) -c $< + ../stamp-gnatlib: @if [ ! -f stamp-gnatlib ] ; \ then \ @@ -2083,13 +1776,7 @@ gnatbl.o: gnatbl.c adaint.h true; \ fi -gnattools: ../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) - -install-gnatlib: stamp-gnatlib +install-gnatlib: ../stamp-gnatlib # Create the directory before deleting it, in case the directory is # a list of directories (as it may be on VMS). This ensures we are # deleting the right one. @@ -2106,7 +1793,7 @@ install-gnatlib: stamp-gnatlib -for file in ada/rts/*$(arext);do \ $(INSTALL_DATA) $$file $(ADA_RTL_OBJ_DIR); \ done -ifeq ($(strip $(filter-out alpha% dec vms%,$(targ))),) +ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),) -for file in ada/rts/lib*$(soext);do \ $(INSTALL_DATA) $$file $(ADA_RTL_OBJ_DIR); \ done @@ -2115,9 +1802,9 @@ else $(INSTALL_DATA) $$file $(ADA_RTL_OBJ_DIR); \ done endif - -$(LN) $(ADA_RTL_OBJ_DIR)/libgnat-*$(soext) \ + -$(LN_S) $(ADA_RTL_OBJ_DIR)/libgnat-*$(soext) \ $(ADA_RTL_OBJ_DIR)/libgnat$(soext) - -$(LN) $(ADA_RTL_OBJ_DIR)/libgnarl-*$(soext) \ + -$(LN_S) $(ADA_RTL_OBJ_DIR)/libgnarl-*$(soext) \ $(ADA_RTL_OBJ_DIR)/libgnarl$(soext) # This copy must be done preserving the date on the original file. for file in ada/rts/*.adb ada/rts/*.ads; do \ @@ -2176,10 +1863,9 @@ gnatlib: ../stamp-gnatlib1 ../stamp-gnatlib2 # ../xgcc -B../ -dD -E ../tconfig.h $(INCLUDES) > rts/tconfig.h $(MAKE) -C rts CC="../../xgcc -B../../" \ INCLUDES="$(INCLUDES_FOR_SUBDIR) -I./../.." \ - CFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS) -DIN_RTS" \ - ADA_CFLAGS="$(GNATLIBCFLAGS)" \ + CFLAGS="$(GNATLIBCFLAGS_FOR_C)" \ srcdir=$(fsrcdir) \ - -f ../Makefile $(LIBGNAT_OBJS) + -f ../Makefile $(LIBGNAT_OBJS) prefix.o $(MAKE) -C rts CC="../../xgcc -B../../" \ ADA_INCLUDES="$(ADA_INCLUDES_FOR_SUBDIR)" \ CFLAGS="$(GNATLIBCFLAGS)" ADA_CFLAGS="$(GNATLIBCFLAGS)" \ @@ -2189,23 +1875,70 @@ gnatlib: ../stamp-gnatlib1 ../stamp-gnatlib2 $(GNATRTL_OBJS) $(RM) rts/libgnat$(arext) rts/libgnarl$(arext) $(AR) $(AR_FLAGS) rts/libgnat$(arext) \ - $(addprefix rts/,$(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS)) + $(addprefix rts/,$(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS) prefix.o) if $(RANLIB_TEST) ; then $(RANLIB) rts/libgnat$(arext); else true; fi $(AR) $(AR_FLAGS) rts/libgnarl$(arext) \ $(addprefix rts/,$(GNATRTL_TASKING_OBJS)) if $(RANLIB_TEST) ; then $(RANLIB) rts/libgnarl$(arext); else true; fi ifeq ($(GMEM_LIB),gmemlib) $(AR) $(AR_FLAGS) rts/libgmem$(arext) rts/memtrack.o; - if $(RANLIB_TEST) ; then \ - $(RANLIB) rts/libgmem$(arext); \ - else \ - true; \ - fi endif $(CHMOD) a-wx rts/*.ali touch ../stamp-gnatlib -# generate read-only ali files for HI-E. +HIE_NONE_TARGET_PAIRS=\ + a-except.ads<1aexcept.ads \ + a-except.adb<1aexcept.adb \ + a-tags.adb<1atags.adb \ + s-secsta.ads<1ssecsta.ads \ + s-secsta.adb<1ssecsta.adb \ + i-c.ads<1ic.ads + +HIE_SUBST:='s/High_Integrity_Mode.*/High_Integrity_Mode : constant Boolean := True;/' +# This target needs RTS_NAME, RTS_SRCS, RTS_TARGET_PAIRS to be set properly +# it creates a rts with the proper structure and the right target dependent srcs +prepare-rts: + $(RMDIR) rts-$(RTS_NAME) + $(MKDIR) rts-$(RTS_NAME) + $(CHMOD) u+w rts-$(RTS_NAME) + $(MKDIR) rts-$(RTS_NAME)/adalib + $(MKDIR) rts-$(RTS_NAME)/adainclude + $(CHMOD) u+w rts-$(RTS_NAME)/* + $(LN) $(fsrcpfx)$(RTS_NAME).gpr rts-$(RTS_NAME) +# Copy target independent sources + $(foreach f,$(RTS_SRCS), \ + $(LN) $(fsrcpfx)$(f) rts-$(RTS_NAME)/adainclude ;) true +# Remove files to be replaced by target dependent sources + $(RM) $(foreach PAIR,$(RTS_TARGET_PAIRS), \ + rts-$(RTS_NAME)/adainclude/$(word 1,$(subst <, ,$(PAIR)))) +# Copy new target dependent sources + $(foreach PAIR,$(RTS_TARGET_PAIRS), \ + $(LN) $(fsrcpfx)$(word 2,$(subst <, ,$(PAIR))) \ + rts-$(RTS_NAME)/adainclude/$(word 1,$(subst <, ,$(PAIR)));) +# change system.High_Integrity_Mode to true for the none & ravenscar rts + ifeq ($(filter-out none ravenscar,$(RTS_NAME)),) + sed -e $(HIE_SUBST) rts-$(RTS_NAME)/adainclude/system.ads \ + > dummy + $(MV) dummy rts-$(RTS_NAME)/adainclude/system.ads + endif + +install-rts: force + $(CP) -r rts-$(RTS_NAME) $(libsubdir)/ + +rts-none: force + $(MAKE) $(FLAGS_TO_PASS) prepare-rts \ + RTS_NAME=none RTS_SRCS="$(HIE_SOURCES)" \ + RTS_TARGET_PAIRS="$(HIE_NONE_TARGET_PAIRS)" + -$(GNATMAKE) -Prts-none/none.gpr + $(RM) rts-none/adalib/*.o + $(CHMOD) a-wx rts-none/adalib/*.ali + +rts-ravenscar: force + $(MAKE) $(FLAGS_TO_PASS) prepare-rts \ + RTS_NAME=ravenscar RTS_SRCS="$(RAVEN_SOURCES)" \ + RTS_TARGET_PAIRS="$(HIE_RAVEN_TARGET_PAIRS)" + -$(GNATMAKE) -Prts-ravenscar/none.gpr + $(CHMOD) a-wx rts-ravenscar/adalib/*.ali internal-hielib: ../stamp-gnatlib1 sed -e 's/High_Integrity_Mode.*/High_Integrity_Mode : constant Boolean := True;/' rts/system.ads > rts/s.ads @@ -2225,14 +1958,14 @@ hielib: $(MAKE) ADA_INCLUDE_SRCS="$(HIE_SOURCES)" LIBGNAT_SRCS="" \ LIBGNAT_TARGET_PAIRS="a-except.ads<1aexcept.ads \ a-except.adb<1aexcept.adb \ + a-tags.adb<1atags.adb \ + s-secsta.ads<1ssecsta.ads \ + s-secsta.adb<1ssecsta.adb \ i-c.ads<1ic.ads" internal-hielib internal-ravenlib: ../stamp-gnatlib1 - echo "pragma Ravenscar;" > rts/gnat.adc - echo "pragma Restrictions (No_Exception_Handlers);" >> rts/gnat.adc - $(foreach f,$(RAVEN_MOD), \ - $(RM) rts/$(f) ; \ - grep -v "not needed in no exc mode" $(fsrcpfx)$(f) > rts/$(f) ;) true + sed -e 's/High_Integrity_Mode.*/High_Integrity_Mode : constant Boolean := True;/' rts/system.ads > rts/s.ads + $(MV) rts/s.ads rts/system.ads $(MAKE) -C rts CC="../../xgcc -B../../" \ ADA_INCLUDES="$(ADA_INCLUDES_FOR_SUBDIR)" \ CFLAGS="$(GNATLIBCFLAGS)" \ @@ -2248,16 +1981,22 @@ ravenppclib: $(MAKE) ADA_INCLUDE_SRCS="$(RAVEN_SOURCES)" LIBGNAT_SRCS="" \ LIBGNAT_TARGET_PAIRS="a-except.ads<1aexcept.ads \ a-except.adb<1aexcept.adb \ + a-tags.adb<1atags.adb \ + s-secsta.ads<1ssecsta.ads \ + s-secsta.adb<1ssecsta.adb \ i-c.ads<1ic.ads \ + a-reatim.ads<1areatim.ads \ + a-reatim.adb<1areatim.adb \ + a-retide.adb<1aretide.adb \ a-interr.adb<1ainterr.adb \ s-interr.ads<1sinterr.ads \ s-interr.adb<1sinterr.adb \ - s-parame.ads<1sparame.ads \ - s-secsta.adb<1ssecsta.adb \ - s-soflin.ads<1ssoflin.ads \ - s-soflin.adb<1ssoflin.adb \ - s-stalib.ads<1sstalib.ads \ - s-stalib.adb<1sstalib.adb \ + s-taskin.ads<1staskin.ads \ + s-taskin.adb<1staskin.adb \ + s-tarest.adb<1starest.adb \ + s-tposen.ads<1stposen.ads \ + s-tposen.adb<1stposen.adb \ + s-osinte.adb<1sosinte.adb \ s-taprop.ads<1staprop.ads \ s-taprop.adb<1staprop.adb \ a-sytaco.ads<1asytaco.ads \ @@ -2269,7 +2008,6 @@ ravenppclib: s-vxwork.ads<5pvxwork.ads \ system.ads<5ysystem.ads" internal-ravenlib - # Warning: this target assumes that LIBRARY_VERSION has been set correctly. gnatlib-shared-default: $(MAKE) $(FLAGS_TO_PASS) \ @@ -2279,13 +2017,15 @@ gnatlib-shared-default: gnatlib $(RM) rts/libgnat$(soext) rts/libgnarl$(soext) cd rts; ../../xgcc -B../../ -shared $(TARGET_LIBGCC2_CFLAGS) \ - -o libgnat-$(LIBRARY_VERSION)$(soext) $(SO_OPTS)libgnat-$(LIBRARY_VERSION)$(soext) \ - $(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS) $(MISCLIB) -lm + -o libgnat-$(LIBRARY_VERSION)$(soext) \ + $(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS) \ + $(SO_OPTS)libgnat-$(LIBRARY_VERSION)$(soext) $(MISCLIB) -lm cd rts; ../../xgcc -B../../ -shared $(TARGET_LIBGCC2_CFLAGS) \ - -o libgnarl-$(LIBRARY_VERSION)$(soext) $(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) \ - $(GNATRTL_TASKING_OBJS) $(THREADSLIB) - cd rts; $(LN) libgnat-$(LIBRARY_VERSION)$(soext) libgnat$(soext) - cd rts; $(LN) libgnarl-$(LIBRARY_VERSION)$(soext) libgnarl$(soext) + -o libgnarl-$(LIBRARY_VERSION)$(soext) \ + $(GNATRTL_TASKING_OBJS) \ + $(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) $(THREADSLIB) + cd rts; $(LN_S) libgnat-$(LIBRARY_VERSION)$(soext) libgnat$(soext) + cd rts; $(LN_S) libgnarl-$(LIBRARY_VERSION)$(soext) libgnarl$(soext) gnatlib-shared-dual: $(MAKE) $(FLAGS_TO_PASS) \ @@ -2331,6 +2071,7 @@ gnatlib-shared: GNATLIBFLAGS="$(GNATLIBFLAGS)" \ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ THREAD_KIND="$(THREAD_KIND)" \ + TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \ $(GNATLIB_SHARED) # .s files for cross-building @@ -2361,57 +2102,14 @@ b_gnatb.c : $(GNATBIND_OBJS) $(GNATBIND) $(ADA_INCLUDES) -o b_gnatb.c gnatbind.ali b_gnatb.o : b_gnatb.c -b_gnatc.c : $(GNATCMD_OBJS) - $(GNATBIND) $(ADA_INCLUDES) -o b_gnatc.c gnatcmd.ali -b_gnatc.o : b_gnatc.c - -b_gnatch.c : $(GNATCHOP_OBJS) - $(GNATBIND) $(ADA_INCLUDES) -o b_gnatch.c gnatchop.ali -b_gnatch.o : b_gnatch.c - -b_gnatkr.c : $(GNATKR_OBJS) - $(GNATBIND) $(ADA_INCLUDES) -o b_gnatkr.c gnatkr.ali -b_gnatkr.o : b_gnatkr.c - b_gnatl.c : $(GNATLINK_OBJS) $(GNATBIND) $(ADA_INCLUDES) -o b_gnatl.c gnatlink.ali b_gnatl.o : b_gnatl.c -b_gnatls.c : $(GNATLS_OBJS) - $(GNATBIND) $(ADA_INCLUDES) -o b_gnatls.c gnatls.ali - b_gnatm.c : $(GNATMAKE_OBJS) $(GNATBIND) $(ADA_INCLUDES) -o b_gnatm.c gnatmake.ali b_gnatm.o : b_gnatm.c -b_gnatmem.c : $(GNATMEM_OBJS) - $(GNATBIND) $(ADA_INCLUDES) -o b_gnatmem.c gnatmem.ali -b_gnatmem.o : b_gnatmem.c - -b_gnatp.c : $(GNATPREP_OBJS) - $(GNATBIND) $(ADA_INCLUDES) -o b_gnatp.c gnatprep.ali -b_gnatp.o : b_gnatp.c - -b_gnatpa.c : $(GNATPSTA_OBJS) - $(GNATBIND) $(ADA_INCLUDES) -o b_gnatpa.c gnatpsta.ali -b_gnatpa.o : b_gnatpa.c - -b_gnatps.c : $(GNATPSYS_OBJS) - $(GNATBIND) $(ADA_INCLUDES) -o b_gnatps.c gnatpsys.ali -b_gnatps.o : b_gnatps.c - -b_gnatxref.c : $(GNATXREF_OBJS) - $(GNATBIND) $(ADA_INCLUDES) -o b_gnatxref.c gnatxref.ali -b_gnatxref.o : b_gnatxref.c - -b_gnatfind.c : $(GNATFIND_OBJS) - $(GNATBIND) $(ADA_INCLUDES) -o b_gnatfind.c gnatfind.ali -b_gnatfind.o : b_gnatfind.c - -b_gnatdll.c : $(GNATDLL_OBJS) - $(GNATBIND) $(ADA_INCLUDES) -o b_gnatdll.c gnatdll.ali -b_gnatdll.o : b_gnatdll.c - treeprs.ads : treeprs.adt sinfo.ads xtreeprs.adb -$(MKDIR) bldtools $(CP) $^ bldtools @@ -2449,7 +2147,8 @@ ADA_RTL_OBJ_DIR = $(libsubdir)/adalib sdefault.adb: stamp-sdefault ; @true stamp-sdefault : $(srcdir)/../version.c $(srcdir)/../move-if-change \ Makefile - $(ECHO) "package body Sdefault is" >tmp-sdefault.adb + $(ECHO) "pragma Style_Checks (Off);" >tmp-sdefault.adb + $(ECHO) "package body Sdefault is" >>tmp-sdefault.adb $(ECHO) " S1 : aliased constant String := \"$(ADA_INCLUDE_DIR)/\";" >>tmp-sdefault.adb $(ECHO) " S2 : aliased constant String := \"$(ADA_RTL_OBJ_DIR)/\";" >>tmp-sdefault.adb $(ECHO) " S3 : aliased constant String := \"$(target)/\";" >>tmp-sdefault.adb @@ -2474,13 +2173,10 @@ stamp-sdefault : $(srcdir)/../version.c $(srcdir)/../move-if-change \ $(srcdir)/../move-if-change tmp-sdefault.adb sdefault.adb touch stamp-sdefault -ADA_TREE_H = ada-tree.h ada-tree.def - -# special compiles for sdefault without -gnatg, to avoid long line error - sdefault.o : sdefault.ads sdefault.adb types.ads unchdeal.ads \ - system.ads s-exctab.ads s-stalib.ads unchconv.ads - $(ADAC) -c -O2 $(MOST_ADAFLAGS) $(ADA_INCLUDES) sdefault.adb + system.ads s-exctab.ads s-stalib.ads unchconv.ads + +ADA_TREE_H = ada-tree.h ada-tree.def # force debugging information on s-tasdeb.o so that it is always # possible to set conditional breakpoints on tasks. @@ -2511,13 +2207,15 @@ s-assert.o : s-assert.adb s-assert.ads a-except.ads $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 \ $(ADA_INCLUDES) $< -# force debugging information on s-stalib.o so that it is always -# possible to set breakpoints on exceptions. +mdll.o : mdll.adb mdll.ads mdll-file.ads mdll-utl.ads + $(CC) -c $(ALL_ADAFLAGS) -O2 $(ADA_INCLUDES) $< -s-stalib.o : s-stalib.adb s-stalib.ads - $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 \ - $(ADA_INCLUDES) $< +mdll-fil.o : mdll-fil.adb mdll.ads mdll-fil.ads + $(CC) -c $(ALL_ADAFLAGS) -O2 $(ADA_INCLUDES) $< +mdll-utl.o : mdll-utl.adb mdll.ads mdll-utl.ads sdefault.ads types.ads + $(CC) -c $(ALL_ADAFLAGS) -O2 $(ADA_INCLUDES) $< + # force debugging information and no optimization on s-memory.o so that it # is always possible to set breakpoint on __gnat_malloc and __gnat_free # this is important for gnatmem using GDB. memtrack.o is built from @@ -2525,48 +2223,51 @@ s-stalib.o : s-stalib.adb s-stalib.ads s-memory.o : s-memory.adb s-memory.ads memtrack.o $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ - $(ADA_INCLUDES) $< + $(ADA_INCLUDES) $< memtrack.o : memtrack.adb s-memory.ads $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ - $(ADA_INCLUDES) $< + $(ADA_INCLUDES) $< # Need to keep the frame pointer in this file to pop the stack properly on # some targets. -tracebak.o : tracebak.c - $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) \ - $(ALL_CPPFLAGS) $(INCLUDES) -fno-omit-frame-pointer $< +traceb.o : traceb.c + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ + $< -expect.o : expect.c -io-aux.o : io-aux.c + +adadecode.o : adadecode.c adadecode.h +aux-io.o : aux-io.c argv.o : argv.c cal.o : cal.c -cio.o : cio.c - $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \ - $(ALL_CPPFLAGS) $(INCLUDES) $< deftarg.o : deftarg.c errno.o : errno.c exit.o : raise.h exit.c +expect.o : expect.c final.o : raise.h final.c gmem.o : gmem.c +link.o : link.c +mkdir.o : mkdir.c +sysdep.o : sysdep.c -raise.o : raise.c raise.h +cio.o : cio.c $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \ - $(ALL_CPPFLAGS) $(INCLUDES) $< + $(ALL_CPPFLAGS) $(INCLUDES) $< -ifeq ($(strip $(filter-out mips sgi irix5%,$(targ))),) init.o : init.c ada.h types.h raise.h $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \ - $(ALL_CPPFLAGS) $(INCLUDES) $< -else -init.o : init.c ada.h types.h raise.h + $(ALL_CPPFLAGS) $(INCLUDES) $< + +raise.o : raise.c raise.h $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \ - $(ALL_CPPFLAGS) $(INCLUDES) -fexceptions $< -endif + $(ALL_CPPFLAGS) $(INCLUDES) $< -link.o : link.c -sysdep.o : sysdep.c +# Need to keep the frame pointer in this file to pop the stack properly on +# some targets. +tracebak.o : tracebak.c + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ + -fno-omit-frame-pointer $< cuintp.o : cuintp.c $(CONFIG_H) $(TREE_H) ada.h types.h uintp.h atree.h \ stringt.h elists.h nlists.h fe.h gigi.h @@ -2579,1399 +2280,1017 @@ decl.o : decl.c $(CONFIG_H) $(TREE_H) $(srcdir)/../flags.h \ misc.o : misc.c $(CONFIG_H) $(TREE_H) $(RTL_H) $(srcdir)/../expr.h \ ../insn-codes.h ../insn-flags.h ../insn-config.h $(srcdir)/../recog.h \ $(srcdir)/../flags.h $(srcdir)/../diagnostic.h $(srcdir)/../output.h \ - $(srcdir)/../except.h ../tm_p.h $(srcdir)/../langhooks.h ada.h types.h \ - atree.h nlists.h elists.h sinfo.h einfo.h namet.h stringt.h uintp.h fe.h \ - $(ADA_TREE_H) gigi.h $(srcdir)/../langhooks-def.h $(srcdir)/../optabs.h + $(srcdir)/../except.h ../tm_p.h $(srcdir)/../langhooks.h \ + $(srcdir)/../debug.h $(srcdir)/../langhooks-def.h $(srcdir)/../libfuncs.h \ + ada.h types.h atree.h nlists.h elists.h sinfo.h einfo.h namet.h stringt.h \ + uintp.h fe.h $(ADA_TREE_H) gigi.h adadecode.h targtyps.o : targtyps.c $(CONFIG_H) ada.h types.h atree.h nlists.h elists.h \ uintp.h sinfo.h einfo.h namet.h snames.h stringt.h urealp.h fe.h \ $(ADA_TREE_H) gigi.h trans.o : trans.c $(CONFIG_H) $(TREE_H) $(RTL_H) $(srcdir)/../flags.h ada.h \ + $(srcdir)/../except.h \ types.h atree.h nlists.h elists.h uintp.h sinfo.h einfo.h \ namet.h snames.h stringt.h urealp.h fe.h $(ADA_TREE_H) gigi.h utils.o : utils.c $(CONFIG_H) $(TREE_H) $(srcdir)/../flags.h \ - $(srcdir)/../convert.h $(srcdir)/../defaults.h ada.h types.h atree.h \ - nlists.h elists.h sinfo.h einfo.h namet.h stringt.h uintp.h fe.h \ - $(ADA_TREE_H) gigi.h + $(srcdir)/../expr.h $(srcdir)/../convert.h $(srcdir)/../defaults.h ada.h \ + types.h atree.h nlists.h elists.h sinfo.h einfo.h namet.h stringt.h \ + uintp.h fe.h $(ADA_TREE_H) gigi.h utils2.o : utils2.c $(CONFIG_H) $(TREE_H) $(srcdir)/../flags.h ada.h types.h \ atree.h nlists.h elists.h sinfo.h einfo.h namet.h snames.h stringt.h \ uintp.h fe.h $(ADA_TREE_H) gigi.h -# specific rules for tools needing target dependent sources -# for each such source (e.g. mlib-tgt.adb) a link from the target -# specific name to the default name is defined in the subdir "tools". -# This subdir is added at the beginning of the source path fore the compilation -# of this unit. Here are the step for adding a new target dependent source: -# - create a Macro with the default name for the source (e.g. mlib-tgt) -# - change the value if this Macro in each target-dependent section of this -# Makefile (close to LIBGNAT_TARGET_PAIRS defs) if there is a -# specific version of the file for this section -# - Add a link from target dependent version to the default name in "tools" -# (see stamp-tool_src_dir target) -# - Add a specific target for the object in order to compile with -# "tools" on the source path (see mlib-tgt) - -stamp-tool_src_dir: - -$(RMDIR) tools - -$(MKDIR) tools - -$(LN_S) $(fsrcdir)/$(MLIB_TGT).adb tools/mlib-tgt.adb - touch stamp-tool_src_dir +# Rule to compile prefix.o for the run-time. -mlib-tgt.o : stamp-tool_src_dir - $(ADAC) -c -Itools $(ALL_ADAFLAGS) $(ADA_INCLUDES) tools/mlib-tgt.adb +prefix.o : $(srcdir)/../prefix.c + $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) -I$(srcdir)/../.. -I../.. \ + -DPREFIX=\"$(prefix)\" $< +# In GNU Make, ignore whether `stage*' exists. +.PHONY: stage1 stage2 stage3 stage4 clean realclean TAGS bootstrap +.PHONY: risky-stage1 risky-stage2 risky-stage3 risky-stage4 + +force: + +# Gnatlbr is only used on VMS + +GNATLBR_RTL_C_OBJS = adaint.o argv.o cio.o cstreams.o exit.o final.o init.o \ + raise.o sysdep.o tracebak.o +GNATLBR_C_OBJS = $(GNATLBR_RTL_C_OBJS) + +../gnatlbr$(exeext):: sdefault.o $(GNATLBR_C_OBJS) $(EXTRA_GNATTOOLS_OBJS) + $(RM) $@ +../gnatlbr$(exeext):: force + $(GNATMAKE) -a --GCC="$(CC)" $(ALL_ADAFLAGS) $(ADA_INCLUDES) \ + --GNATBIND="$(GNATBIND)" --GNATLINK="$(GNATLINK)" \ + -nostdlib $(fsrcpfx)gnatlbr -o $@ \ + -largs --GCC="$(CC) $(ALL_CFLAGS) $(LDFLAGS)" \ + $(GNATLBR_C_OBJS) $(EXTRA_GNATTOOLS_OBJS) + +# +# DO NOT PUT SPECIAL RULES BELOW, THIS SECTION IS UPDATED AUTOMATICALLY +# # GNAT DEPENDENCIES # regular dependencies -a-chahan.o : ada.ads a-charac.ads a-chahan.ads a-chahan.adb a-chlat1.ads \ - a-string.ads a-strmap.ads a-stmaco.ads system.ads s-exctab.ads \ - s-secsta.ads s-stalib.ads s-stoele.ads s-unstyp.ads unchconv.ads - a-charac.o : ada.ads a-charac.ads system.ads a-chlat1.o : ada.ads a-charac.ads a-chlat1.ads system.ads -a-comlin.o : ada.ads a-comlin.ads a-comlin.adb system.ads s-secsta.ads \ - s-stoele.ads - -ada.o : ada.ads system.ads - a-except.o : ada.ads a-except.ads a-except.adb a-excpol.adb a-uncdea.ads \ gnat.ads g-hesora.ads system.ads s-exctab.ads s-except.ads s-mastop.ads \ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ s-stoele.adb s-traceb.ads unchconv.ads -a-filico.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-filico.adb \ - a-stream.ads a-tags.ads a-tags.adb gnat.ads g-htable.ads system.ads \ - s-exctab.ads s-finimp.ads s-finroo.ads s-secsta.ads s-soflin.ads \ - s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads s-unstyp.ads \ - unchconv.ads - -a-finali.o : ada.ads a-except.ads a-finali.ads a-finali.adb a-stream.ads \ - a-tags.ads a-tags.adb gnat.ads g-htable.ads system.ads s-exctab.ads \ - s-finimp.ads s-finroo.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads s-stratt.ads s-unstyp.ads unchconv.ads - -a-flteio.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-flteio.ads \ - a-flteio.ads a-ioexce.ads a-stream.ads a-tags.ads a-textio.ads \ - a-tiflau.ads a-tiflio.ads a-tiflio.adb interfac.ads i-cstrea.ads \ - system.ads s-exctab.ads s-ficobl.ads s-finimp.ads s-finroo.ads \ - s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-stratt.ads s-unstyp.ads unchconv.ads - -a-inteio.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-inteio.ads \ - a-inteio.ads a-ioexce.ads a-stream.ads a-tags.ads a-textio.ads \ - a-tiinau.ads a-tiinio.ads a-tiinio.adb interfac.ads i-cstrea.ads \ - system.ads s-exctab.ads s-ficobl.ads s-finimp.ads s-finroo.ads \ - s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-stratt.ads s-unstyp.ads unchconv.ads - -a-ioexce.o : ada.ads a-ioexce.ads system.ads s-exctab.ads s-stalib.ads \ - unchconv.ads - -ali.o : ada.ads a-except.ads a-uncdea.ads ali.ads ali.adb alloc.ads \ - butil.ads casing.ads debug.ads fname.ads gnat.ads g-htable.ads \ - g-htable.adb g-os_lib.ads gnatvsn.ads hostparm.ads namet.ads opt.ads \ - osint.ads output.ads rident.ads system.ads s-assert.ads s-exctab.ads \ - s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ - table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads - -ali-util.o : ada.ads a-except.ads ali.ads ali-util.ads ali-util.adb \ - alloc.ads binderr.ads casing.ads debug.ads gnat.ads g-htable.ads \ - g-os_lib.ads gnatvsn.ads hostparm.ads interfac.ads namet.ads opt.ads \ - osint.ads output.ads rident.ads system.ads s-assert.ads s-crc32.ads \ - s-exctab.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-wchcon.ads table.ads table.adb tree_io.ads types.ads unchconv.ads \ - unchdeal.ads - -alloc.o : alloc.ads system.ads - -a-stmaco.o : ada.ads a-charac.ads a-chlat1.ads a-string.ads a-strmap.ads \ - a-stmaco.ads system.ads s-exctab.ads s-stalib.ads s-unstyp.ads \ - unchconv.ads - a-stream.o : ada.ads a-except.ads a-stream.ads a-tags.ads a-tags.adb \ gnat.ads g-htable.ads system.ads s-exctab.ads s-secsta.ads s-stalib.ads \ s-stoele.ads unchconv.ads -a-strfix.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-string.ads \ - a-strfix.ads a-strfix.adb a-strmap.ads a-strsea.ads system.ads \ - s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-unstyp.ads unchconv.ads - -a-string.o : ada.ads a-string.ads system.ads s-exctab.ads s-stalib.ads \ - unchconv.ads - -a-strmap.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-string.ads \ - a-strmap.ads a-strmap.adb system.ads s-bitops.ads s-exctab.ads \ - s-secsta.ads s-stalib.ads s-stoele.ads s-unstyp.ads unchconv.ads - -a-strsea.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-string.ads \ - a-strmap.ads a-strsea.ads a-strsea.adb system.ads s-exctab.ads \ - s-stalib.ads s-unstyp.ads unchconv.ads - -a-strunb.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-finali.ads \ - a-stream.ads a-string.ads a-strfix.ads a-strmap.ads a-strsea.ads \ - a-strunb.ads a-strunb.adb a-tags.ads a-tags.adb a-uncdea.ads gnat.ads \ - g-htable.ads system.ads s-exctab.ads s-finimp.ads s-finroo.ads \ - s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-stratt.ads s-unstyp.ads unchconv.ads - a-tags.o : ada.ads a-except.ads a-tags.ads a-tags.adb a-uncdea.ads \ - gnat.ads g-htable.ads g-htable.adb system.ads s-exctab.ads s-secsta.ads \ - s-stalib.ads s-stoele.ads unchconv.ads + gnat.ads g-htable.ads g-htable.adb system.ads s-exctab.ads s-exctab.adb \ + s-secsta.ads s-stalib.ads s-stoele.ads unchconv.ads -a-textio.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \ - a-stream.ads a-tags.ads a-tags.adb a-textio.ads a-textio.adb gnat.ads \ - g-htable.ads interfac.ads i-cstrea.ads system.ads s-exctab.ads \ - s-ficobl.ads s-fileio.ads s-finimp.ads s-finroo.ads s-parame.ads \ - s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-stratt.ads s-unstyp.ads unchconv.ads unchdeal.ads +ada.o : ada.ads system.ads -a-tiflau.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \ - a-stream.ads a-tags.ads a-textio.ads a-tiflau.ads a-tiflau.adb \ - a-tigeau.ads interfac.ads i-cstrea.ads system.ads s-exctab.ads \ - s-ficobl.ads s-finimp.ads s-finroo.ads s-imgrea.ads s-parame.ads \ - s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-stratt.ads s-unstyp.ads s-valrea.ads unchconv.ads - -a-tigeau.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \ - a-stream.ads a-tags.ads a-textio.ads a-tigeau.ads a-tigeau.adb \ - interfac.ads i-cstrea.ads system.ads s-exctab.ads s-ficobl.ads \ - s-fileio.ads s-finimp.ads s-finroo.ads s-parame.ads s-secsta.ads \ - s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads \ - s-unstyp.ads unchconv.ads - -a-tiinau.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \ - a-stream.ads a-tags.ads a-textio.ads a-tigeau.ads a-tiinau.ads \ - a-tiinau.adb interfac.ads i-cstrea.ads system.ads s-exctab.ads \ - s-ficobl.ads s-finimp.ads s-finroo.ads s-imgbiu.ads s-imgint.ads \ - s-imgllb.ads s-imglli.ads s-imgllw.ads s-imgwiu.ads s-parame.ads \ - s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-stratt.ads s-unstyp.ads s-valint.ads s-vallli.ads unchconv.ads +ali-util.o : ada.ads a-except.ads ali.ads ali-util.ads ali-util.adb \ + alloc.ads binderr.ads casing.ads debug.ads gnat.ads g-htable.ads \ + g-os_lib.ads gnatvsn.ads hostparm.ads interfac.ads namet.ads namet.adb \ + opt.ads osint.ads output.ads rident.ads system.ads s-atacco.ads \ + s-atacco.adb s-crc32.ads s-crc32.adb s-exctab.ads s-exctab.adb \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ + unchconv.ads unchdeal.ads widechar.ads + +ali.o : ada.ads a-except.ads a-uncdea.ads ali.ads ali.adb alloc.ads \ + butil.ads casing.ads debug.ads fname.ads gnat.ads g-htable.ads \ + g-htable.adb g-os_lib.ads gnatvsn.ads hostparm.ads namet.ads namet.adb \ + opt.ads osint.ads output.ads rident.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-exctab.adb s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads \ + widechar.ads -a-tiocst.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \ - a-stream.ads a-tags.ads a-textio.ads a-tiocst.ads a-tiocst.adb \ - interfac.ads i-cstrea.ads system.ads s-exctab.ads s-ficobl.ads \ - s-fileio.ads s-finimp.ads s-finroo.ads s-parame.ads s-secsta.ads \ - s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads \ - s-unstyp.ads unchconv.ads +alloc.o : alloc.ads system.ads atree.o : ada.ads a-except.ads a-uncdea.ads alloc.ads atree.ads atree.adb \ - casing.ads debug.ads einfo.ads elists.ads gnat.ads g-htable.ads \ - g-htable.adb g-os_lib.ads hostparm.ads nlists.ads opt.ads output.ads \ - sinfo.ads sinput.ads snames.ads system.ads s-assert.ads s-exctab.ads \ - s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads - -back_end.o : alloc.ads atree.ads back_end.ads back_end.adb casing.ads \ - debug.ads einfo.ads elists.ads gnat.ads g-os_lib.ads hostparm.ads \ - lib.ads namet.ads nlists.ads opt.ads osint.ads sinfo.ads sinput.ads \ - snames.ads stand.ads stringt.ads switch.ads system.ads s-exctab.ads \ - s-stalib.ads s-wchcon.ads table.ads types.ads uintp.ads unchconv.ads \ - unchdeal.ads urealp.ads + casing.ads debug.ads einfo.ads einfo.adb elists.ads elists.adb gnat.ads \ + g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads namet.ads \ + nlists.ads nlists.adb opt.ads output.ads sinfo.ads sinfo.adb sinput.ads \ + snames.ads stand.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads + +back_end.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb \ + back_end.ads back_end.adb casing.ads debug.ads einfo.ads einfo.adb \ + elists.ads fname.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \ + hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb namet.ads \ + nlists.ads nlists.adb opt.ads osint.ads osint-c.ads output.ads \ + sinfo.ads sinfo.adb sinput.ads sinput.adb snames.ads stand.ads \ + stringt.ads switch.ads switch-c.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb tree_io.ads types.ads uintp.ads uintp.adb uname.ads \ + unchconv.ads unchdeal.ads urealp.ads -bcheck.o : ada.ads a-except.ads ali.ads ali-util.ads alloc.ads bcheck.ads \ - bcheck.adb binderr.ads butil.ads casing.ads debug.ads fname.ads \ - gnat.ads g-htable.ads g-os_lib.ads gnatvsn.ads hostparm.ads namet.ads \ - opt.ads osint.ads output.ads rident.ads system.ads s-exctab.ads \ - s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-wchcon.ads table.ads types.ads unchconv.ads unchdeal.ads +bcheck.o : ada.ads a-except.ads ali.ads ali-util.ads ali-util.adb \ + alloc.ads bcheck.ads bcheck.adb binderr.ads butil.ads casing.ads \ + debug.ads fname.ads gnat.ads g-htable.ads g-os_lib.ads gnatvsn.ads \ + hostparm.ads interfac.ads namet.ads namet.adb opt.ads osint.ads \ + output.ads rident.ads system.ads s-atacco.ads s-atacco.adb s-crc32.ads \ + s-crc32.adb s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads \ + widechar.ads binde.o : ada.ads a-except.ads ali.ads alloc.ads binde.ads binde.adb \ binderr.ads butil.ads casing.ads debug.ads fname.ads gnat.ads \ - g-htable.ads g-os_lib.ads gnatvsn.ads hostparm.ads namet.ads opt.ads \ - output.ads rident.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \ + g-htable.ads g-os_lib.ads gnatvsn.ads hostparm.ads namet.ads namet.adb \ + opt.ads output.ads rident.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-memory.ads s-secsta.ads s-stalib.ads s-stoele.ads \ s-wchcon.ads table.ads table.adb tree_io.ads types.ads unchconv.ads \ - unchdeal.ads + unchdeal.ads widechar.ads binderr.o : ada.ads a-except.ads alloc.ads binderr.ads binderr.adb \ - butil.ads hostparm.ads namet.ads opt.ads output.ads system.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads types.ads unchconv.ads \ - unchdeal.ads + butil.ads debug.ads gnat.ads g-os_lib.ads hostparm.ads namet.ads \ + opt.ads output.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-memory.ads s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads unchconv.ads unchdeal.ads bindgen.o : ada.ads a-except.ads ali.ads alloc.ads binde.ads bindgen.ads \ - bindgen.adb butil.ads casing.ads fname.ads gnat.ads g-hesora.ads \ - g-htable.ads g-os_lib.ads gnatvsn.ads hostparm.ads namet.ads opt.ads \ - osint.ads output.ads rident.ads sdefault.ads system.ads s-assert.ads \ - s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + bindgen.adb butil.ads casing.ads debug.ads fname.ads gnat.ads \ + g-hesora.ads g-htable.ads g-os_lib.ads gnatvsn.ads hostparm.ads \ + namet.ads opt.ads osint.ads osint-b.ads output.ads rident.ads \ + sdefault.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ s-stoele.ads s-strops.ads s-sopco3.ads s-sopco4.ads s-sopco5.ads \ - s-wchcon.ads table.ads types.ads unchconv.ads unchdeal.ads + s-wchcon.ads table.ads table.adb tree_io.ads types.ads unchconv.ads \ + unchdeal.ads bindusg.o : bindusg.ads bindusg.adb gnat.ads g-os_lib.ads osint.ads \ output.ads system.ads s-exctab.ads s-stalib.ads types.ads unchconv.ads \ unchdeal.ads -butil.o : alloc.ads butil.ads butil.adb hostparm.ads namet.ads output.ads \ - system.ads s-exctab.ads s-stalib.ads table.ads types.ads unchconv.ads \ - unchdeal.ads - -casing.o : alloc.ads casing.ads casing.adb csets.ads hostparm.ads \ - namet.ads opt.ads system.ads s-exctab.ads s-stalib.ads s-wchcon.ads \ - table.ads types.ads unchconv.ads unchdeal.ads widechar.ads - -checks.o : ada.ads a-except.ads alloc.ads atree.ads checks.ads checks.adb \ - debug.ads einfo.ads elists.ads errout.ads exp_ch2.ads exp_util.ads \ - freeze.ads get_targ.ads hostparm.ads namet.ads nlists.ads nmake.ads \ - opt.ads rtsfind.ads sem.ads sem_eval.ads sem_res.ads sem_util.ads \ - sem_warn.ads sinfo.ads snames.ads stand.ads system.ads s-assert.ads \ - s-exctab.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-wchcon.ads table.ads tbuild.ads ttypes.ads types.ads uintp.ads \ - unchconv.ads unchdeal.ads urealp.ads validsw.ads +butil.o : ada.ads a-except.ads alloc.ads butil.ads butil.adb debug.ads \ + gnat.ads g-os_lib.ads hostparm.ads namet.ads opt.ads output.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-memory.ads \ + s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ + unchconv.ads unchdeal.ads -comperr.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads \ - comperr.ads comperr.adb debug.ads einfo.ads errout.ads fname.ads \ - gnat.ads g-os_lib.ads gnatvsn.ads lib.ads namet.ads osint.ads \ - output.ads sdefault.ads sinfo.ads sinput.ads snames.ads sprint.ads \ - system.ads s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads table.ads treepr.ads types.ads uintp.ads \ +casing.o : ada.ads a-except.ads alloc.ads casing.ads casing.adb csets.ads \ + csets.adb debug.ads gnat.ads g-os_lib.ads hostparm.ads namet.ads \ + opt.ads output.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-memory.ads s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads unchconv.ads unchdeal.ads widechar.ads + +checks.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + elists.adb errout.ads eval_fat.ads exp_ch11.ads exp_ch2.ads exp_ch7.ads \ + exp_util.ads exp_util.adb freeze.ads get_targ.ads gnat.ads g-htable.ads \ + g-os_lib.ads hostparm.ads inline.ads itypes.ads lib.ads namet.ads \ + nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \ + restrict.ads rident.ads rtsfind.ads sem.ads sem_cat.ads sem_ch8.ads \ + sem_eval.ads sem_eval.adb sem_res.ads sem_type.ads sem_util.ads \ + sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \ + stringt.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \ + tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads \ + uintp.adb unchconv.ads unchdeal.ads urealp.ads validsw.ads + +comperr.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + comperr.ads comperr.adb debug.ads einfo.ads einfo.adb elists.ads \ + errout.ads fname.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \ + gnatvsn.ads hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb \ + namet.ads nlists.ads nlists.adb opt.ads osint.ads output.ads output.adb \ + sdefault.ads sinfo.ads sinfo.adb sinput.ads sinput.adb snames.ads \ + sprint.ads stand.ads stringt.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tree_io.ads treepr.ads types.ads uintp.ads uintp.adb uname.ads \ unchconv.ads unchdeal.ads urealp.ads csets.o : csets.ads csets.adb hostparm.ads opt.ads system.ads s-exctab.ads \ s-stalib.ads s-wchcon.ads types.ads unchconv.ads unchdeal.ads -cstand.o : ada.ads a-except.ads alloc.ads atree.ads csets.ads cstand.ads \ - cstand.adb debug.ads einfo.ads get_targ.ads hostparm.ads layout.ads \ - namet.ads nlists.ads nmake.ads opt.ads sem_mech.ads sem_util.ads \ - sinfo.ads snames.ads stand.ads system.ads s-assert.ads s-exctab.ads \ - s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-wchcon.ads table.ads tbuild.ads ttypef.ads ttypes.ads \ - types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -debug_a.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads debug.ads \ - debug_a.ads debug_a.adb einfo.ads output.ads sinfo.ads sinput.ads \ - snames.ads system.ads s-exctab.ads s-imgenu.ads s-secsta.ads \ - s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads table.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads +cstand.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + csets.ads cstand.ads cstand.adb debug.ads einfo.ads einfo.adb \ + elists.ads errout.ads exp_util.ads freeze.ads get_targ.ads gnat.ads \ + g-htable.ads g-os_lib.ads hostparm.ads layout.ads lib.ads lib-xref.ads \ + namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \ + output.ads restrict.ads rident.ads rtsfind.ads scans.ads scn.ads \ + sem.ads sem_ch8.ads sem_eval.ads sem_mech.ads sem_res.ads sem_type.ads \ + sem_util.ads sem_util.adb sinfo.ads sinfo.adb sinput.ads snames.ads \ + stand.ads stringt.ads style.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + targparm.ads tbuild.ads tbuild.adb tree_io.ads ttypef.ads ttypes.ads \ + types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads \ + urealp.adb widechar.ads debug.o : debug.ads debug.adb system.ads -einfo.o : ada.ads a-except.ads alloc.ads atree.ads einfo.ads einfo.adb \ - namet.ads nlists.ads output.ads sinfo.ads snames.ads stand.ads \ - system.ads s-assert.ads s-exctab.ads s-imgenu.ads s-secsta.ads \ - s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads table.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads +debug_a.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads debug_a.ads debug_a.adb einfo.ads elists.ads gnat.ads \ + g-htable.ads g-os_lib.ads hostparm.ads nlists.ads nlists.adb opt.ads \ + output.ads sinfo.ads sinput.ads snames.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb tree_io.ads types.ads uintp.ads unchconv.ads \ + unchdeal.ads urealp.ads + +einfo.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads gnat.ads g-htable.ads \ + g-os_lib.ads hostparm.ads namet.ads nlists.ads nlists.adb opt.ads \ + output.ads sinfo.ads sinfo.adb sinput.ads snames.ads snames.adb \ + stand.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads elists.o : ada.ads a-except.ads alloc.ads debug.ads elists.ads elists.adb \ gnat.ads g-os_lib.ads hostparm.ads opt.ads output.ads system.ads \ - s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb \ - tree_io.ads types.ads unchconv.ads unchdeal.ads + s-atacco.ads s-atacco.adb s-exctab.ads s-memory.ads s-stalib.ads \ + s-wchcon.ads table.ads table.adb tree_io.ads types.ads unchconv.ads \ + unchdeal.ads errout.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ - csets.ads debug.ads einfo.ads elists.ads errout.ads errout.adb \ - fname.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads \ - namet.ads nlists.ads opt.ads output.ads scans.ads sinfo.ads sinput.ads \ - snames.ads stand.ads style.ads system.ads s-assert.ads s-exctab.ads \ - s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ - uintp.ads uname.ads unchconv.ads unchdeal.ads urealp.ads - -eval_fat.o : alloc.ads einfo.ads eval_fat.ads eval_fat.adb sem_util.ads \ - system.ads s-assert.ads s-exctab.ads s-stalib.ads table.ads \ - targparm.ads ttypef.ads types.ads uintp.ads unchconv.ads unchdeal.ads \ - urealp.ads - -exp_aggr.o : alloc.ads atree.ads checks.ads einfo.ads elists.ads \ - exp_aggr.ads exp_aggr.adb exp_ch3.ads exp_ch7.ads exp_util.ads \ - expander.ads freeze.ads hostparm.ads itypes.ads namet.ads nlists.ads \ - nmake.ads opt.ads restrict.ads rident.ads rtsfind.ads sem.ads \ - sem_ch3.ads sem_eval.ads sem_res.ads sem_util.ads sinfo.ads snames.ads \ - stand.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \ - s-wchcon.ads table.ads tbuild.ads types.ads uintp.ads unchconv.ads \ - unchdeal.ads urealp.ads - -expander.o : ada.ads a-except.ads alloc.ads atree.ads debug.ads \ - debug_a.ads einfo.ads elists.ads errout.ads exp_aggr.ads exp_attr.ads \ - exp_ch11.ads exp_ch12.ads exp_ch13.ads exp_ch2.ads exp_ch3.ads \ - exp_ch4.ads exp_ch5.ads exp_ch6.ads exp_ch7.ads exp_ch8.ads exp_ch9.ads \ - exp_prag.ads expander.ads expander.adb gnat.ads g-os_lib.ads \ - hostparm.ads opt.ads output.ads sem.ads sem_ch8.ads sem_util.ads \ - sinfo.ads snames.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \ + csets.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \ + errout.adb fname.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \ + hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb namet.ads \ + nlists.ads nlists.adb opt.ads output.ads output.adb scans.ads scn.ads \ + sinfo.ads sinfo.adb sinput.ads sinput.adb snames.ads stand.ads \ + stringt.ads style.ads style.adb stylesw.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-exctab.adb s-imgenu.ads s-memory.ads \ + s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ s-wchcon.ads table.ads table.adb tree_io.ads types.ads uintp.ads \ - unchconv.ads unchdeal.ads urealp.ads + uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads + +eval_fat.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads eval_fat.ads eval_fat.adb \ + gnat.ads g-htable.ads g-os_lib.ads hostparm.ads namet.ads nlists.ads \ + nlists.adb opt.ads output.ads sem_util.ads sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + targparm.ads tree_io.ads ttypef.ads types.ads uintp.ads uintp.adb \ + unchconv.ads unchdeal.ads urealp.ads urealp.adb + +exp_aggr.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + elists.adb errout.ads exp_aggr.ads exp_aggr.adb exp_ch11.ads \ + exp_ch2.ads exp_ch3.ads exp_ch7.ads exp_util.ads exp_util.adb \ + expander.ads fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads \ + g-htable.ads g-os_lib.ads hostparm.ads inline.ads itypes.ads lib.ads \ + lib.adb lib-list.adb lib-sort.adb namet.ads nlists.ads nlists.adb \ + nmake.ads nmake.adb opt.ads output.ads restrict.ads rident.ads \ + rtsfind.ads sem.ads sem_ch3.ads sem_ch8.ads sem_eval.ads sem_res.ads \ + sem_util.ads sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads \ + stand.ads stringt.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-exctab.adb s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + targparm.ads tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads \ + uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads \ + validsw.ads -exp_attr.o : alloc.ads atree.ads checks.ads einfo.ads exp_attr.ads \ - exp_attr.adb exp_ch2.ads exp_ch9.ads exp_imgv.ads exp_pakd.ads \ - exp_strm.ads exp_tss.ads exp_util.ads get_targ.ads gnatvsn.ads \ - hostparm.ads lib.ads namet.ads nlists.ads nmake.ads opt.ads \ - restrict.ads rident.ads rtsfind.ads sem.ads sem_ch13.ads sem_ch7.ads \ - sem_ch8.ads sem_eval.ads sem_res.ads sem_util.ads sinfo.ads snames.ads \ - stand.ads stringt.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \ - s-wchcon.ads table.ads tbuild.ads ttypes.ads types.ads uintp.ads \ - uname.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads +exp_attr.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + errout.ads exp_attr.ads exp_attr.adb exp_ch11.ads exp_ch2.ads \ + exp_ch7.ads exp_ch9.ads exp_imgv.ads exp_pakd.ads exp_strm.ads \ + exp_tss.ads exp_util.ads exp_util.adb fname.ads fname-uf.ads freeze.ads \ + get_targ.ads gnat.ads g-htable.ads g-os_lib.ads gnatvsn.ads \ + hostparm.ads inline.ads itypes.ads lib.ads lib-xref.ads namet.ads \ + namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \ + restrict.ads restrict.adb rident.ads rtsfind.ads scans.ads scn.ads \ + sem.ads sem_ch7.ads sem_ch8.ads sem_eval.ads sem_res.ads sem_type.ads \ + sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinput.ads \ + snames.ads stand.ads stringt.ads stringt.adb style.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads \ + s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ + s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tbuild.adb \ + tree_io.ads ttypes.ads types.ads types.adb uintp.ads uintp.adb \ + uname.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads widechar.ads exp_ch11.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ - debug.ads einfo.ads elists.ads exp_ch11.ads exp_ch11.adb exp_ch7.ads \ - exp_util.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads inline.ads \ - lib.ads namet.ads nlists.ads nmake.ads opt.ads output.ads restrict.ads \ - rident.ads rtsfind.ads sem.ads sem_ch5.ads sem_ch8.ads sem_res.ads \ - sem_util.ads sinfo.ads sinput.ads snames.ads stand.ads stringt.ads \ - system.ads s-assert.ads s-exctab.ads s-imgenu.ads s-secsta.ads \ - s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ - table.ads targparm.ads tbuild.ads tree_io.ads types.ads uintp.ads \ - uname.ads unchconv.ads unchdeal.ads urealp.ads - -exp_ch12.o : alloc.ads atree.ads checks.ads einfo.ads exp_ch12.ads \ - exp_ch12.adb exp_util.ads namet.ads nlists.ads nmake.ads rtsfind.ads \ - sinfo.ads snames.ads stand.ads system.ads s-exctab.ads s-stalib.ads \ - table.ads tbuild.ads types.ads uintp.ads unchconv.ads unchdeal.ads \ - urealp.ads - -exp_ch13.o : alloc.ads atree.ads einfo.ads elists.ads exp_ch13.ads \ - exp_ch13.adb exp_ch3.ads exp_ch6.ads exp_imgv.ads exp_util.ads \ - hostparm.ads namet.ads nlists.ads nmake.ads opt.ads rtsfind.ads sem.ads \ - sem_ch7.ads sem_ch8.ads sem_eval.ads sem_util.ads sinfo.ads snames.ads \ - stand.ads stringt.ads system.ads s-exctab.ads s-stalib.ads s-wchcon.ads \ - table.ads tbuild.ads types.ads uintp.ads unchconv.ads unchdeal.ads \ - urealp.ads - -exp_ch2.o : alloc.ads atree.ads einfo.ads elists.ads exp_ch2.ads \ - exp_ch2.adb exp_smem.ads exp_util.ads exp_vfpt.ads hostparm.ads \ - nlists.ads nmake.ads opt.ads rtsfind.ads sem.ads sem_res.ads \ - sem_util.ads sinfo.ads snames.ads system.ads s-exctab.ads s-stalib.ads \ - s-wchcon.ads table.ads tbuild.ads types.ads uintp.ads unchconv.ads \ - unchdeal.ads urealp.ads - -exp_ch3.o : alloc.ads atree.ads checks.ads einfo.ads elists.ads \ - exp_aggr.ads exp_ch11.ads exp_ch3.ads exp_ch3.adb exp_ch4.ads \ - exp_ch7.ads exp_ch9.ads exp_disp.ads exp_dist.ads exp_smem.ads \ - exp_strm.ads exp_tss.ads exp_util.ads freeze.ads get_targ.ads \ - hostparm.ads namet.ads nlists.ads nmake.ads opt.ads restrict.ads \ - rident.ads rtsfind.ads sem.ads sem_ch3.ads sem_ch8.ads sem_eval.ads \ - sem_mech.ads sem_res.ads sem_util.ads sinfo.ads snames.ads stand.ads \ - system.ads s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads \ - table.ads tbuild.ads ttypes.ads types.ads uintp.ads unchconv.ads \ - unchdeal.ads urealp.ads validsw.ads + casing.adb csets.ads debug.ads einfo.ads einfo.adb elists.ads \ + errout.ads exp_ch11.ads exp_ch11.adb exp_ch7.ads exp_util.ads fname.ads \ + fname-uf.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \ + g-os_lib.ads hostparm.ads inline.ads lib.ads lib.adb lib-list.adb \ + lib-sort.adb lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb \ + nmake.ads nmake.adb opt.ads output.ads restrict.ads restrict.adb \ + rident.ads rtsfind.ads scans.ads scn.ads sem.ads sem_ch5.ads \ + sem_ch8.ads sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \ + sem_util.adb sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \ + stringt.ads style.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \ + tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads types.adb \ + uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads \ + widechar.ads -exp_ch4.o : alloc.ads atree.ads checks.ads einfo.ads elists.ads errout.ads \ - exp_aggr.ads exp_ch3.ads exp_ch4.ads exp_ch4.adb exp_ch7.ads \ - exp_ch9.ads exp_disp.ads exp_fixd.ads exp_pakd.ads exp_tss.ads \ - exp_util.ads exp_vfpt.ads get_targ.ads hostparm.ads inline.ads \ - namet.ads nlists.ads nmake.ads opt.ads rtsfind.ads sem.ads sem_cat.ads \ - sem_ch13.ads sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \ - sinfo.ads sinfo-cn.ads snames.ads stand.ads system.ads s-assert.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads tbuild.ads ttypes.ads \ - types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads - -exp_ch5.o : alloc.ads atree.ads checks.ads einfo.ads exp_aggr.ads \ - exp_ch11.ads exp_ch5.ads exp_ch5.adb exp_ch7.ads exp_dbug.ads \ - exp_pakd.ads exp_util.ads get_targ.ads hostparm.ads namet.ads \ - nlists.ads nmake.ads opt.ads restrict.ads rident.ads rtsfind.ads \ - sem.ads sem_ch13.ads sem_ch8.ads sem_eval.ads sem_res.ads sem_util.ads \ - sinfo.ads snames.ads stand.ads system.ads s-assert.ads s-exctab.ads \ - s-stalib.ads s-wchcon.ads table.ads tbuild.ads ttypes.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads +exp_ch12.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + errout.ads exp_ch12.ads exp_ch12.adb exp_ch2.ads exp_util.ads \ + freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads \ + lib.ads namet.ads nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \ + output.ads restrict.ads rident.ads rtsfind.ads sem.ads sem_eval.ads \ + sem_res.ads sem_util.ads sem_warn.ads sinfo.ads sinfo.adb sinput.ads \ + snames.ads stand.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \ + tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads \ + uintp.adb unchconv.ads unchdeal.ads urealp.ads validsw.ads + +exp_ch13.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads debug.ads einfo.ads einfo.adb elists.ads exp_ch13.ads \ + exp_ch13.adb exp_ch3.ads exp_ch6.ads exp_imgv.ads exp_util.ads gnat.ads \ + g-htable.ads g-os_lib.ads hostparm.ads namet.ads nlists.ads nlists.adb \ + nmake.ads nmake.adb opt.ads output.ads rtsfind.ads sem.ads sem_ch7.ads \ + sem_ch8.ads sem_eval.ads sem_util.ads sinfo.ads sinfo.adb sinput.ads \ + snames.ads stand.ads stringt.ads stringt.adb system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb tbuild.ads tree_io.ads types.ads types.adb \ + uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads + +exp_ch2.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads debug.ads einfo.ads einfo.adb elists.ads elists.adb \ + errout.ads exp_ch11.ads exp_ch2.ads exp_ch2.adb exp_ch7.ads \ + exp_smem.ads exp_util.ads exp_util.adb exp_vfpt.ads get_targ.ads \ + gnat.ads g-htable.ads g-os_lib.ads hostparm.ads inline.ads itypes.ads \ + lib.ads namet.ads nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \ + output.ads restrict.ads rident.ads rtsfind.ads sem.ads sem_ch8.ads \ + sem_eval.ads sem_res.ads sem_util.ads sinfo.ads sinfo.adb sinput.ads \ + snames.ads stand.ads stringt.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + targparm.ads tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads \ + uintp.adb unchconv.ads unchdeal.ads urealp.ads validsw.ads + +exp_ch3.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + elists.adb errout.ads exp_aggr.ads exp_ch11.ads exp_ch2.ads exp_ch3.ads \ + exp_ch3.adb exp_ch4.ads exp_ch7.ads exp_ch9.ads exp_disp.ads \ + exp_dist.ads exp_smem.ads exp_strm.ads exp_tss.ads exp_tss.adb \ + exp_util.ads exp_util.adb fname.ads fname-uf.ads freeze.ads \ + get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads inline.ads \ + itypes.ads lib.ads namet.ads nlists.ads nlists.adb nmake.ads nmake.adb \ + opt.ads output.ads restrict.ads restrict.adb rident.ads rtsfind.ads \ + sem.ads sem_ch3.ads sem_ch8.ads sem_eval.ads sem_mech.ads sem_res.ads \ + sem_util.ads sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads \ + stand.ads stringt.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \ + tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads \ + uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads + +exp_ch4.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + elists.adb errout.ads exp_aggr.ads exp_ch11.ads exp_ch2.ads exp_ch3.ads \ + exp_ch4.ads exp_ch4.adb exp_ch7.ads exp_ch9.ads exp_disp.ads \ + exp_fixd.ads exp_pakd.ads exp_tss.ads exp_util.ads exp_util.adb \ + exp_vfpt.ads freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads \ + hostparm.ads inline.ads itypes.ads lib.ads namet.ads nlists.ads \ + nlists.adb nmake.ads nmake.adb opt.ads output.ads restrict.ads \ + rident.ads rtsfind.ads sem.ads sem_cat.ads sem_ch13.ads sem_ch8.ads \ + sem_eval.ads sem_res.ads sem_type.ads sem_util.ads sem_warn.ads \ + sinfo.ads sinfo.adb sinfo-cn.ads sinput.ads snames.ads stand.ads \ + stringt.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \ + tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads \ + uintp.adb unchconv.ads unchdeal.ads urealp.ads urealp.adb validsw.ads + +exp_ch5.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + errout.ads exp_aggr.ads exp_ch11.ads exp_ch2.ads exp_ch5.ads \ + exp_ch5.adb exp_ch7.ads exp_dbug.ads exp_pakd.ads exp_util.ads \ + exp_util.adb fname.ads fname-uf.ads freeze.ads get_targ.ads gnat.ads \ + g-htable.ads g-os_lib.ads hostparm.ads inline.ads itypes.ads lib.ads \ + lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb nmake.ads \ + nmake.adb opt.ads output.ads restrict.ads restrict.adb rident.ads \ + rtsfind.ads scans.ads scn.ads sem.ads sem_ch13.ads sem_ch8.ads \ + sem_eval.ads sem_res.ads sem_type.ads sem_util.ads sem_util.adb \ + sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \ + stringt.ads style.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \ + tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads \ + uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads \ + widechar.ads exp_ch6.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ - checks.ads debug.ads einfo.ads elists.ads errout.ads exp_ch11.ads \ - exp_ch2.ads exp_ch3.ads exp_ch6.ads exp_ch6.adb exp_ch7.ads exp_ch9.ads \ - exp_dbug.ads exp_disp.ads exp_dist.ads exp_intr.ads exp_pakd.ads \ - exp_tss.ads exp_util.ads freeze.ads get_targ.ads gnat.ads g-htable.ads \ - g-os_lib.ads hostparm.ads inline.ads lib.ads namet.ads nlists.ads \ - nmake.ads opt.ads output.ads restrict.ads rident.ads rtsfind.ads \ - sem.ads sem_ch12.ads sem_ch13.ads sem_ch6.ads sem_ch8.ads sem_disp.ads \ - sem_dist.ads sem_res.ads sem_util.ads sinfo.ads sinput.ads snames.ads \ - stand.ads system.ads s-assert.ads s-exctab.ads s-imgenu.ads \ - s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-wchcon.ads table.ads tbuild.ads tree_io.ads types.ads uintp.ads \ - unchconv.ads unchdeal.ads urealp.ads validsw.ads + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + elists.adb errout.ads exp_ch11.ads exp_ch2.ads exp_ch3.ads exp_ch6.ads \ + exp_ch6.adb exp_ch7.ads exp_ch9.ads exp_dbug.ads exp_disp.ads \ + exp_dist.ads exp_intr.ads exp_pakd.ads exp_tss.ads exp_util.ads \ + exp_util.adb freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads \ + hostparm.ads inline.ads itypes.ads lib.ads lib-xref.ads namet.ads \ + namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \ + restrict.ads rident.ads rtsfind.ads scans.ads scn.ads sem.ads \ + sem_ch12.ads sem_ch13.ads sem_ch6.ads sem_ch8.ads sem_disp.ads \ + sem_dist.ads sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \ + sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads \ + stand.ads stringt.ads style.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + targparm.ads tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads \ + uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads validsw.ads \ + widechar.ads -exp_ch7.o : alloc.ads atree.ads debug.ads einfo.ads exp_ch11.ads \ - exp_ch7.ads exp_ch7.adb exp_ch9.ads exp_dbug.ads exp_tss.ads \ - exp_util.ads freeze.ads get_targ.ads hostparm.ads lib.ads lib-xref.ads \ - namet.ads nlists.ads nmake.ads opt.ads output.ads restrict.ads \ +exp_ch7.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \ + exp_ch11.ads exp_ch7.ads exp_ch7.adb exp_ch9.ads exp_dbug.ads \ + exp_tss.ads exp_util.ads exp_util.adb fname.ads fname-uf.ads freeze.ads \ + get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads inline.ads \ + itypes.ads lib.ads lib-xref.ads namet.ads nlists.ads nlists.adb \ + nmake.ads nmake.adb opt.ads output.ads restrict.ads restrict.adb \ rident.ads rtsfind.ads sem.ads sem_ch3.ads sem_ch7.ads sem_ch8.ads \ - sem_res.ads sem_type.ads sem_util.ads sinfo.ads snames.ads stand.ads \ - system.ads s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads \ - table.ads targparm.ads tbuild.ads types.ads uintp.ads unchconv.ads \ - unchdeal.ads urealp.ads + sem_eval.ads sem_res.ads sem_type.ads sem_util.ads sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads stringt.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb targparm.ads tbuild.ads tbuild.adb tree_io.ads \ + ttypes.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \ + unchdeal.ads urealp.ads validsw.ads -exp_ch8.o : alloc.ads atree.ads einfo.ads exp_ch8.ads exp_ch8.adb \ - exp_dbug.ads exp_util.ads get_targ.ads hostparm.ads namet.ads \ - nlists.ads opt.ads rtsfind.ads sem.ads sem_ch8.ads sinfo.ads snames.ads \ - stand.ads system.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads \ - types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads +exp_ch8.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \ + exp_ch11.ads exp_ch7.ads exp_ch8.ads exp_ch8.adb exp_dbug.ads \ + exp_util.ads exp_util.adb get_targ.ads gnat.ads g-htable.ads \ + g-os_lib.ads hostparm.ads inline.ads itypes.ads lib.ads namet.ads \ + nlists.ads nlists.adb nmake.ads opt.ads output.ads restrict.ads \ + rident.ads rtsfind.ads sem.ads sem_ch8.ads sem_eval.ads sem_res.ads \ + sem_util.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \ + stringt.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \ + tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb \ + unchconv.ads unchdeal.ads urealp.ads validsw.ads exp_ch9.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ - checks.ads debug.ads einfo.ads elists.ads errout.ads exp_ch11.ads \ - exp_ch3.ads exp_ch6.ads exp_ch9.ads exp_ch9.adb exp_dbug.ads \ - exp_smem.ads exp_tss.ads exp_util.ads freeze.ads get_targ.ads gnat.ads \ - g-htable.ads g-os_lib.ads hostparm.ads namet.ads nlists.ads nmake.ads \ - opt.ads output.ads restrict.ads rident.ads rtsfind.ads sem.ads \ - sem_ch11.ads sem_ch6.ads sem_ch8.ads sem_elab.ads sem_res.ads \ - sem_util.ads sinfo.ads sinput.ads snames.ads stand.ads system.ads \ - s-assert.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \ - s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads \ - tbuild.ads tree_io.ads types.ads uintp.ads unchconv.ads unchdeal.ads \ - urealp.ads + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + elists.adb errout.ads exp_ch11.ads exp_ch2.ads exp_ch3.ads exp_ch6.ads \ + exp_ch7.ads exp_ch9.ads exp_ch9.adb exp_dbug.ads exp_smem.ads \ + exp_tss.ads exp_util.ads exp_util.adb fname.ads fname-uf.ads freeze.ads \ + get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads inline.ads \ + itypes.ads lib.ads lib-xref.ads namet.ads namet.adb nlists.ads \ + nlists.adb nmake.ads nmake.adb opt.ads output.ads restrict.ads \ + restrict.adb rident.ads rtsfind.ads scans.ads scn.ads sem.ads \ + sem_ch11.ads sem_ch6.ads sem_ch8.ads sem_elab.ads sem_eval.ads \ + sem_res.ads sem_type.ads sem_util.ads sem_util.adb sem_warn.ads \ + sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads stringt.ads \ + style.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \ + tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads \ + uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads \ + widechar.ads -exp_code.o : alloc.ads atree.ads einfo.ads errout.ads exp_code.ads \ - exp_code.adb fname.ads hostparm.ads lib.ads namet.ads nlists.ads \ - nmake.ads opt.ads rtsfind.ads sem_eval.ads sem_util.ads sinfo.ads \ - snames.ads stringt.ads system.ads s-assert.ads s-exctab.ads \ - s-stalib.ads s-wchcon.ads table.ads tbuild.ads types.ads uintp.ads \ - unchconv.ads unchdeal.ads urealp.ads +exp_code.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \ + eval_fat.ads exp_code.ads exp_code.adb exp_util.ads fname.ads \ + freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \ + hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb lib-xref.ads \ + namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \ + output.ads restrict.ads rident.ads rtsfind.ads scans.ads scn.ads \ + sem.ads sem_cat.ads sem_ch8.ads sem_eval.ads sem_eval.adb sem_res.ads \ + sem_type.ads sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads stringt.ads stringt.adb style.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads \ + tree_io.ads ttypes.ads types.ads types.adb uintp.ads uintp.adb \ + uname.ads unchconv.ads unchdeal.ads urealp.ads widechar.ads exp_dbug.o : ada.ads a-except.ads a-uncdea.ads alloc.ads atree.ads \ - casing.ads debug.ads einfo.ads exp_dbug.ads exp_dbug.adb exp_util.ads \ - freeze.ads get_targ.ads gnat.ads g-htable.ads g-htable.adb g-os_lib.ads \ - hostparm.ads lib.ads namet.ads nlists.ads nmake.ads opt.ads output.ads \ - rtsfind.ads sem_eval.ads sem_util.ads sinfo.ads sinput.ads snames.ads \ - stand.ads stringt.ads system.ads s-assert.ads s-exctab.ads s-secsta.ads \ - s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ - table.ads table.adb tree_io.ads types.ads uintp.ads unchconv.ads \ - unchdeal.ads urealp.ads - -exp_disp.o : alloc.ads atree.ads checks.ads einfo.ads elists.ads \ - errout.ads exp_ch7.ads exp_disp.ads exp_disp.adb exp_tss.ads \ - exp_util.ads fname.ads hostparm.ads itypes.ads lib.ads namet.ads \ - nlists.ads nmake.ads opt.ads rtsfind.ads sem_disp.ads sem_res.ads \ - sem_util.ads sinfo.ads snames.ads stand.ads system.ads s-assert.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads tbuild.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads - -exp_dist.o : ada.ads a-uncdea.ads alloc.ads atree.ads einfo.ads elists.ads \ - exp_dist.ads exp_dist.adb exp_tss.ads exp_util.ads gnat.ads \ - g-htable.ads g-htable.adb hostparm.ads lib.ads namet.ads nlists.ads \ - nmake.ads opt.ads rtsfind.ads sem.ads sem_ch3.ads sem_ch8.ads \ - sem_dist.ads sem_util.ads sinfo.ads snames.ads stand.ads stringt.ads \ - system.ads s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads \ - table.ads tbuild.ads types.ads uintp.ads uname.ads unchconv.ads \ - unchdeal.ads urealp.ads - -exp_fixd.o : alloc.ads atree.ads checks.ads einfo.ads exp_fixd.ads \ - exp_fixd.adb exp_util.ads get_targ.ads hostparm.ads namet.ads \ - nlists.ads nmake.ads opt.ads restrict.ads rident.ads rtsfind.ads \ - sem.ads sem_eval.ads sem_res.ads sem_util.ads sinfo.ads snames.ads \ - stand.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \ - s-wchcon.ads table.ads tbuild.ads ttypes.ads types.ads uintp.ads \ - unchconv.ads unchdeal.ads urealp.ads - -exp_imgv.o : alloc.ads atree.ads casing.ads checks.ads einfo.ads \ - exp_imgv.ads exp_imgv.adb exp_util.ads get_targ.ads hostparm.ads \ - namet.ads nlists.ads nmake.ads opt.ads rtsfind.ads sem_res.ads \ - sinfo.ads snames.ads stand.ads stringt.ads system.ads s-assert.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads tbuild.ads ttypes.ads \ - types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads + atree.adb casing.ads checks.ads debug.ads einfo.ads einfo.adb \ + elists.ads errout.ads eval_fat.ads exp_dbug.ads exp_dbug.adb \ + exp_util.ads fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads \ + g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads lib.ads lib.adb \ + lib-list.adb lib-sort.adb namet.ads namet.adb nlists.ads nlists.adb \ + nmake.ads nmake.adb opt.ads output.ads rtsfind.ads sem.ads sem_cat.ads \ + sem_ch8.ads sem_eval.ads sem_eval.adb sem_res.ads sem_type.ads \ + sem_util.ads sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads \ + stand.ads stringt.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tbuild.ads \ + tree_io.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \ + unchdeal.ads urealp.ads urealp.adb widechar.ads + +exp_disp.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + elists.adb errout.ads exp_ch11.ads exp_ch2.ads exp_ch7.ads exp_disp.ads \ + exp_disp.adb exp_tss.ads exp_tss.adb exp_util.ads exp_util.adb \ + fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \ + g-os_lib.ads hostparm.ads inline.ads itypes.ads lib.ads lib.adb \ + lib-list.adb lib-sort.adb lib-xref.ads namet.ads namet.adb nlists.ads \ + nlists.adb nmake.ads nmake.adb opt.ads output.ads restrict.ads \ + rident.ads rtsfind.ads scans.ads scn.ads sem.ads sem_ch8.ads \ + sem_disp.ads sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \ + sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads \ + stand.ads stringt.ads style.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + targparm.ads tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads \ + uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads \ + validsw.ads widechar.ads + +exp_dist.o : ada.ads a-except.ads a-uncdea.ads alloc.ads atree.ads \ + atree.adb casing.ads debug.ads einfo.ads einfo.adb elists.ads \ + elists.adb exp_dist.ads exp_dist.adb exp_tss.ads exp_util.ads fname.ads \ + gnat.ads g-hesora.ads g-htable.ads g-htable.adb g-os_lib.ads \ + hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb namet.ads \ + nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \ + restrict.ads rident.ads rtsfind.ads sem.ads sem_ch3.ads sem_ch8.ads \ + sem_dist.ads sem_util.ads sinfo.ads sinfo.adb sinput.ads snames.ads \ + stand.ads stringt.ads stringt.adb system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tbuild.ads tbuild.adb tree_io.ads types.ads uintp.ads uintp.adb \ + uname.ads unchconv.ads unchdeal.ads urealp.ads -exp_intr.o : alloc.ads atree.ads casing.ads einfo.ads errout.ads \ +exp_fixd.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + errout.ads eval_fat.ads exp_ch2.ads exp_fixd.ads exp_fixd.adb \ + exp_util.ads freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads \ + hostparm.ads namet.ads nlists.ads nlists.adb nmake.ads nmake.adb \ + opt.ads output.ads restrict.ads rident.ads rtsfind.ads sem.ads \ + sem_cat.ads sem_ch8.ads sem_eval.ads sem_eval.adb sem_res.ads \ + sem_type.ads sem_util.ads sem_warn.ads sinfo.ads sinfo.adb sinput.ads \ + snames.ads stand.ads stringt.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + targparm.ads tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads \ + uintp.adb unchconv.ads unchdeal.ads urealp.ads urealp.adb validsw.ads + +exp_imgv.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads debug.ads einfo.ads einfo.adb elists.ads exp_imgv.ads \ + exp_imgv.adb exp_util.ads get_targ.ads gnat.ads g-htable.ads \ + g-os_lib.ads hostparm.ads lib.ads namet.ads nlists.ads nlists.adb \ + nmake.ads nmake.adb opt.ads output.ads restrict.ads rident.ads \ + rtsfind.ads sem_res.ads sinfo.ads sinfo.adb sinput.ads snames.ads \ + stand.ads stringt.ads stringt.adb system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads \ + uintp.adb unchconv.ads unchdeal.ads urealp.ads + +exp_intr.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \ exp_ch11.ads exp_ch4.ads exp_ch7.ads exp_ch9.ads exp_code.ads \ - exp_fixd.ads exp_intr.ads exp_intr.adb exp_util.ads hostparm.ads \ - itypes.ads namet.ads nlists.ads nmake.ads opt.ads restrict.ads \ - rident.ads rtsfind.ads sem.ads sem_eval.ads sem_res.ads sem_util.ads \ - sinfo.ads sinput.ads snames.ads stand.ads stringt.ads system.ads \ - s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads \ - tbuild.ads types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -exp_pakd.o : alloc.ads atree.ads checks.ads einfo.ads exp_dbug.ads \ - exp_pakd.ads exp_pakd.adb exp_util.ads get_targ.ads hostparm.ads \ - namet.ads nlists.ads nmake.ads opt.ads rtsfind.ads sem.ads sem_ch13.ads \ - sem_ch8.ads sem_eval.ads sem_res.ads sem_util.ads sinfo.ads snames.ads \ - stand.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \ - s-wchcon.ads table.ads targparm.ads tbuild.ads ttypes.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads - -exp_prag.o : alloc.ads atree.ads casing.ads einfo.ads errout.ads \ - exp_ch11.ads exp_prag.ads exp_prag.adb exp_tss.ads exp_util.ads \ - expander.ads hostparm.ads namet.ads nlists.ads nmake.ads opt.ads \ - rtsfind.ads sem.ads sem_eval.ads sem_res.ads sem_util.ads sinfo.ads \ - sinput.ads snames.ads stand.ads stringt.ads system.ads s-assert.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads tbuild.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads + exp_fixd.ads exp_intr.ads exp_intr.adb exp_util.ads exp_util.adb \ + fname.ads fname-uf.ads freeze.ads get_targ.ads gnat.ads g-htable.ads \ + g-os_lib.ads hostparm.ads inline.ads itypes.ads lib.ads lib-xref.ads \ + namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \ + output.ads restrict.ads restrict.adb rident.ads rtsfind.ads scans.ads \ + scn.ads sem.ads sem_ch8.ads sem_eval.ads sem_res.ads sem_type.ads \ + sem_util.ads sem_util.adb sinfo.ads sinfo.adb sinput.ads sinput.adb \ + snames.ads stand.ads stringt.ads stringt.adb style.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads \ + s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ + s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tbuild.adb \ + tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb uname.ads \ + unchconv.ads unchdeal.ads urealp.ads urealp.adb validsw.ads \ + widechar.ads -exp_smem.o : alloc.ads atree.ads einfo.ads exp_smem.ads exp_smem.adb \ - exp_util.ads hostparm.ads namet.ads nlists.ads nmake.ads opt.ads \ - rtsfind.ads sem.ads sem_util.ads sinfo.ads snames.ads stand.ads \ - stringt.ads system.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads \ - tbuild.ads types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads +exp_pakd.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + errout.ads exp_ch11.ads exp_ch2.ads exp_ch7.ads exp_dbug.ads \ + exp_pakd.ads exp_pakd.adb exp_util.ads exp_util.adb freeze.ads \ + get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads inline.ads \ + itypes.ads lib.ads namet.ads nlists.ads nlists.adb nmake.ads nmake.adb \ + opt.ads output.ads restrict.ads rident.ads rtsfind.ads sem.ads \ + sem_ch13.ads sem_ch8.ads sem_eval.ads sem_res.ads sem_util.ads \ + sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \ + stringt.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \ + tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads \ + uintp.adb unchconv.ads unchdeal.ads urealp.ads validsw.ads + +exp_prag.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + casing.adb csets.ads debug.ads einfo.ads einfo.adb elists.ads \ + errout.ads exp_ch11.ads exp_prag.ads exp_prag.adb exp_tss.ads \ + exp_util.ads expander.ads gnat.ads g-htable.ads g-os_lib.ads \ + hostparm.ads namet.ads nlists.ads nlists.adb nmake.ads nmake.adb \ + opt.ads output.ads rtsfind.ads sem.ads sem_eval.ads sem_res.ads \ + sem_util.ads sinfo.ads sinfo.adb sinput.ads snames.ads snames.adb \ + stand.ads stringt.ads stringt.adb system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tbuild.ads tree_io.ads types.ads types.adb uintp.ads uintp.adb \ + unchconv.ads unchdeal.ads urealp.ads widechar.ads -exp_strm.o : alloc.ads atree.ads einfo.ads exp_strm.ads exp_strm.adb \ - exp_tss.ads get_targ.ads lib.ads namet.ads nlists.ads nmake.ads \ - rtsfind.ads sinfo.ads snames.ads stand.ads system.ads s-assert.ads \ - s-exctab.ads s-stalib.ads table.ads tbuild.ads ttypes.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads +exp_smem.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads exp_smem.ads exp_smem.adb \ + exp_util.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads \ + namet.ads nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \ + restrict.ads rident.ads rtsfind.ads sem.ads sem_util.ads sinfo.ads \ + sinfo.adb sinput.ads snames.ads stand.ads stringt.ads stringt.adb \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb tbuild.ads tbuild.adb \ + tree_io.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads \ + urealp.ads -exp_tss.o : alloc.ads atree.ads einfo.ads elists.ads exp_tss.ads \ - exp_tss.adb exp_util.ads lib.ads rtsfind.ads sem_util.ads sinfo.ads \ - snames.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads table.ads \ +exp_strm.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads exp_strm.ads exp_strm.adb \ + exp_tss.ads fname.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \ + g-os_lib.ads hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb \ + namet.ads nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \ + restrict.ads rident.ads rtsfind.ads sinfo.ads sinfo.adb sinput.ads \ + snames.ads stand.ads stringt.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads \ + uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads + +exp_tss.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads elists.adb exp_tss.ads \ + exp_tss.adb exp_util.ads gnat.ads g-htable.ads g-os_lib.ads \ + hostparm.ads lib.ads namet.ads nlists.ads nlists.adb opt.ads output.ads \ + rtsfind.ads sem_util.ads sinfo.ads sinfo.adb sinput.ads snames.ads \ + stand.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads + +exp_util.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads debug.ads einfo.ads einfo.adb elists.ads elists.adb \ + errout.ads eval_fat.ads exp_ch11.ads exp_ch7.ads exp_util.ads \ + exp_util.adb fname.ads fname-uf.ads get_targ.ads gnat.ads g-hesora.ads \ + g-htable.ads g-os_lib.ads hostparm.ads inline.ads itypes.ads lib.ads \ + lib.adb lib-list.adb lib-sort.adb namet.ads nlists.ads nlists.adb \ + nmake.ads nmake.adb opt.ads output.ads restrict.ads restrict.adb \ + rident.ads rtsfind.ads sem.ads sem_cat.ads sem_ch8.ads sem_eval.ads \ + sem_eval.adb sem_res.ads sem_type.ads sem_util.ads sem_warn.ads \ + sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads stringt.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads \ + tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb \ + uname.ads unchconv.ads unchdeal.ads urealp.ads urealp.adb validsw.ads + +exp_vfpt.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads exp_vfpt.ads exp_vfpt.adb \ + gnat.ads g-htable.ads g-os_lib.ads hostparm.ads namet.ads nlists.ads \ + nlists.adb nmake.ads nmake.adb opt.ads output.ads rtsfind.ads \ + sem_res.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb tbuild.ads tree_io.ads \ + ttypef.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads \ + urealp.ads urealp.adb + +expander.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads debug_a.ads debug_a.adb einfo.ads elists.ads errout.ads \ + exp_aggr.ads exp_attr.ads exp_ch11.ads exp_ch12.ads exp_ch13.ads \ + exp_ch2.ads exp_ch3.ads exp_ch4.ads exp_ch5.ads exp_ch6.ads exp_ch7.ads \ + exp_ch8.ads exp_ch9.ads exp_prag.ads expander.ads expander.adb gnat.ads \ + g-htable.ads g-os_lib.ads hostparm.ads nlists.ads nlists.adb opt.ads \ + output.ads sem.ads sem_ch8.ads sem_util.ads sinfo.ads sinput.ads \ + snames.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads -exp_util.o : alloc.ads atree.ads checks.ads einfo.ads elists.ads \ - errout.ads exp_ch11.ads exp_ch7.ads exp_util.ads exp_util.adb \ - get_targ.ads hostparm.ads inline.ads itypes.ads lib.ads namet.ads \ - nlists.ads nmake.ads opt.ads restrict.ads rident.ads rtsfind.ads \ - sem.ads sem_ch8.ads sem_eval.ads sem_res.ads sem_util.ads sinfo.ads \ - snames.ads stand.ads stringt.ads system.ads s-assert.ads s-exctab.ads \ - s-stalib.ads s-wchcon.ads table.ads tbuild.ads ttypes.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads - -exp_vfpt.o : alloc.ads atree.ads einfo.ads exp_vfpt.ads exp_vfpt.adb \ - namet.ads nlists.ads nmake.ads rtsfind.ads sem_res.ads sinfo.ads \ - snames.ads stand.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \ - table.ads tbuild.ads ttypef.ads types.ads uintp.ads unchconv.ads \ - unchdeal.ads urealp.ads +fmap.o : ada.ads a-except.ads a-uncdea.ads alloc.ads debug.ads fmap.ads \ + fmap.adb gnat.ads g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads \ + namet.ads opt.ads osint.ads output.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tree_io.ads types.ads unchconv.ads unchdeal.ads + +fname-uf.o : ada.ads a-except.ads a-uncdea.ads alloc.ads casing.ads \ + debug.ads fmap.ads fname.ads fname-uf.ads fname-uf.adb gnat.ads \ + g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads krunch.ads \ + namet.ads opt.ads osint.ads output.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-memory.ads s-stalib.ads s-stoele.ads \ + s-wchcon.ads table.ads table.adb tree_io.ads types.ads unchconv.ads \ + unchdeal.ads widechar.ads fname.o : ada.ads a-except.ads alloc.ads debug.ads fname.ads fname.adb \ gnat.ads g-os_lib.ads hostparm.ads namet.ads opt.ads output.ads \ - system.ads s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads \ - table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads - -fmap.o : alloc.ads debug.ads fmap.ads fmap.adb hostparm.ads namet.ads opt.ads \ - osint.ads output.ads table.ads table.adb tree_io.ads types.ads - -fname-sf.o : alloc.ads casing.ads fname.ads fname-sf.ads fname-sf.adb \ - fname-uf.ads gnat.ads g-os_lib.ads namet.ads osint.ads sfn_scan.ads \ - system.ads s-exctab.ads s-stalib.ads s-stoele.ads table.ads types.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-memory.ads \ + s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ unchconv.ads unchdeal.ads -fname-uf.o : ada.ads a-except.ads a-uncdea.ads alloc.ads casing.ads \ - debug.ads fname.ads fname-uf.ads fname-uf.adb gnat.ads g-htable.ads \ - g-htable.adb g-os_lib.ads hostparm.ads krunch.ads namet.ads opt.ads \ - osint.ads output.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \ - s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ - unchconv.ads unchdeal.ads widechar.ads - freeze.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ - debug.ads einfo.ads elists.ads errout.ads exp_ch11.ads exp_ch7.ads \ - exp_pakd.ads exp_util.ads freeze.ads freeze.adb get_targ.ads gnat.ads \ - g-htable.ads g-os_lib.ads hostparm.ads layout.ads namet.ads nlists.ads \ - nmake.ads opt.ads output.ads restrict.ads rident.ads rtsfind.ads \ - sem.ads sem_cat.ads sem_ch13.ads sem_ch6.ads sem_ch7.ads sem_ch8.ads \ - sem_eval.ads sem_mech.ads sem_prag.ads sem_res.ads sem_util.ads \ - sinfo.ads sinput.ads snames.ads stand.ads system.ads s-assert.ads \ - s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads s-wchcon.ads table.ads targparm.ads \ - tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads unchconv.ads \ - unchdeal.ads urealp.ads - -frontend.o : alloc.ads atree.ads casing.ads checks.ads cstand.ads \ - debug.ads einfo.ads elists.ads exp_ch11.ads exp_dbug.ads fname.ads \ - fname-uf.ads frontend.ads frontend.adb get_targ.ads gnat.ads \ - g-os_lib.ads hostparm.ads inline.ads lib.ads lib-load.ads live.ads \ - namet.ads nlists.ads opt.ads osint.ads output.ads par.ads rtsfind.ads \ - scn.ads sem.ads sem_ch8.ads sem_elab.ads sem_prag.ads sem_warn.ads \ - sinfo.ads sinput.ads sinput-l.ads snames.ads sprint.ads system.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads types.ads uintp.ads \ - unchconv.ads unchdeal.ads urealp.ads + debug.ads einfo.ads einfo.adb elists.ads elists.adb errout.ads \ + exp_ch11.ads exp_ch7.ads exp_pakd.ads exp_util.ads freeze.ads \ + freeze.adb get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads \ + layout.ads lib.ads lib-xref.ads namet.ads namet.adb nlists.ads \ + nlists.adb nmake.ads nmake.adb opt.ads output.ads restrict.ads \ + rident.ads rtsfind.ads scans.ads scn.ads sem.ads sem_cat.ads \ + sem_ch13.ads sem_ch6.ads sem_ch7.ads sem_ch8.ads sem_eval.ads \ + sem_mech.ads sem_prag.ads sem_res.ads sem_type.ads sem_util.ads \ + sem_util.adb sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \ + stringt.ads style.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-exctab.adb s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + targparm.ads tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads \ + uintp.adb unchconv.ads unchdeal.ads urealp.ads widechar.ads + +frontend.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads cstand.ads debug.ads einfo.ads einfo.adb elists.ads \ + exp_ch11.ads exp_dbug.ads fmap.ads fname.ads fname-uf.ads frontend.ads \ + frontend.adb get_targ.ads gnat.ads g-hesora.ads g-htable.ads \ + g-os_lib.ads hostparm.ads inline.ads lib.ads lib.adb lib-list.adb \ + lib-load.ads lib-sort.adb live.ads namet.ads nlists.ads nlists.adb \ + opt.ads osint.ads output.ads par.ads rtsfind.ads scn.ads sem.ads \ + sem_ch8.ads sem_elab.ads sem_prag.ads sem_warn.ads sinfo.ads sinfo.adb \ + sinput.ads sinput.adb sinput-l.ads snames.ads sprint.ads stand.ads \ + stringt.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads \ + urealp.ads -g-casuti.o : gnat.ads g-casuti.ads g-casuti.adb system.ads +g-hesora.o : gnat.ads g-hesora.ads g-hesora.adb system.ads -g-comlin.o : ada.ads a-comlin.ads a-except.ads a-finali.ads a-filico.ads \ - a-stream.ads a-tags.ads gnat.ads g-comlin.ads g-comlin.adb g-dirope.ads \ - g-regexp.ads system.ads s-exctab.ads s-finimp.ads s-finroo.ads \ - s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-stratt.ads s-strops.ads s-unstyp.ads unchconv.ads +g-htable.o : ada.ads a-uncdea.ads gnat.ads g-htable.ads g-htable.adb \ + system.ads -g-diopit.o : ada.ads a-charac.ads a-chahan.ads a-chlat1.ads a-except.ads \ - a-finali.ads a-filico.ads a-stream.ads a-string.ads a-strfix.ads \ - a-strmap.ads a-tags.ads gnat.ads g-dirope.ads g-dirope.adb \ - g-os_lib.ads g-regexp.ads system.ads s-exctab.ads s-finimp.ads \ - s-finroo.ads s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads s-unstyp.ads \ - unchconv.ads unchdeal.ads +g-os_lib.o : ada.ads a-except.ads gnat.ads g-os_lib.ads g-os_lib.adb \ + system.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads unchconv.ads unchdeal.ads -g-dirope.o : ada.ads a-charac.ads a-chahan.ads a-chlat1.ads a-except.ads \ - a-finali.ads a-filico.ads a-stream.ads a-string.ads a-strfix.ads \ - a-strmap.ads a-tags.ads gnat.ads g-dirope.ads g-dirope.adb \ - g-os_lib.ads system.ads s-exctab.ads s-finimp.ads \ - s-finroo.ads s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads s-unstyp.ads \ - unchconv.ads unchdeal.ads +g-speche.o : gnat.ads g-speche.ads g-speche.adb system.ads get_targ.o : get_targ.ads get_targ.adb system.ads s-exctab.ads \ s-stalib.ads types.ads unchconv.ads unchdeal.ads -g-except.o : gnat.ads g-except.ads system.ads - -g-hesora.o : gnat.ads g-hesora.ads g-hesora.adb system.ads - -g-htable.o : ada.ads a-uncdea.ads gnat.ads g-htable.ads g-htable.adb \ - system.ads +gnat.o : gnat.ads system.ads -g-io_aux.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \ - a-stream.ads a-tags.ads a-textio.ads gnat.ads g-io_aux.ads g-io_aux.adb \ - interfac.ads i-cstrea.ads system.ads s-exctab.ads s-ficobl.ads \ - s-finimp.ads s-finroo.ads s-parame.ads s-secsta.ads s-soflin.ads \ - s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads \ - s-unstyp.ads unchconv.ads - -gnat1drv.o : ada.ads a-except.ads alloc.ads atree.ads back_end.ads \ - casing.ads comperr.ads csets.ads debug.ads einfo.ads elists.ads \ - errout.ads fname.ads fname-uf.ads frontend.ads get_targ.ads gnat.ads \ - g-os_lib.ads gnat1drv.ads gnat1drv.adb gnatvsn.ads hostparm.ads \ - inline.ads lib.ads lib-writ.ads namet.ads nlists.ads opt.ads osint.ads \ - output.ads repinfo.ads restrict.ads rident.ads sem.ads sem_ch13.ads \ - sem_warn.ads sinfo.ads sinput.ads sinput-l.ads snames.ads sprint.ads \ - stringt.ads system.ads s-assert.ads s-exctab.ads s-soflin.ads \ - s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads \ - targparm.ads tree_gen.ads treepr.ads ttypes.ads types.ads uintp.ads \ +gnat1drv.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb \ + back_end.ads casing.ads comperr.ads csets.ads debug.ads einfo.ads \ + einfo.adb elists.ads errout.ads fname.ads fname-uf.ads frontend.ads \ + get_targ.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \ + gnat1drv.ads gnat1drv.adb gnatvsn.ads hostparm.ads inline.ads lib.ads \ + lib.adb lib-list.adb lib-sort.adb lib-writ.ads namet.ads nlists.ads \ + nlists.adb opt.ads osint.ads output.ads repinfo.ads restrict.ads \ + rident.ads sem.ads sem_ch13.ads sinfo.ads sinfo.adb sinput.ads \ + sinput-l.ads snames.ads sprint.ads stand.ads stringt.ads system.ads \ + s-atacco.ads s-atacco.adb s-assert.ads s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads tree_gen.ads \ + tree_io.ads treepr.ads ttypes.ads types.ads uintp.ads uintp.adb \ uname.ads unchconv.ads unchdeal.ads urealp.ads usage.ads -gnat.o : gnat.ads system.ads - gnatbind.o : ada.ads a-except.ads ali.ads ali-util.ads alloc.ads \ bcheck.ads binde.ads binderr.ads bindgen.ads bindusg.ads butil.ads \ - casing.ads csets.ads gnat.ads g-htable.ads g-os_lib.ads gnatbind.ads \ - gnatbind.adb gnatvsn.ads hostparm.ads namet.ads opt.ads osint.ads \ - output.ads rident.ads switch.ads system.ads s-assert.ads s-exctab.ads \ - s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-strops.ads s-wchcon.ads table.ads types.ads unchconv.ads unchdeal.ads - -gnatchop.o : ada.ads a-comlin.ads a-except.ads a-finali.ads a-filico.ads \ - a-ioexce.ads a-stream.ads a-tags.ads a-textio.ads gnat.ads g-comlin.ads \ - g-dirope.ads g-hesorg.ads g-hesorg.adb g-os_lib.ads g-regexp.ads \ - g-table.ads g-table.adb gnatchop.adb gnatvsn.ads hostparm.ads \ - interfac.ads i-cstrea.ads system.ads s-assert.ads s-exctab.ads \ - s-ficobl.ads s-finimp.ads s-finroo.ads s-imgint.ads s-parame.ads \ - s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-stratt.ads s-strops.ads s-sopco3.ads s-sopco4.ads s-sopco5.ads \ - s-unstyp.ads s-valint.ads unchconv.ads unchdeal.ads - -gnatcmd.o : ada.ads a-charac.ads a-chahan.ads a-comlin.ads a-except.ads \ - a-finali.ads a-filico.ads a-ioexce.ads a-stream.ads a-tags.ads \ - a-textio.ads debug.ads gnat.ads g-os_lib.ads gnatcmd.ads gnatcmd.adb \ - gnatvsn.ads hostparm.ads interfac.ads i-cstrea.ads opt.ads osint.ads \ - output.ads sdefault.ads system.ads s-assert.ads s-exctab.ads \ - s-ficobl.ads s-finimp.ads s-finroo.ads s-imgint.ads s-parame.ads \ - s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-stratt.ads s-strops.ads s-sopco4.ads s-unstyp.ads s-wchcon.ads \ - table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads - -gnatfind.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-finali.ads \ - a-filico.ads a-ioexce.ads a-stream.ads a-string.ads a-strfix.ads \ - a-strmap.ads a-strunb.ads a-tags.ads a-textio.ads gnat.ads g-comlin.ads \ - g-dirope.ads g-dyntab.ads g-os_lib.ads g-regexp.ads gnatfind.adb \ - gnatvsn.ads hostparm.ads interfac.ads i-cstrea.ads osint.ads system.ads \ - s-exctab.ads s-ficobl.ads s-finimp.ads s-finroo.ads s-parame.ads \ - s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-stratt.ads s-strops.ads s-unstyp.ads types.ads unchconv.ads \ - unchdeal.ads xr_tabls.ads xref_lib.ads - -gnatkr.o : ada.ads a-charac.ads a-chahan.ads a-comlin.ads a-except.ads \ - gnatkr.ads gnatkr.adb gnatvsn.ads krunch.ads system.ads s-exctab.ads \ - s-io.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads unchconv.ads - -gnatlink.o : ada.ads a-comlin.ads a-except.ads debug.ads gnat.ads \ - g-os_lib.ads gnatlink.ads gnatlink.adb gnatvsn.ads hostparm.ads \ - interfac.ads i-cstrea.ads opt.ads osint.ads output.ads system.ads \ - s-assert.ads s-exctab.ads s-parame.ads s-secsta.ads s-soflin.ads \ - s-stache.ads s-stalib.ads s-stoele.ads s-strops.ads s-sopco3.ads \ - s-sopco4.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ - unchconv.ads unchdeal.ads - -gnatls.o : ada.ads a-except.ads ali.ads ali-util.ads alloc.ads binderr.ads \ - butil.ads casing.ads csets.ads fname.ads gnat.ads g-htable.ads \ - g-os_lib.ads gnatls.ads gnatls.adb gnatvsn.ads hostparm.ads namet.ads \ - opt.ads osint.ads output.ads prj.ads prj-com.ads prj-env.ads \ - prj-env.adb prj-ext.ads prj-pars.ads prj-util.ads rident.ads scans.ads \ - snames.ads stringt.ads system.ads s-assert.ads s-exctab.ads \ + casing.ads csets.ads debug.ads gnat.ads g-htable.ads g-os_lib.ads \ + gnatbind.ads gnatbind.adb gnatvsn.ads hostparm.ads namet.ads opt.ads \ + osint.ads osint-b.ads output.ads rident.ads switch.ads switch-b.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-memory.ads \ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-strops.ads s-sopco3.ads s-sopco4.ads s-wchcon.ads table.ads types.ads \ - unchconv.ads unchdeal.ads - -gnatmake.o : gnat.ads g-os_lib.ads gnatmake.ads gnatmake.adb gnatvsn.ads \ - make.ads system.ads s-exctab.ads s-stalib.ads table.ads types.ads \ - unchconv.ads unchdeal.ads - -gnatmem.o : ada.ads a-comlin.ads a-except.ads a-finali.ads a-filico.ads \ - a-flteio.ads a-inteio.ads a-ioexce.ads a-stream.ads a-tags.ads \ - a-textio.ads a-tiocst.ads a-tiflio.ads a-tiinio.ads a-uncdea.ads \ - gnat.ads g-hesorg.ads g-hesorg.adb g-htable.ads g-htable.adb \ - g-os_lib.ads gnatmem.adb gnatvsn.ads interfac.ads i-cstrea.ads \ - memroot.ads system.ads s-exctab.ads s-ficobl.ads s-finimp.ads \ - s-finroo.ads s-imgint.ads s-parame.ads s-secsta.ads s-soflin.ads \ - s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads \ - s-sopco3.ads s-sopco4.ads s-sopco5.ads s-unstyp.ads s-valint.ads \ - s-valuns.ads unchconv.ads unchdeal.ads - -gnatprep.o : ada.ads a-charac.ads a-chahan.ads a-chlat1.ads a-comlin.ads \ - a-except.ads a-finali.ads a-filico.ads a-ioexce.ads a-stream.ads \ - a-string.ads a-strfix.ads a-strmap.ads a-tags.ads a-textio.ads gnat.ads \ - g-comlin.ads g-dirope.ads g-hesorg.ads g-hesorg.adb g-regexp.ads \ - gnatprep.ads gnatprep.adb gnatvsn.ads interfac.ads i-cstrea.ads \ - system.ads s-exctab.ads s-ficobl.ads s-finimp.ads s-finroo.ads \ - s-imgint.ads s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads s-sopco3.ads \ - s-sopco4.ads s-unstyp.ads unchconv.ads - -gnatpsta.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \ - a-stream.ads a-tags.ads a-textio.ads get_targ.ads gnatpsta.adb \ - gnatvsn.ads interfac.ads i-cstrea.ads system.ads s-exctab.ads \ - s-ficobl.ads s-finimp.ads s-finroo.ads s-imgint.ads s-imgrea.ads \ - s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-stratt.ads s-strops.ads s-sopco3.ads s-sopco4.ads \ - s-sopco5.ads s-unstyp.ads ttypef.ads ttypes.ads types.ads unchconv.ads \ - unchdeal.ads - -gnatpsys.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \ - a-stream.ads a-tags.ads a-textio.ads gnatpsys.adb gnatvsn.ads \ - interfac.ads i-cstrea.ads system.ads s-exctab.ads s-ficobl.ads \ - s-finimp.ads s-finroo.ads s-imgenu.ads s-imgint.ads s-imglli.ads \ - s-imgrea.ads s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads s-stratt.ads s-sopco3.ads s-sopco5.ads \ - s-unstyp.ads unchconv.ads + s-strops.ads s-wchcon.ads table.ads table.adb targparm.ads tree_io.ads \ + types.ads unchconv.ads unchdeal.ads gnatvsn.o : gnatvsn.ads system.ads -gnatxref.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-finali.ads \ - a-filico.ads a-ioexce.ads a-stream.ads a-string.ads a-strfix.ads \ - a-strmap.ads a-strunb.ads a-tags.ads a-textio.ads gnat.ads g-comlin.ads \ - g-dirope.ads g-dyntab.ads g-os_lib.ads g-regexp.ads gnatvsn.ads \ - gnatxref.adb hostparm.ads interfac.ads i-cstrea.ads osint.ads \ - system.ads s-exctab.ads s-ficobl.ads s-finimp.ads s-finroo.ads \ - s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-stratt.ads s-strops.ads s-unstyp.ads types.ads \ - unchconv.ads unchdeal.ads xr_tabls.ads xref_lib.ads - -g-os_lib.o : ada.ads a-except.ads gnat.ads g-os_lib.ads g-os_lib.adb \ - system.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads unchconv.ads unchdeal.ads - -g-regexp.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \ - a-stream.ads a-tags.ads a-tags.adb a-textio.ads gnat.ads g-casuti.ads \ - g-htable.ads g-regexp.ads g-regexp.adb interfac.ads i-cstrea.ads \ - system.ads s-exctab.ads s-ficobl.ads s-finimp.ads s-finroo.ads \ - s-imgint.ads s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads s-sopco3.ads \ - s-unstyp.ads unchconv.ads unchdeal.ads - -g-speche.o : gnat.ads g-speche.ads g-speche.adb system.ads - hlo.o : hlo.ads hlo.adb output.ads system.ads s-exctab.ads s-stalib.ads \ types.ads unchconv.ads unchdeal.ads hostparm.o : hostparm.ads system.ads -i-cstrea.o : interfac.ads i-cstrea.ads i-cstrea.adb system.ads \ - s-parame.ads unchconv.ads - -impunit.o : alloc.ads hostparm.ads impunit.ads impunit.adb lib.ads \ - namet.ads opt.ads system.ads s-exctab.ads s-stalib.ads s-wchcon.ads \ - table.ads types.ads unchconv.ads unchdeal.ads +impunit.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads fname.ads gnat.ads \ + g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads impunit.ads \ + impunit.adb lib.ads lib.adb lib-list.adb lib-sort.adb namet.ads \ + namet.adb nlists.ads nlists.adb opt.ads output.ads sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads stringt.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb tree_io.ads types.ads uintp.ads uintp.adb uname.ads \ + unchconv.ads unchdeal.ads urealp.ads widechar.ads -inline.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads debug.ads \ - einfo.ads elists.ads errout.ads exp_ch11.ads exp_ch7.ads exp_tss.ads \ - fname.ads fname-uf.ads gnat.ads g-os_lib.ads hostparm.ads inline.ads \ - inline.adb lib.ads namet.ads nlists.ads opt.ads output.ads sem_ch10.ads \ - sem_ch12.ads sem_ch8.ads sem_util.ads sinfo.ads snames.ads stand.ads \ - system.ads s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads \ - table.ads table.adb tree_io.ads types.ads uintp.ads uname.ads \ - unchconv.ads unchdeal.ads urealp.ads +inline.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads elists.adb errout.ads \ + exp_ch11.ads exp_ch7.ads exp_tss.ads exp_tss.adb exp_util.ads fname.ads \ + fname-uf.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \ + hostparm.ads inline.ads inline.adb lib.ads lib.adb lib-list.adb \ + lib-sort.adb namet.ads nlists.ads nlists.adb opt.ads output.ads \ + rtsfind.ads sem_ch10.ads sem_ch12.ads sem_ch8.ads sem_util.ads \ + sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads stringt.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ + uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads interfac.o : interfac.ads system.ads -itypes.o : alloc.ads atree.ads einfo.ads itypes.ads itypes.adb namet.ads \ - sem_util.ads sinfo.ads snames.ads stand.ads system.ads s-exctab.ads \ - s-stalib.ads table.ads types.ads uintp.ads unchconv.ads unchdeal.ads \ +itypes.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads gnat.ads g-htable.ads \ + g-os_lib.ads hostparm.ads itypes.ads itypes.adb namet.ads nlists.ads \ + nlists.adb opt.ads output.ads sem_util.ads sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tree_io.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads \ urealp.ads krunch.o : hostparm.ads krunch.ads krunch.adb system.ads s-stoele.ads layout.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ - checks.ads debug.ads einfo.ads elists.ads errout.ads exp_ch3.ads \ - exp_util.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads \ - hostparm.ads layout.ads layout.adb namet.ads nlists.ads nmake.ads \ - opt.ads output.ads repinfo.ads rtsfind.ads sem.ads sem_ch13.ads \ - sem_eval.ads sem_res.ads sem_util.ads sinfo.ads sinput.ads snames.ads \ - stand.ads system.ads s-assert.ads s-exctab.ads s-imgenu.ads \ + checks.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \ + exp_ch3.ads exp_util.ads freeze.ads get_targ.ads gnat.ads g-htable.ads \ + g-os_lib.ads hostparm.ads layout.ads layout.adb lib.ads lib-xref.ads \ + namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \ + output.ads repinfo.ads repinfo.adb restrict.ads rident.ads rtsfind.ads \ + scans.ads scn.ads sem.ads sem_ch13.ads sem_ch8.ads sem_eval.ads \ + sem_res.ads sem_type.ads sem_util.ads sem_util.adb sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads stringt.ads style.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads \ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-wchcon.ads table.ads targparm.ads tbuild.ads tree_io.ads ttypes.ads \ - types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -lib.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads debug.ads \ - einfo.ads fname.ads gnat.ads g-hesora.ads g-os_lib.ads hostparm.ads \ - lib.ads lib.adb lib-list.adb lib-sort.adb namet.ads opt.ads output.ads \ - sinfo.ads sinput.ads snames.ads stand.ads stringt.ads system.ads \ - s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb \ - tree_io.ads types.ads uintp.ads uname.ads unchconv.ads unchdeal.ads \ - urealp.ads + s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tbuild.adb \ + tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb uname.ads \ + unchconv.ads unchdeal.ads urealp.ads widechar.ads -lib-load.o : alloc.ads atree.ads casing.ads debug.ads einfo.ads errout.ads \ - fname.ads fname-uf.ads gnat.ads g-os_lib.ads hostparm.ads lib.ads \ - lib-load.ads lib-load.adb namet.ads nlists.ads nmake.ads opt.ads \ - osint.ads output.ads par.ads scn.ads sinfo.ads sinput.ads sinput-l.ads \ - snames.ads system.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads \ - tbuild.ads types.ads uintp.ads uname.ads unchconv.ads unchdeal.ads \ - urealp.ads +lib-load.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads elists.ads errout.ads fname.ads fname-uf.ads \ + gnat.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib-load.ads \ + lib-load.adb namet.ads nlists.ads nlists.adb nmake.ads nmake.adb \ + opt.ads osint.ads osint-c.ads output.ads par.ads scn.ads sinfo.ads \ + sinfo.adb sinput.ads sinput-l.ads snames.ads stand.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads \ + s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ + s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tree_io.ads \ + types.ads uintp.ads uname.ads unchconv.ads unchdeal.ads urealp.ads -lib-util.o : alloc.ads gnat.ads g-os_lib.ads hostparm.ads lib.ads \ - lib-util.ads lib-util.adb namet.ads osint.ads system.ads s-exctab.ads \ - s-stalib.ads s-stoele.ads table.ads types.ads unchconv.ads unchdeal.ads +lib-util.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads \ + g-os_lib.ads hostparm.ads lib.ads lib-util.ads lib-util.adb namet.ads \ + opt.ads osint.ads osint-c.ads output.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-memory.ads s-stalib.ads s-stoele.ads \ + s-wchcon.ads table.ads table.adb tree_io.ads types.ads unchconv.ads \ + unchdeal.ads -lib-writ.o : ali.ads alloc.ads atree.ads casing.ads einfo.ads errout.ads \ +lib-writ.o : ada.ads a-except.ads ali.ads alloc.ads atree.ads atree.adb \ + casing.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \ fname.ads fname-uf.ads gnat.ads g-htable.ads g-os_lib.ads gnatvsn.ads \ - hostparm.ads lib.ads lib-util.ads lib-writ.ads lib-writ.adb \ - lib-xref.ads namet.ads nlists.ads opt.ads osint.ads par.ads \ - restrict.ads rident.ads scn.ads sinfo.ads sinput.ads snames.ads \ - stringt.ads system.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads \ - targparm.ads types.ads uintp.ads uname.ads unchconv.ads unchdeal.ads \ - urealp.ads + hostparm.ads lib.ads lib-util.ads lib-util.adb lib-writ.ads \ + lib-writ.adb lib-xref.ads namet.ads nlists.ads nlists.adb opt.ads \ + osint.ads osint-c.ads output.ads par.ads restrict.ads rident.ads \ + scn.ads sinfo.ads sinfo.adb sinput.ads sinput.adb snames.ads stand.ads \ + stringt.ads stringt.adb system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tree_io.ads types.ads types.adb uintp.ads uintp.adb uname.ads \ + unchconv.ads unchdeal.ads urealp.ads -lib-xref.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads csets.ads \ - debug.ads einfo.ads gnat.ads g-hesora.ads g-os_lib.ads hostparm.ads \ - lib.ads lib-util.ads lib-xref.ads lib-xref.adb namet.ads opt.ads \ - output.ads sinfo.ads sinput.ads snames.ads system.ads s-assert.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads \ - types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads widechar.ads +lib-xref.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + csets.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads gnat.ads \ + g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads \ + lib-util.ads lib-util.adb lib-xref.ads lib-xref.adb namet.ads \ + nlists.ads nlists.adb opt.ads osint.ads osint-c.ads output.ads \ + sinfo.ads sinfo.adb sinput.ads sinput.adb snames.ads stand.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ + uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads widechar.ads + +lib.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads fname.ads gnat.ads \ + g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb \ + lib-list.adb lib-sort.adb namet.ads namet.adb nlists.ads nlists.adb \ + opt.ads output.ads sinfo.ads sinfo.adb sinput.ads sinput.adb snames.ads \ + stand.ads stringt.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads \ + urealp.ads widechar.ads live.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ - debug.ads einfo.ads elists.ads gnat.ads g-htable.ads g-os_lib.ads \ - lib.ads live.ads live.adb nlists.ads output.ads sem_util.ads sinfo.ads \ - sinput.ads snames.ads system.ads s-assert.ads s-exctab.ads s-imgenu.ads \ - s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-unstyp.ads table.ads tree_io.ads types.ads uintp.ads unchconv.ads \ - unchdeal.ads urealp.ads - -make.o : ada.ads a-charac.ads a-chahan.ads a-comlin.ads a-except.ads \ - ali.ads ali-util.ads alloc.ads casing.ads csets.ads debug.ads \ - errout.ads fname.ads fname-sf.ads fname-uf.ads gnat.ads g-htable.ads \ - g-os_lib.ads gnatvsn.ads hostparm.ads make.ads make.adb makeusg.ads \ - mlib.ads mlib-prj.ads mlib-tgt.ads mlib-utl.ads namet.ads opt.ads \ - osint.ads output.ads prj.ads prj.adb prj-attr.ads prj-com.ads \ - prj-env.ads prj-env.adb prj-ext.ads prj-pars.ads prj-util.ads \ - rident.ads scans.ads scn.ads sfn_scan.ads sinfo.ads sinfo-cn.ads \ - sinput.ads sinput-l.ads snames.ads stringt.ads switch.ads system.ads \ - s-assert.ads s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads s-strops.ads s-sopco3.ads s-sopco5.ads \ + debug.ads einfo.ads einfo.adb elists.ads fname.ads gnat.ads \ + g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb \ + lib-list.adb lib-sort.adb live.ads live.adb namet.ads nlists.ads \ + nlists.adb opt.ads output.ads sem_util.ads sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads stringt.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-unstyp.ads \ s-wchcon.ads table.ads table.adb tree_io.ads types.ads uintp.ads \ - unchconv.ads unchdeal.ads urealp.ads - -makeusg.o : gnat.ads g-os_lib.ads makeusg.ads makeusg.adb osint.ads \ - output.ads system.ads s-exctab.ads s-stalib.ads types.ads unchconv.ads \ - unchdeal.ads usage.ads - -memroot.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \ - a-stream.ads a-tags.ads a-textio.ads a-uncdea.ads gnat.ads g-htable.ads \ - g-htable.adb g-table.ads g-table.adb interfac.ads i-cstrea.ads \ - memroot.ads memroot.adb system.ads s-assert.ads s-exctab.ads \ - s-ficobl.ads s-finimp.ads s-finroo.ads s-parame.ads s-secsta.ads \ - s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads \ - s-sopco5.ads s-unstyp.ads unchconv.ads + uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads memtrack.o : ada.ads a-except.ads system.ads s-memory.ads memtrack.adb \ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-traceb.ads \ unchconv.ads -mlib.o : ada.ads a-charac.ads a-chahan.ads a-except.ads gnat.ads \ - g-os_lib.ads hostparm.ads mlib.ads mlib.adb mlib-utl.ads opt.ads \ - osint.ads output.ads system.ads s-exctab.ads s-secsta.ads s-soflin.ads \ - s-stache.ads s-stalib.ads s-stoele.ads s-sopco4.ads s-wchcon.ads \ - types.ads unchconv.ads unchdeal.ads - -mlib-fil.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-string.ads \ - a-strfix.ads a-strmap.ads gnat.ads g-os_lib.ads mlib.ads mlib-fil.ads \ - mlib-fil.adb mlib-tgt.ads system.ads s-exctab.ads s-secsta.ads \ - s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-sopco3.ads \ - s-unstyp.ads types.ads unchconv.ads unchdeal.ads - -mlib-prj.o : ada.ads a-charac.ads a-chahan.ads a-except.ads a-finali.ads \ - a-filico.ads a-stream.ads a-tags.ads alloc.ads casing.ads debug.ads \ - gnat.ads g-dirope.ads g-os_lib.ads hostparm.ads mlib.ads mlib-fil.ads \ - mlib-prj.ads mlib-prj.adb mlib-tgt.ads namet.ads opt.ads osint.ads \ - output.ads prj.ads scans.ads system.ads s-assert.ads s-exctab.ads \ - s-finimp.ads s-finroo.ads s-imgenu.ads s-secsta.ads s-soflin.ads \ - s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads \ - s-sopco3.ads s-unstyp.ads s-wchcon.ads table.ads table.adb tree_io.ads \ - types.ads unchconv.ads unchdeal.ads - -mlib-tgt.o : ada.ads a-charac.ads a-chahan.ads a-except.ads a-finali.ads \ - a-filico.ads a-stream.ads a-tags.ads alloc.ads gnat.ads g-dirope.ads \ - g-os_lib.ads hostparm.ads mlib.ads mlib-fil.ads mlib-tgt.ads \ - mlib-tgt.adb mlib-utl.ads namet.ads opt.ads osint.ads output.ads \ - system.ads s-exctab.ads s-finimp.ads s-finroo.ads s-secsta.ads \ - s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads \ - s-strops.ads s-sopco3.ads s-sopco4.ads s-unstyp.ads s-wchcon.ads \ - table.ads types.ads unchconv.ads unchdeal.ads - -mlib-utl.o : ada.ads a-except.ads alloc.ads gnat.ads g-os_lib.ads \ - hostparm.ads mlib.ads mlib-fil.ads mlib-tgt.ads mlib-utl.ads \ - mlib-utl.adb namet.ads opt.ads osint.ads output.ads system.ads \ - s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-strops.ads s-wchcon.ads table.ads types.ads unchconv.ads \ - unchdeal.ads - namet.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \ hostparm.ads namet.ads namet.adb opt.ads output.ads system.ads \ - s-assert.ads s-exctab.ads s-secsta.ads s-stalib.ads s-stoele.ads \ - s-wchcon.ads table.ads table.adb tree_io.ads types.ads unchconv.ads \ - unchdeal.ads widechar.ads + s-atacco.ads s-atacco.adb s-exctab.ads s-memory.ads s-secsta.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads types.adb unchconv.ads unchdeal.ads widechar.ads -nlists.o : ada.ads a-except.ads alloc.ads atree.ads debug.ads einfo.ads \ - gnat.ads g-os_lib.ads hostparm.ads nlists.ads nlists.adb opt.ads \ - output.ads sinfo.ads snames.ads system.ads s-assert.ads s-exctab.ads \ - s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads +nlists.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads elists.ads gnat.ads g-htable.ads g-os_lib.ads \ + hostparm.ads nlists.ads nlists.adb opt.ads output.ads sinfo.ads \ + sinput.ads snames.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads -nmake.o : alloc.ads atree.ads einfo.ads namet.ads nlists.ads nmake.ads \ - nmake.adb sinfo.ads snames.ads stand.ads system.ads s-exctab.ads \ - s-stalib.ads table.ads types.ads uintp.ads unchconv.ads unchdeal.ads \ - urealp.ads +nmake.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads elists.ads gnat.ads g-htable.ads g-os_lib.ads \ + hostparm.ads namet.ads nlists.ads nlists.adb nmake.ads nmake.adb \ + opt.ads output.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ + uintp.ads unchconv.ads unchdeal.ads urealp.ads opt.o : ada.ads a-except.ads gnat.ads g-os_lib.ads gnatvsn.ads \ hostparm.ads opt.ads opt.adb system.ads s-exctab.ads s-stalib.ads \ s-wchcon.ads tree_io.ads types.ads unchconv.ads unchdeal.ads +osint-b.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \ + hostparm.ads namet.ads opt.ads osint.ads osint-b.ads osint-b.adb \ + output.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-memory.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tree_io.ads types.ads unchconv.ads unchdeal.ads + +osint-c.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \ + hostparm.ads namet.ads opt.ads osint.ads osint-c.ads osint-c.adb \ + output.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-memory.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tree_io.ads types.ads unchconv.ads unchdeal.ads + osint.o : ada.ads a-except.ads a-uncdea.ads alloc.ads debug.ads fmap.ads \ gnat.ads g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads namet.ads \ opt.ads osint.ads osint.adb output.ads sdefault.ads system.ads \ - s-assert.ads s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ - types.ads unchconv.ads unchdeal.ads + s-atacco.ads s-atacco.adb s-exctab.ads s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads output.o : gnat.ads g-os_lib.ads output.ads output.adb system.ads \ s-exctab.ads s-stalib.ads types.ads unchconv.ads unchdeal.ads -par.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads csets.ads \ - debug.ads einfo.ads elists.ads errout.ads fname.ads fname-uf.ads \ - gnat.ads g-os_lib.ads g-speche.ads hostparm.ads lib.ads lib-load.ads \ - namet.ads nlists.ads nmake.ads opt.ads osint.ads output.ads par.ads \ +par.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + csets.ads debug.ads einfo.ads einfo.adb elists.ads elists.adb \ + errout.ads fname.ads fname-uf.ads gnat.ads g-hesora.ads g-htable.ads \ + g-os_lib.ads g-speche.ads hostparm.ads interfac.ads lib.ads lib.adb \ + lib-list.adb lib-load.ads lib-sort.adb namet.ads namet.adb nlists.ads \ + nlists.adb nmake.ads nmake.adb opt.ads osint.ads output.ads par.ads \ par.adb par-ch10.adb par-ch11.adb par-ch12.adb par-ch13.adb par-ch2.adb \ par-ch3.adb par-ch4.adb par-ch5.adb par-ch6.adb par-ch7.adb par-ch8.adb \ par-ch9.adb par-endh.adb par-labl.adb par-load.adb par-prag.adb \ - par-sync.adb par-tchk.adb par-util.adb scans.ads scn.ads sinfo.ads \ - sinfo-cn.ads sinput.ads sinput-l.ads snames.ads stringt.ads style.ads \ - stylesw.ads system.ads s-assert.ads s-exctab.ads s-imgenu.ads \ + par-sync.adb par-tchk.adb par-util.adb scans.ads scans.adb scn.ads \ + scn.adb scn-nlit.adb scn-slit.adb sinfo.ads sinfo.adb sinfo-cn.ads \ + sinput.ads sinput.adb sinput-l.ads snames.ads snames.adb stand.ads \ + stringt.ads stringt.adb style.ads style.adb stylesw.ads system.ads \ + s-atacco.ads s-atacco.adb s-crc32.ads s-crc32.adb s-exctab.ads \ + s-exctab.adb s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tree_io.ads types.ads types.adb uintp.ads uintp.adb uname.ads \ + unchconv.ads unchdeal.ads urealp.ads validsw.ads widechar.ads + +repinfo.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads fname.ads gnat.ads \ + g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb \ + lib-list.adb lib-sort.adb namet.ads nlists.ads nlists.adb opt.ads \ + output.ads output.adb repinfo.ads repinfo.adb sinfo.ads sinfo.adb \ + sinput.ads sinput.adb snames.ads stand.ads stringt.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads \ s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ s-wchcon.ads table.ads table.adb tree_io.ads types.ads uintp.ads \ - uname.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads - -prj.o : ada.ads a-charac.ads a-chahan.ads a-except.ads alloc.ads \ - casing.ads debug.ads errout.ads gnat.ads g-htable.ads g-os_lib.ads \ - hostparm.ads namet.ads opt.ads output.ads prj.ads prj.adb prj-attr.ads \ - prj-com.ads prj-env.ads scans.ads scn.ads sinfo.ads sinfo-cn.ads \ - snames.ads stringt.ads system.ads s-assert.ads s-exctab.ads \ - s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-sopco3.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads - -prj-attr.o : ada.ads a-charac.ads a-chahan.ads a-except.ads alloc.ads \ - casing.ads debug.ads gnat.ads g-os_lib.ads hostparm.ads namet.ads \ - opt.ads output.ads prj.ads prj-attr.ads prj-attr.adb scans.ads \ - system.ads s-assert.ads s-exctab.ads s-secsta.ads s-soflin.ads \ - s-stache.ads s-stalib.ads s-stoele.ads s-sopco3.ads s-wchcon.ads \ - table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads - -prj-com.o : ada.ads a-except.ads a-uncdea.ads alloc.ads casing.ads \ - debug.ads gnat.ads g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads \ - namet.ads opt.ads output.ads prj.ads prj-com.ads prj-com.adb scans.ads \ - stringt.ads system.ads s-assert.ads s-exctab.ads s-secsta.ads \ + uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads + +restrict.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads errout.ads exp_util.ads \ + fname.ads fname-uf.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \ + hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb namet.ads \ + nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \ + restrict.ads restrict.adb rident.ads rtsfind.ads sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads stringt.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads \ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ - table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads - -prj-dect.o : alloc.ads casing.ads errout.ads gnat.ads g-htable.ads \ - g-os_lib.ads prj.ads prj-attr.ads prj-com.ads prj-dect.ads prj-dect.adb \ - prj-strt.ads prj-tree.ads scans.ads sinfo.ads system.ads s-exctab.ads \ - s-stalib.ads table.ads types.ads uintp.ads unchconv.ads unchdeal.ads \ + table.ads table.adb targparm.ads tbuild.ads tbuild.adb tree_io.ads \ + types.ads uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads \ urealp.ads -prj-env.o : ada.ads a-except.ads alloc.ads casing.ads debug.ads gnat.ads \ - g-htable.ads g-os_lib.ads hostparm.ads namet.ads opt.ads osint.ads \ - output.ads prj.ads prj-com.ads prj-env.ads prj-env.adb prj-util.ads \ - scans.ads snames.ads stringt.ads system.ads s-assert.ads s-exctab.ads \ - s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-strops.ads s-sopco3.ads s-wchcon.ads table.ads table.adb tree_io.ads \ - types.ads unchconv.ads unchdeal.ads - -prj-ext.o : ada.ads a-except.ads a-uncdea.ads alloc.ads casing.ads \ - gnat.ads g-htable.ads g-htable.adb g-os_lib.ads namet.ads prj.ads \ - prj-com.ads prj-ext.ads prj-ext.adb scans.ads stringt.ads system.ads \ - s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads table.ads types.ads unchconv.ads unchdeal.ads - -prj-nmsc.o : ada.ads a-charac.ads a-chahan.ads a-chlat1.ads a-except.ads \ - a-finali.ads a-filico.ads a-stream.ads a-string.ads a-strfix.ads \ - a-strmap.ads a-stmaco.ads a-tags.ads alloc.ads casing.ads errout.ads \ - gnat.ads g-casuti.ads g-dirope.ads g-htable.ads g-os_lib.ads namet.ads \ - osint.ads output.ads prj.ads prj-com.ads prj-nmsc.ads prj-nmsc.adb \ - prj-util.ads scans.ads snames.ads stringt.ads system.ads s-assert.ads \ - s-exctab.ads s-finimp.ads s-finroo.ads s-secsta.ads s-soflin.ads \ - s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads \ - s-sopco3.ads s-sopco5.ads s-unstyp.ads table.ads types.ads uintp.ads \ - unchconv.ads unchdeal.ads - -prj-pars.o : ada.ads a-except.ads alloc.ads casing.ads errout.ads gnat.ads \ - g-htable.ads g-os_lib.ads output.ads prj.ads prj-attr.ads prj-com.ads \ - prj-pars.ads prj-pars.adb prj-part.ads prj-proc.ads prj-tree.ads \ - scans.ads system.ads s-exctab.ads s-secsta.ads s-soflin.ads \ - s-stache.ads s-stalib.ads s-stoele.ads table.ads types.ads uintp.ads \ - unchconv.ads unchdeal.ads - -prj-part.o : ada.ads a-charac.ads a-chahan.ads a-except.ads a-finali.ads \ - a-filico.ads a-stream.ads a-tags.ads alloc.ads casing.ads debug.ads \ - errout.ads gnat.ads g-dirope.ads g-htable.ads g-os_lib.ads hostparm.ads \ - namet.ads opt.ads osint.ads output.ads prj.ads prj-attr.ads prj-com.ads \ - prj-dect.ads prj-part.ads prj-part.adb prj-tree.ads scans.ads scn.ads \ - sinfo.ads sinput.ads sinput-p.ads stringt.ads system.ads s-assert.ads \ - s-exctab.ads s-finimp.ads s-finroo.ads s-secsta.ads s-soflin.ads \ - s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads \ - s-sopco3.ads s-unstyp.ads s-wchcon.ads table.ads table.adb tree_io.ads \ - types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -prj-proc.o : ada.ads a-except.ads a-uncdea.ads alloc.ads casing.ads \ - errout.ads gnat.ads g-casuti.ads g-htable.ads g-htable.adb g-os_lib.ads \ - hostparm.ads namet.ads opt.ads output.ads prj.ads prj-attr.ads \ - prj-com.ads prj-ext.ads prj-nmsc.ads prj-proc.ads prj-proc.adb \ - prj-tree.ads scans.ads stringt.ads system.ads s-assert.ads s-exctab.ads \ - s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-strops.ads s-sopco3.ads s-sopco5.ads s-wchcon.ads \ - table.ads types.ads uintp.ads unchconv.ads unchdeal.ads - -prj-strt.o : ada.ads a-except.ads alloc.ads casing.ads debug.ads \ - errout.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads opt.ads \ - output.ads prj.ads prj-attr.ads prj-com.ads prj-strt.ads prj-strt.adb \ - prj-tree.ads scans.ads sinfo.ads stringt.ads system.ads s-assert.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads \ - types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -prj-tree.o : ada.ads a-except.ads a-uncdea.ads casing.ads debug.ads \ - gnat.ads g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads opt.ads \ - output.ads prj.ads prj-attr.ads prj-com.ads prj-tree.ads prj-tree.adb \ - scans.ads stringt.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \ - s-wchcon.ads table.ads table.adb tree_io.ads types.ads unchconv.ads \ - unchdeal.ads - -prj-util.o : ada.ads a-uncdea.ads alloc.ads casing.ads gnat.ads \ - g-os_lib.ads namet.ads osint.ads output.ads prj.ads prj-util.ads \ - prj-util.adb scans.ads stringt.ads system.ads s-exctab.ads s-secsta.ads \ - s-stalib.ads s-stoele.ads table.ads types.ads unchconv.ads unchdeal.ads - -repinfo.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads debug.ads \ - einfo.ads gnat.ads g-os_lib.ads hostparm.ads lib.ads namet.ads opt.ads \ - output.ads repinfo.ads repinfo.adb sinfo.ads sinput.ads snames.ads \ - system.ads s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads \ - table.ads table.adb tree_io.ads types.ads uintp.ads uname.ads \ - unchconv.ads unchdeal.ads urealp.ads - -restrict.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads einfo.ads \ - errout.ads exp_util.ads fname.ads fname-uf.ads hostparm.ads lib.ads \ - namet.ads nlists.ads nmake.ads opt.ads restrict.ads restrict.adb \ - rident.ads rtsfind.ads sinfo.ads snames.ads stand.ads system.ads \ - s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads s-wchcon.ads table.ads targparm.ads types.ads \ - uintp.ads uname.ads unchconv.ads unchdeal.ads urealp.ads - rident.o : rident.ads system.ads -rtsfind.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads csets.ads \ - debug.ads einfo.ads elists.ads fname.ads fname-uf.ads hostparm.ads \ - lib.ads lib-load.ads namet.ads nlists.ads nmake.ads opt.ads output.ads \ - restrict.ads rident.ads rtsfind.ads rtsfind.adb sem.ads sem_ch7.ads \ - sem_util.ads sinfo.ads snames.ads stand.ads system.ads s-assert.ads \ - s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads s-wchcon.ads table.ads tbuild.ads types.ads \ - uintp.ads uname.ads unchconv.ads unchdeal.ads urealp.ads - -s-arit64.o : gnat.ads g-except.ads interfac.ads system.ads s-arit64.ads \ - s-arit64.adb unchconv.ads - -s-assert.o : ada.ads a-except.ads system.ads s-assert.ads s-assert.adb \ - s-exctab.ads s-stalib.ads unchconv.ads - -s-bitops.o : gnat.ads g-except.ads system.ads s-bitops.ads s-bitops.adb \ - s-unstyp.ads unchconv.ads - -scans.o : scans.ads scans.adb system.ads s-exctab.ads s-stalib.ads \ - types.ads unchconv.ads unchdeal.ads - -scn.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads csets.ads \ - einfo.ads errout.ads hostparm.ads interfac.ads namet.ads opt.ads \ - scans.ads scn.ads scn.adb scn-nlit.adb scn-slit.adb sinfo.ads \ - sinput.ads snames.ads stringt.ads style.ads system.ads s-crc32.ads \ - s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads s-wchcon.ads table.ads types.ads uintp.ads \ - unchconv.ads unchdeal.ads urealp.ads widechar.ads - -s-crc32.o : interfac.ads system.ads s-crc32.ads s-crc32.adb - -sem_aggr.o : alloc.ads atree.ads checks.ads einfo.ads elists.ads \ - errout.ads exp_util.ads freeze.ads gnat.ads g-speche.ads hostparm.ads \ - itypes.ads namet.ads nlists.ads nmake.ads opt.ads rtsfind.ads sem.ads \ - sem_aggr.ads sem_aggr.adb sem_cat.ads sem_ch13.ads sem_ch8.ads \ - sem_eval.ads sem_res.ads sem_type.ads sem_util.ads sinfo.ads snames.ads \ - stand.ads stringt.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \ - s-wchcon.ads table.ads tbuild.ads types.ads uintp.ads unchconv.ads \ - unchdeal.ads urealp.ads - -sem.o : ada.ads a-except.ads alloc.ads atree.ads debug.ads debug_a.ads \ - einfo.ads errout.ads expander.ads fname.ads gnat.ads g-os_lib.ads \ - hlo.ads hostparm.ads inline.ads lib.ads lib-load.ads namet.ads \ - nlists.ads opt.ads output.ads sem.ads sem.adb sem_attr.ads sem_ch10.ads \ - sem_ch11.ads sem_ch12.ads sem_ch13.ads sem_ch2.ads sem_ch3.ads \ - sem_ch4.ads sem_ch5.ads sem_ch6.ads sem_ch7.ads sem_ch8.ads sem_ch9.ads \ - sem_prag.ads sem_util.ads sinfo.ads snames.ads stand.ads system.ads \ - s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb \ - tree_io.ads types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -sem_attr.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads alloc.ads \ - atree.ads casing.ads checks.ads einfo.ads errout.ads eval_fat.ads \ - exp_tss.ads exp_util.ads expander.ads freeze.ads get_targ.ads \ - hostparm.ads lib.ads lib-xref.ads namet.ads nlists.ads nmake.ads \ - opt.ads restrict.ads rident.ads rtsfind.ads sem.ads sem_attr.ads \ - sem_attr.adb sem_cat.ads sem_ch13.ads sem_ch6.ads sem_ch8.ads \ - sem_dist.ads sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \ - sinfo.ads sinput.ads snames.ads stand.ads stringt.ads system.ads \ - s-assert.ads s-exctab.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-wchcon.ads table.ads targparm.ads tbuild.ads ttypef.ads \ - ttypes.ads types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads \ - widechar.ads - -sem_case.o : alloc.ads atree.ads einfo.ads errout.ads gnat.ads \ - g-hesora.ads hostparm.ads namet.ads nlists.ads opt.ads sem.ads \ - sem_case.ads sem_case.adb sem_eval.ads sem_res.ads sem_type.ads \ - sem_util.ads sinfo.ads snames.ads stand.ads system.ads s-assert.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads types.ads uintp.ads \ - unchconv.ads unchdeal.ads urealp.ads - -sem_cat.o : alloc.ads atree.ads debug.ads einfo.ads elists.ads errout.ads \ - exp_tss.ads fname.ads hostparm.ads lib.ads namet.ads nlists.ads opt.ads \ - sem.ads sem_cat.ads sem_cat.adb sem_util.ads sinfo.ads snames.ads \ - stand.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \ - s-wchcon.ads table.ads types.ads uintp.ads unchconv.ads unchdeal.ads \ - urealp.ads - -sem_ch10.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads debug.ads \ - einfo.ads errout.ads exp_util.ads fname.ads fname-uf.ads freeze.ads \ - get_targ.ads hostparm.ads impunit.ads inline.ads lib.ads lib-load.ads \ - lib-xref.ads namet.ads nlists.ads nmake.ads opt.ads output.ads \ - restrict.ads rident.ads rtsfind.ads sem.ads sem_ch10.ads sem_ch10.adb \ - sem_ch6.ads sem_ch7.ads sem_ch8.ads sem_dist.ads sem_prag.ads \ - sem_util.ads sem_warn.ads sinfo.ads sinfo-cn.ads sinput.ads snames.ads \ - stand.ads style.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \ - s-wchcon.ads table.ads tbuild.ads ttypes.ads types.ads uintp.ads \ - uname.ads unchconv.ads unchdeal.ads urealp.ads - -sem_ch11.o : alloc.ads atree.ads einfo.ads errout.ads hostparm.ads lib.ads \ - lib-xref.ads namet.ads nlists.ads nmake.ads opt.ads restrict.ads \ - rident.ads rtsfind.ads sem.ads sem_ch11.ads sem_ch11.adb sem_ch5.ads \ - sem_ch8.ads sem_res.ads sem_util.ads sinfo.ads snames.ads stand.ads \ - system.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads - -sem_ch12.o : ada.ads a-except.ads a-uncdea.ads alloc.ads atree.ads \ - casing.ads debug.ads einfo.ads elists.ads errout.ads expander.ads \ - fname.ads fname-uf.ads freeze.ads gnat.ads g-htable.ads g-htable.adb \ - g-os_lib.ads hostparm.ads inline.ads lib.ads lib-load.ads lib-xref.ads \ - namet.ads nlists.ads nmake.ads opt.ads output.ads restrict.ads \ - rident.ads rtsfind.ads sem.ads sem_cat.ads sem_ch10.ads sem_ch12.ads \ - sem_ch12.adb sem_ch13.ads sem_ch3.ads sem_ch6.ads sem_ch7.ads \ - sem_ch8.ads sem_elab.ads sem_elim.ads sem_eval.ads sem_res.ads \ - sem_type.ads sem_util.ads sinfo.ads sinfo-cn.ads sinput.ads \ - sinput-l.ads snames.ads stand.ads stringt.ads system.ads s-assert.ads \ - s-exctab.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-wchcon.ads table.ads table.adb tbuild.ads tree_io.ads types.ads \ - uintp.ads uname.ads unchconv.ads unchdeal.ads urealp.ads - -sem_ch13.o : ada.ads a-except.ads alloc.ads atree.ads debug.ads einfo.ads \ - errout.ads exp_tss.ads exp_util.ads get_targ.ads gnat.ads g-hesora.ads \ - g-os_lib.ads hostparm.ads lib.ads namet.ads nlists.ads nmake.ads \ - opt.ads output.ads rtsfind.ads sem.ads sem_ch13.ads sem_ch13.adb \ - sem_ch8.ads sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \ - sinfo.ads snames.ads stand.ads system.ads s-assert.ads s-exctab.ads \ - s-stalib.ads s-wchcon.ads table.ads table.adb tbuild.ads tree_io.ads \ - ttypes.ads types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -sem_ch2.o : alloc.ads atree.ads einfo.ads hostparm.ads namet.ads opt.ads \ - restrict.ads rident.ads sem_ch2.ads sem_ch2.adb sem_ch8.ads sinfo.ads \ - snames.ads stand.ads system.ads s-exctab.ads s-stalib.ads s-wchcon.ads \ - table.ads types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -sem_ch3.o : alloc.ads atree.ads checks.ads einfo.ads elists.ads errout.ads \ - eval_fat.ads exp_ch3.ads exp_dist.ads exp_util.ads freeze.ads \ - get_targ.ads gnat.ads g-hesora.ads hostparm.ads itypes.ads layout.ads \ - lib.ads lib-xref.ads namet.ads nlists.ads nmake.ads opt.ads \ - restrict.ads rident.ads rtsfind.ads sem.ads sem_case.ads sem_case.adb \ - sem_cat.ads sem_ch13.ads sem_ch3.ads sem_ch3.adb sem_ch6.ads \ - sem_ch7.ads sem_ch8.ads sem_disp.ads sem_dist.ads sem_elim.ads \ - sem_eval.ads sem_mech.ads sem_res.ads sem_smem.ads sem_type.ads \ - sem_util.ads sinfo.ads snames.ads stand.ads system.ads s-assert.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads tbuild.ads ttypes.ads \ - types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -sem_ch4.o : alloc.ads atree.ads debug.ads einfo.ads errout.ads \ - exp_util.ads gnat.ads g-speche.ads hostparm.ads itypes.ads lib.ads \ - lib-xref.ads namet.ads nlists.ads nmake.ads opt.ads output.ads \ - restrict.ads rident.ads rtsfind.ads sem.ads sem_cat.ads sem_ch3.ads \ - sem_ch4.ads sem_ch4.adb sem_ch8.ads sem_dist.ads sem_eval.ads \ - sem_res.ads sem_type.ads sem_util.ads sinfo.ads snames.ads stand.ads \ - system.ads s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads \ - table.ads tbuild.ads types.ads uintp.ads unchconv.ads unchdeal.ads \ - urealp.ads - -sem_ch5.o : alloc.ads atree.ads checks.ads einfo.ads errout.ads \ - exp_util.ads expander.ads freeze.ads gnat.ads g-hesora.ads hostparm.ads \ - lib.ads lib-xref.ads namet.ads nlists.ads opt.ads rtsfind.ads sem.ads \ - sem_case.ads sem_case.adb sem_ch3.ads sem_ch5.ads sem_ch5.adb \ - sem_ch8.ads sem_disp.ads sem_eval.ads sem_res.ads sem_type.ads \ - sem_util.ads sem_warn.ads sinfo.ads snames.ads stand.ads system.ads \ - s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads \ - tbuild.ads types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -sem_ch6.o : alloc.ads atree.ads casing.ads checks.ads debug.ads einfo.ads \ - elists.ads errout.ads exp_ch7.ads expander.ads fname.ads freeze.ads \ - hostparm.ads inline.ads lib.ads lib-xref.ads namet.ads nlists.ads \ - nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_cat.ads \ - sem_ch12.ads sem_ch3.ads sem_ch4.ads sem_ch5.ads sem_ch6.ads \ - sem_ch6.adb sem_ch8.ads sem_disp.ads sem_dist.ads sem_elim.ads \ - sem_eval.ads sem_mech.ads sem_prag.ads sem_res.ads sem_type.ads \ - sem_util.ads sem_warn.ads sinfo.ads sinfo-cn.ads sinput.ads snames.ads \ - stand.ads stringt.ads style.ads stylesw.ads system.ads s-assert.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads tbuild.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads - -sem_ch7.o : alloc.ads atree.ads casing.ads debug.ads einfo.ads elists.ads \ - errout.ads exp_dbug.ads exp_disp.ads get_targ.ads hostparm.ads \ - inline.ads lib.ads lib-xref.ads namet.ads nlists.ads nmake.ads opt.ads \ - output.ads sem.ads sem_cat.ads sem_ch12.ads sem_ch3.ads sem_ch6.ads \ - sem_ch7.ads sem_ch7.adb sem_ch8.ads sem_util.ads sem_warn.ads sinfo.ads \ - sinput.ads snames.ads stand.ads style.ads system.ads s-assert.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads types.ads uintp.ads \ - unchconv.ads unchdeal.ads urealp.ads - -sem_ch8.o : ada.ads a-except.ads alloc.ads atree.ads debug.ads einfo.ads \ - elists.ads errout.ads exp_util.ads fname.ads freeze.ads gnat.ads \ - g-os_lib.ads g-speche.ads hostparm.ads inline.ads lib.ads lib-load.ads \ - lib-xref.ads namet.ads nlists.ads nmake.ads opt.ads output.ads \ - restrict.ads rident.ads rtsfind.ads sem.ads sem_ch12.ads sem_ch3.ads \ - sem_ch4.ads sem_ch6.ads sem_ch8.ads sem_ch8.adb sem_res.ads \ - sem_type.ads sem_util.ads sinfo.ads sinfo-cn.ads snames.ads stand.ads \ - style.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \ - s-wchcon.ads table.ads table.adb tbuild.ads tree_io.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads - -sem_ch9.o : alloc.ads atree.ads checks.ads einfo.ads elists.ads errout.ads \ - exp_ch9.ads hostparm.ads itypes.ads lib.ads lib-xref.ads namet.ads \ - nlists.ads nmake.ads opt.ads restrict.ads rident.ads rtsfind.ads \ - sem.ads sem_ch3.ads sem_ch5.ads sem_ch6.ads sem_ch8.ads sem_ch9.ads \ - sem_ch9.adb sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \ - sem_warn.ads sinfo.ads snames.ads stand.ads style.ads system.ads \ - s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads \ - tbuild.ads types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -sem_disp.o : alloc.ads atree.ads debug.ads einfo.ads elists.ads errout.ads \ - exp_disp.ads hostparm.ads nlists.ads output.ads sem_ch6.ads \ - sem_disp.ads sem_disp.adb sem_eval.ads sem_util.ads sinfo.ads \ - snames.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads table.ads \ - types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -sem_dist.o : alloc.ads atree.ads casing.ads einfo.ads errout.ads \ - exp_dist.ads exp_tss.ads hostparm.ads namet.ads nlists.ads nmake.ads \ - opt.ads rtsfind.ads sem.ads sem_dist.ads sem_dist.adb sem_res.ads \ - sem_util.ads sinfo.ads snames.ads stand.ads stringt.ads system.ads \ - s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads \ - tbuild.ads types.ads uintp.ads uname.ads unchconv.ads unchdeal.ads \ - urealp.ads - -sem_elab.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ - checks.ads debug.ads einfo.ads elists.ads errout.ads exp_util.ads \ - expander.ads fname.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads \ - lib.ads lib-load.ads namet.ads nlists.ads nmake.ads opt.ads output.ads \ - restrict.ads rident.ads rtsfind.ads sem.ads sem_cat.ads sem_ch7.ads \ - sem_ch8.ads sem_elab.ads sem_elab.adb sem_res.ads sem_util.ads \ - sinfo.ads sinput.ads snames.ads stand.ads system.ads s-assert.ads \ - s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads \ +rtsfind.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + csets.ads debug.ads einfo.ads einfo.adb elists.ads elists.adb fname.ads \ + fname-uf.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \ + hostparm.ads lib.ads lib.adb lib-list.adb lib-load.ads lib-sort.adb \ + namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \ + output.ads restrict.ads rident.ads rtsfind.ads rtsfind.adb sem.ads \ + sem_ch7.ads sem_util.ads sinfo.ads sinfo.adb sinput.ads snames.ads \ + stand.ads stringt.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tbuild.ads \ - tree_io.ads types.ads uintp.ads uname.ads unchconv.ads unchdeal.ads \ - urealp.ads - -sem_elim.o : ada.ads a-uncdea.ads alloc.ads atree.ads einfo.ads errout.ads \ - gnat.ads g-htable.ads g-htable.adb namet.ads nlists.ads sem_elim.ads \ - sem_elim.adb sinfo.ads snames.ads stand.ads stringt.ads system.ads \ - s-exctab.ads s-stalib.ads table.ads types.ads uintp.ads unchconv.ads \ - unchdeal.ads urealp.ads - -sem_eval.o : ada.ads a-except.ads alloc.ads atree.ads checks.ads debug.ads \ - einfo.ads elists.ads errout.ads eval_fat.ads hostparm.ads namet.ads \ - nlists.ads nmake.ads opt.ads sem.ads sem_cat.ads sem_ch8.ads \ - sem_eval.ads sem_eval.adb sem_res.ads sem_type.ads sem_util.ads \ - sem_warn.ads sinfo.ads snames.ads stand.ads stringt.ads system.ads \ - s-assert.ads s-exctab.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-wchcon.ads table.ads types.ads uintp.ads unchconv.ads \ - unchdeal.ads urealp.ads - -sem_intr.o : alloc.ads atree.ads einfo.ads errout.ads fname.ads lib.ads \ - namet.ads sem_eval.ads sem_intr.ads sem_intr.adb sem_util.ads sinfo.ads \ - snames.ads stand.ads stringt.ads system.ads s-exctab.ads s-stalib.ads \ - table.ads targparm.ads types.ads uintp.ads unchconv.ads unchdeal.ads \ - urealp.ads - -sem_maps.o : ada.ads a-except.ads alloc.ads atree.ads debug.ads einfo.ads \ - gnat.ads g-os_lib.ads hostparm.ads namet.ads opt.ads output.ads \ - sem_maps.ads sem_maps.adb sinfo.ads snames.ads system.ads s-assert.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads \ - types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -sem_mech.o : alloc.ads atree.ads einfo.ads errout.ads hostparm.ads \ - namet.ads nlists.ads opt.ads sem.ads sem_mech.ads sem_mech.adb \ - sem_util.ads sinfo.ads snames.ads stand.ads system.ads s-exctab.ads \ - s-stalib.ads s-wchcon.ads table.ads targparm.ads types.ads uintp.ads \ - unchconv.ads unchdeal.ads urealp.ads - -sem_prag.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads csets.ads \ - debug.ads einfo.ads elists.ads errout.ads exp_dist.ads expander.ads \ - fname.ads get_targ.ads hostparm.ads lib.ads namet.ads nlists.ads \ - nmake.ads opt.ads output.ads restrict.ads rident.ads rtsfind.ads \ - sem.ads sem_ch13.ads sem_ch8.ads sem_disp.ads sem_elim.ads sem_eval.ads \ - sem_intr.ads sem_mech.ads sem_prag.ads sem_prag.adb sem_res.ads \ - sem_type.ads sem_util.ads sem_vfpt.ads sinfo.ads sinfo-cn.ads \ - sinput.ads snames.ads stand.ads stringt.ads stylesw.ads system.ads \ - s-exctab.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-wchcon.ads table.ads targparm.ads tbuild.ads ttypes.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads - -sem_res.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ - checks.ads debug.ads debug_a.ads einfo.ads elists.ads errout.ads \ - exp_ch7.ads exp_util.ads expander.ads freeze.ads gnat.ads g-htable.ads \ - g-os_lib.ads hostparm.ads itypes.ads lib.ads lib-xref.ads namet.ads \ - nlists.ads nmake.ads opt.ads output.ads restrict.ads rident.ads \ - rtsfind.ads sem.ads sem_aggr.ads sem_attr.ads sem_cat.ads sem_ch4.ads \ - sem_ch6.ads sem_ch8.ads sem_disp.ads sem_dist.ads sem_elab.ads \ - sem_eval.ads sem_intr.ads sem_res.ads sem_res.adb sem_type.ads \ - sem_util.ads sem_warn.ads sinfo.ads sinput.ads snames.ads stand.ads \ - stringt.ads system.ads s-assert.ads s-exctab.ads s-imgenu.ads \ - s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-wchcon.ads table.ads targparm.ads tbuild.ads tree_io.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads - -sem_smem.o : alloc.ads atree.ads einfo.ads errout.ads namet.ads \ - sem_smem.ads sem_smem.adb sinfo.ads snames.ads system.ads s-exctab.ads \ - s-stalib.ads table.ads types.ads uintp.ads unchconv.ads unchdeal.ads \ - urealp.ads - -sem_type.o : ada.ads a-except.ads alloc.ads atree.ads debug.ads einfo.ads \ - errout.ads gnat.ads g-os_lib.ads hostparm.ads lib.ads namet.ads opt.ads \ - output.ads sem.ads sem_ch6.ads sem_ch8.ads sem_type.ads sem_type.adb \ - sem_util.ads sinfo.ads snames.ads stand.ads system.ads s-assert.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads \ - types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -sem_util.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ - debug.ads einfo.ads elists.ads errout.ads exp_util.ads freeze.ads \ - get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads \ - lib-xref.ads namet.ads nlists.ads nmake.ads opt.ads output.ads \ - restrict.ads rident.ads rtsfind.ads scans.ads scn.ads sem.ads \ - sem_ch8.ads sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \ - sem_util.adb sinfo.ads sinput.ads snames.ads stand.ads stringt.ads \ - style.ads system.ads s-assert.ads s-exctab.ads s-imgenu.ads \ - s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - s-wchcon.ads table.ads targparm.ads tbuild.ads tree_io.ads ttypes.ads \ - types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads + tree_io.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \ + unchdeal.ads urealp.ads widechar.ads -sem_vfpt.o : alloc.ads cstand.ads einfo.ads hostparm.ads namet.ads opt.ads \ - sem_vfpt.ads sem_vfpt.adb stand.ads system.ads s-exctab.ads \ - s-stalib.ads s-wchcon.ads table.ads targparm.ads ttypef.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads +s-assert.o : ada.ads a-except.ads gnat.ads g-htable.ads system.ads \ + s-assert.ads s-assert.adb s-exctab.ads s-exctab.adb s-stalib.ads \ + unchconv.ads -sem_warn.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads debug.ads \ - einfo.ads errout.ads fname.ads gnat.ads g-os_lib.ads hostparm.ads \ - lib.ads namet.ads nlists.ads opt.ads output.ads sem.ads sem_util.ads \ - sem_warn.ads sem_warn.adb sinfo.ads sinput.ads snames.ads stand.ads \ - system.ads s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads \ - table.ads table.adb tree_io.ads types.ads uintp.ads unchconv.ads \ - unchdeal.ads urealp.ads +s-crc32.o : interfac.ads system.ads s-crc32.ads s-crc32.adb s-except.o : ada.ads a-except.ads system.ads s-except.ads s-stalib.ads \ unchconv.ads @@ -3979,122 +3298,17 @@ s-except.o : ada.ads a-except.ads system.ads s-except.ads s-stalib.ads \ s-exctab.o : ada.ads a-uncdea.ads gnat.ads g-htable.ads g-htable.adb \ system.ads s-exctab.ads s-exctab.adb s-stalib.ads unchconv.ads -s-exngen.o : system.ads s-exngen.ads s-exngen.adb - -s-exnllf.o : ada.ads a-except.ads system.ads s-exngen.ads s-exngen.adb \ - s-exnllf.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - unchconv.ads - -s-fatllf.o : ada.ads a-unccon.ads system.ads s-assert.ads s-exctab.ads \ - s-fatgen.ads s-fatgen.adb s-fatllf.ads s-stalib.ads s-unstyp.ads \ - unchconv.ads - -s-ficobl.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-stream.ads \ - a-tags.ads a-tags.adb gnat.ads g-htable.ads interfac.ads i-cstrea.ads \ - system.ads s-exctab.ads s-ficobl.ads s-finimp.ads s-finroo.ads \ - s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-stratt.ads s-unstyp.ads unchconv.ads - -s-fileio.o : ada.ads a-except.ads a-finali.ads a-filico.ads a-ioexce.ads \ - a-stream.ads a-tags.ads a-tags.adb gnat.ads g-htable.ads interfac.ads \ - i-cstrea.ads system.ads s-exctab.ads s-ficobl.ads s-fileio.ads \ - s-fileio.adb s-finimp.ads s-finroo.ads s-parame.ads s-secsta.ads \ - s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads \ - s-unstyp.ads unchconv.ads unchdeal.ads - -s-finimp.o : ada.ads a-except.ads a-stream.ads a-tags.ads a-tags.adb \ - a-unccon.ads gnat.ads g-htable.ads system.ads s-exctab.ads s-finimp.ads \ - s-finimp.adb s-finroo.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads s-stoele.adb s-stratt.ads s-sopco3.ads \ - s-unstyp.ads unchconv.ads - -s-finroo.o : ada.ads a-except.ads a-stream.ads a-tags.ads a-tags.adb \ - gnat.ads g-htable.ads system.ads s-exctab.ads s-finroo.ads s-finroo.adb \ - s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ - unchconv.ads - -sfn_scan.o : ada.ads a-except.ads sfn_scan.ads sfn_scan.adb system.ads \ - s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads unchconv.ads - -s-imgbiu.o : system.ads s-imgbiu.ads s-imgbiu.adb s-unstyp.ads - s-imgenu.o : system.ads s-imgenu.ads s-imgenu.adb s-secsta.ads \ s-stoele.ads unchconv.ads -s-imgint.o : system.ads s-imgint.ads s-imgint.adb s-secsta.ads \ - s-stoele.ads - -s-imgllb.o : system.ads s-imgllb.ads s-imgllb.adb s-unstyp.ads - -s-imglli.o : system.ads s-imglli.ads s-imglli.adb s-secsta.ads \ - s-stoele.ads - -s-imgllu.o : system.ads s-imgllu.ads s-imgllu.adb s-secsta.ads \ - s-stoele.ads s-unstyp.ads - -s-imgllw.o : system.ads s-imgllw.ads s-imgllw.adb s-unstyp.ads - -s-imgrea.o : ada.ads a-unccon.ads system.ads s-assert.ads s-exctab.ads \ - s-fatgen.ads s-fatgen.adb s-fatllf.ads s-imgllu.ads s-imgrea.ads \ - s-imgrea.adb s-imguns.ads s-powtab.ads s-secsta.ads s-stalib.ads \ - s-stoele.ads s-unstyp.ads unchconv.ads - -s-imguns.o : system.ads s-imguns.ads s-imguns.adb s-secsta.ads \ - s-stoele.ads s-unstyp.ads - -s-imgwiu.o : system.ads s-imgwiu.ads s-imgwiu.adb s-unstyp.ads - -sinfo.o : alloc.ads atree.ads einfo.ads sinfo.ads sinfo.adb snames.ads \ - system.ads s-assert.ads s-exctab.ads s-stalib.ads table.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads - -sinfo-cn.o : alloc.ads atree.ads einfo.ads sinfo.ads sinfo-cn.ads \ - sinfo-cn.adb snames.ads system.ads s-exctab.ads s-stalib.ads table.ads \ - types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads - -sinput.o : ada.ads a-except.ads alloc.ads casing.ads debug.ads gnat.ads \ - g-os_lib.ads hostparm.ads namet.ads opt.ads output.ads sinput.ads \ - sinput.adb system.ads s-assert.ads s-exctab.ads s-stalib.ads \ - s-wchcon.ads table.ads table.adb tree_io.ads types.ads unchconv.ads \ - unchdeal.ads - -sinput-l.o : alloc.ads atree.ads casing.ads debug.ads einfo.ads gnat.ads \ - g-os_lib.ads hostparm.ads namet.ads opt.ads osint.ads output.ads \ - scans.ads scn.ads sinfo.ads sinput.ads sinput-l.ads sinput-l.adb \ - snames.ads system.ads s-assert.ads s-exctab.ads s-stalib.ads \ - s-wchcon.ads table.ads types.ads uintp.ads unchconv.ads unchdeal.ads \ - urealp.ads - -sinput-p.o : ada.ads a-unccon.ads alloc.ads casing.ads gnat.ads \ - g-os_lib.ads hostparm.ads namet.ads opt.ads scans.ads sinput.ads \ - sinput-p.ads sinput-p.adb system.ads s-exctab.ads s-stalib.ads \ - s-stoele.ads s-wchcon.ads table.ads types.ads unchconv.ads unchdeal.ads - -s-io.o : system.ads s-io.ads s-io.adb - s-mastop.o : ada.ads a-except.ads system.ads s-except.ads s-mastop.ads \ s-mastop.adb s-stalib.ads s-stoele.ads unchconv.ads s-memory.o : ada.ads a-except.ads system.ads s-memory.ads s-memory.adb \ s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads unchconv.ads -snames.o : alloc.ads namet.ads snames.ads snames.adb system.ads \ - s-assert.ads s-exctab.ads s-stalib.ads table.ads types.ads unchconv.ads \ - unchdeal.ads - s-parame.o : system.ads s-parame.ads s-parame.adb -s-powtab.o : system.ads s-powtab.ads - -sprint.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads debug.ads \ - einfo.ads hostparm.ads lib.ads namet.ads nlists.ads opt.ads output.ads \ - rtsfind.ads sinfo.ads sinput.ads sinput-l.ads snames.ads sprint.ads \ - sprint.adb stand.ads stringt.ads system.ads s-assert.ads s-exctab.ads \ - s-imgenu.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-wchcon.ads table.ads types.ads uintp.ads uname.ads \ - unchconv.ads unchdeal.ads urealp.ads - s-secsta.o : ada.ads a-except.ads system.ads s-parame.ads s-secsta.ads \ s-secsta.adb s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ unchconv.ads unchdeal.ads @@ -4121,142 +3335,704 @@ s-stalib.o : ada.ads a-except.ads system.ads s-memory.ads s-soflin.ads \ s-stoele.o : system.ads s-stoele.ads s-stoele.adb unchconv.ads -s-stopoo.o : ada.ads a-except.ads a-finali.ads a-stream.ads a-tags.ads \ - a-tags.adb gnat.ads g-htable.ads system.ads s-exctab.ads s-finimp.ads \ - s-finroo.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-stopoo.ads s-stratt.ads s-unstyp.ads unchconv.ads - -s-stratt.o : ada.ads a-except.ads a-ioexce.ads a-stream.ads a-tags.ads \ - a-tags.adb gnat.ads g-htable.ads system.ads s-exctab.ads s-secsta.ads \ - s-stalib.ads s-stoele.ads s-stratt.ads s-stratt.adb s-unstyp.ads \ - unchconv.ads - s-strops.o : system.ads s-secsta.ads s-stoele.ads s-strops.ads \ s-strops.adb -stand.o : alloc.ads gnat.ads g-os_lib.ads namet.ads stand.ads stand.adb \ - system.ads s-exctab.ads s-stalib.ads table.ads tree_io.ads types.ads \ - unchconv.ads unchdeal.ads - s-traceb.o : system.ads s-traceb.ads s-traceb.adb -stringt.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \ - hostparm.ads namet.ads opt.ads output.ads stringt.ads stringt.adb \ - system.ads s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads \ - table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads +s-unstyp.o : system.ads s-unstyp.ads -style.o : alloc.ads atree.ads casing.ads csets.ads einfo.ads errout.ads \ - hostparm.ads namet.ads opt.ads scans.ads scn.ads sinfo.ads sinput.ads \ - snames.ads stand.ads style.ads style.adb stylesw.ads system.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads table.ads types.ads uintp.ads \ - unchconv.ads unchdeal.ads urealp.ads +s-wchcnv.o : interfac.ads system.ads s-wchcnv.ads s-wchcnv.adb \ + s-wchcon.ads s-wchjis.ads -stylesw.o : hostparm.ads opt.ads stylesw.ads stylesw.adb system.ads \ - s-exctab.ads s-stalib.ads s-wchcon.ads types.ads unchconv.ads \ - unchdeal.ads +s-wchcon.o : system.ads s-wchcon.ads -s-unstyp.o : system.ads s-unstyp.ads +s-wchjis.o : system.ads s-wchjis.ads s-wchjis.adb -s-valenu.o : system.ads s-valenu.ads s-valenu.adb s-valuti.ads \ - unchconv.ads +scans.o : scans.ads scans.adb system.ads s-exctab.ads s-stalib.ads \ + types.ads unchconv.ads unchdeal.ads -s-valint.o : system.ads s-unstyp.ads s-valint.ads s-valint.adb \ - s-valuns.ads s-valuti.ads +scn.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + csets.ads debug.ads einfo.ads elists.ads errout.ads gnat.ads \ + g-htable.ads g-os_lib.ads hostparm.ads interfac.ads namet.ads namet.adb \ + nlists.ads nlists.adb opt.ads output.ads scans.ads scn.ads scn.adb \ + scn-nlit.adb scn-slit.adb sinfo.ads sinfo.adb sinput.ads sinput.adb \ + snames.ads stringt.ads stringt.adb style.ads system.ads s-atacco.ads \ + s-atacco.adb s-crc32.ads s-crc32.adb s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ + types.adb uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads \ + urealp.adb widechar.ads + +sem.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads debug_a.ads debug_a.adb einfo.ads einfo.adb elists.ads \ + errout.ads expander.ads fname.ads gnat.ads g-hesora.ads g-htable.ads \ + g-os_lib.ads hlo.ads hostparm.ads inline.ads lib.ads lib.adb \ + lib-list.adb lib-load.ads lib-sort.adb namet.ads nlists.ads nlists.adb \ + opt.ads output.ads restrict.ads rident.ads sem.ads sem.adb sem_attr.ads \ + sem_ch10.ads sem_ch11.ads sem_ch12.ads sem_ch13.ads sem_ch2.ads \ + sem_ch2.adb sem_ch3.ads sem_ch4.ads sem_ch5.ads sem_ch6.ads sem_ch7.ads \ + sem_ch8.ads sem_ch9.ads sem_prag.ads sem_util.ads sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads stringt.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb tree_io.ads types.ads types.adb uintp.ads uintp.adb \ + uname.ads unchconv.ads unchdeal.ads urealp.ads -s-vallli.o : system.ads s-unstyp.ads s-vallli.ads s-vallli.adb \ - s-valllu.ads s-valuti.ads +sem_aggr.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + elists.adb errout.ads eval_fat.ads exp_ch11.ads exp_ch2.ads exp_ch7.ads \ + exp_util.ads exp_util.adb freeze.ads get_targ.ads gnat.ads g-htable.ads \ + g-os_lib.ads g-speche.ads hostparm.ads inline.ads itypes.ads lib.ads \ + lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb nmake.ads \ + nmake.adb opt.ads output.ads restrict.ads rident.ads rtsfind.ads \ + scans.ads scn.ads sem.ads sem_aggr.ads sem_aggr.adb sem_cat.ads \ + sem_ch13.ads sem_ch8.ads sem_eval.ads sem_eval.adb sem_res.ads \ + sem_type.ads sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads stringt.ads stringt.adb style.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads \ + tbuild.adb tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb \ + unchconv.ads unchdeal.ads urealp.ads validsw.ads widechar.ads -s-valllu.o : system.ads s-unstyp.ads s-valllu.ads s-valllu.adb \ - s-valuti.ads +sem_attr.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads alloc.ads \ + atree.ads atree.adb casing.ads checks.ads checks.adb debug.ads \ + einfo.ads einfo.adb elists.ads errout.ads eval_fat.ads exp_ch11.ads \ + exp_ch2.ads exp_ch7.ads exp_tss.ads exp_util.ads exp_util.adb \ + expander.ads freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads \ + hostparm.ads inline.ads itypes.ads lib.ads lib-xref.ads namet.ads \ + nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \ + restrict.ads rident.ads rtsfind.ads sem.ads sem_attr.ads sem_attr.adb \ + sem_cat.ads sem_ch6.ads sem_ch8.ads sem_dist.ads sem_eval.ads \ + sem_eval.adb sem_res.ads sem_type.ads sem_util.ads sem_warn.ads \ + sinfo.ads sinfo.adb sinput.ads sinput.adb snames.ads snames.adb \ + stand.ads stringt.ads stringt.adb system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-exctab.adb s-imgenu.ads s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb targparm.ads tbuild.ads tbuild.adb tree_io.ads \ + ttypef.ads ttypes.ads types.ads types.adb uintp.ads uintp.adb \ + unchconv.ads unchdeal.ads urealp.ads urealp.adb validsw.ads \ + widechar.ads -s-valrea.o : system.ads s-exngen.ads s-exnllf.ads s-powtab.ads \ - s-valrea.ads s-valrea.adb s-valuti.ads +sem_case.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads errout.ads gnat.ads \ + g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads namet.ads \ + nlists.ads nlists.adb opt.ads output.ads sem.ads sem_case.ads \ + sem_case.adb sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \ + sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads \ + s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ + s-wchcon.ads table.ads table.adb tree_io.ads types.ads uintp.ads \ + uintp.adb unchconv.ads unchdeal.ads urealp.ads + +sem_cat.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads elists.adb errout.ads \ + exp_tss.ads fname.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \ + hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb namet.ads \ + nlists.ads nlists.adb opt.ads output.ads sem.ads sem_cat.ads \ + sem_cat.adb sem_util.ads sinfo.ads sinfo.adb sinput.ads snames.ads \ + stand.ads stringt.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads \ + urealp.ads -s-valuns.o : system.ads s-unstyp.ads s-valuns.ads s-valuns.adb \ - s-valuti.ads +sem_ch10.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads errout.ads exp_util.ads \ + fname.ads fname-uf.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads \ + g-htable.ads g-os_lib.ads hostparm.ads impunit.ads inline.ads lib.ads \ + lib.adb lib-list.adb lib-load.ads lib-sort.adb lib-xref.ads namet.ads \ + namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \ + restrict.ads rident.ads rtsfind.ads scans.ads scn.ads sem.ads \ + sem_ch10.ads sem_ch10.adb sem_ch6.ads sem_ch7.ads sem_ch8.ads \ + sem_dist.ads sem_eval.ads sem_prag.ads sem_res.ads sem_type.ads \ + sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinfo-cn.ads \ + sinput.ads sinput.adb snames.ads stand.ads stringt.ads style.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads \ + tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb uname.ads \ + unchconv.ads unchdeal.ads urealp.ads widechar.ads -s-valuti.o : gnat.ads g-casuti.ads system.ads s-valuti.ads s-valuti.adb +sem_ch11.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads errout.ads gnat.ads \ + g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib-xref.ads namet.ads \ + nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \ + restrict.ads rident.ads rtsfind.ads sem.ads sem_ch11.ads sem_ch11.adb \ + sem_ch5.ads sem_ch8.ads sem_res.ads sem_util.ads sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tree_io.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads \ + urealp.ads -s-wchcnv.o : interfac.ads system.ads s-wchcnv.ads s-wchcnv.adb \ - s-wchcon.ads s-wchjis.ads +sem_ch12.o : ada.ads a-except.ads a-uncdea.ads alloc.ads atree.ads \ + atree.adb casing.ads debug.ads einfo.ads einfo.adb elists.ads \ + elists.adb errout.ads exp_util.ads expander.ads fname.ads fname-uf.ads \ + freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads g-htable.adb \ + g-os_lib.ads hostparm.ads inline.ads lib.ads lib.adb lib-list.adb \ + lib-load.ads lib-sort.adb lib-xref.ads namet.ads namet.adb nlists.ads \ + nlists.adb nmake.ads nmake.adb opt.ads output.ads restrict.ads \ + rident.ads rtsfind.ads scans.ads scn.ads sem.ads sem_cat.ads \ + sem_ch10.ads sem_ch12.ads sem_ch12.adb sem_ch13.ads sem_ch3.ads \ + sem_ch6.ads sem_ch7.ads sem_ch8.ads sem_elab.ads sem_elim.ads \ + sem_eval.ads sem_res.ads sem_type.ads sem_util.ads sem_util.adb \ + sinfo.ads sinfo.adb sinfo-cn.ads sinput.ads sinput-l.ads snames.ads \ + stand.ads stringt.ads style.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-exctab.adb s-imgenu.ads s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb targparm.ads tbuild.ads tbuild.adb tree_io.ads \ + ttypes.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \ + unchdeal.ads urealp.ads urealp.adb widechar.ads + +sem_ch13.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads debug.ads einfo.ads einfo.adb elists.ads errout.ads \ + exp_tss.ads exp_util.ads fname.ads get_targ.ads gnat.ads g-hesora.ads \ + g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb lib-list.adb \ + lib-sort.adb namet.ads nlists.ads nlists.adb nmake.ads nmake.adb \ + opt.ads output.ads rtsfind.ads sem.ads sem_ch13.ads sem_ch13.adb \ + sem_ch8.ads sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \ + sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads stringt.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb tbuild.ads tree_io.ads \ + ttypes.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \ + unchdeal.ads urealp.ads urealp.adb + +sem_ch2.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads elists.ads errout.ads gnat.ads g-htable.ads \ + g-os_lib.ads hostparm.ads namet.ads nlists.ads nlists.adb opt.ads \ + output.ads restrict.ads rident.ads sem_ch2.ads sem_ch2.adb sem_ch8.ads \ + sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads \ + s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ + s-wchcon.ads table.ads table.adb tree_io.ads types.ads types.adb \ + uintp.ads unchconv.ads unchdeal.ads urealp.ads -s-wchcon.o : system.ads s-wchcon.ads +sem_ch3.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + elists.adb errout.ads eval_fat.ads exp_ch11.ads exp_ch2.ads exp_ch3.ads \ + exp_ch7.ads exp_dist.ads exp_tss.ads exp_util.ads exp_util.adb \ + fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \ + g-os_lib.ads hostparm.ads inline.ads itypes.ads layout.ads lib.ads \ + lib.adb lib-list.adb lib-sort.adb lib-xref.ads namet.ads namet.adb \ + nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \ + restrict.ads rident.ads rtsfind.ads scans.ads scn.ads sem.ads \ + sem_case.ads sem_case.adb sem_cat.ads sem_cat.adb sem_ch13.ads \ + sem_ch3.ads sem_ch3.adb sem_ch6.ads sem_ch7.ads sem_ch8.ads \ + sem_disp.ads sem_dist.ads sem_elim.ads sem_eval.ads sem_eval.adb \ + sem_mech.ads sem_res.ads sem_smem.ads sem_type.ads sem_util.ads \ + sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads \ + stand.ads stringt.ads style.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + targparm.ads tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads \ + uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads \ + urealp.adb validsw.ads widechar.ads + +sem_ch4.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads errout.ads exp_util.ads \ + freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads g-speche.ads \ + hostparm.ads itypes.ads lib.ads lib-xref.ads namet.ads namet.adb \ + nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \ + restrict.ads rident.ads rtsfind.ads scans.ads scn.ads sem.ads \ + sem_cat.ads sem_ch3.ads sem_ch4.ads sem_ch4.adb sem_ch8.ads \ + sem_dist.ads sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \ + sem_util.adb sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \ + stringt.ads style.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \ + tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb \ + unchconv.ads unchdeal.ads urealp.ads widechar.ads -s-wchjis.o : system.ads s-wchjis.ads s-wchjis.adb +sem_ch5.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + errout.ads eval_fat.ads exp_ch2.ads exp_util.ads expander.ads \ + freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \ + hostparm.ads lib.ads lib-xref.ads namet.ads namet.adb nlists.ads \ + nlists.adb nmake.ads opt.ads output.ads restrict.ads rident.ads \ + rtsfind.ads scans.ads scn.ads sem.ads sem_case.ads sem_case.adb \ + sem_cat.ads sem_ch3.ads sem_ch5.ads sem_ch5.adb sem_ch8.ads \ + sem_disp.ads sem_eval.ads sem_eval.adb sem_res.ads sem_type.ads \ + sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinput.ads \ + snames.ads stand.ads stringt.ads style.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb targparm.ads tbuild.ads tree_io.ads ttypes.ads \ + types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads \ + validsw.ads widechar.ads + +sem_ch6.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + elists.adb errout.ads exp_ch2.ads exp_ch7.ads exp_util.ads expander.ads \ + fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \ + g-os_lib.ads hostparm.ads inline.ads lib.ads lib.adb lib-list.adb \ + lib-sort.adb lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb \ + nmake.ads nmake.adb opt.ads output.ads restrict.ads rident.ads \ + rtsfind.ads scans.ads scn.ads sem.ads sem_cat.ads sem_ch12.ads \ + sem_ch3.ads sem_ch4.ads sem_ch5.ads sem_ch6.ads sem_ch6.adb sem_ch8.ads \ + sem_disp.ads sem_dist.ads sem_elim.ads sem_eval.ads sem_mech.ads \ + sem_prag.ads sem_res.ads sem_type.ads sem_util.ads sem_util.adb \ + sem_warn.ads sinfo.ads sinfo.adb sinfo-cn.ads sinput.ads snames.ads \ + stand.ads stringt.ads stringt.adb style.ads stylesw.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads \ + s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ + s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tbuild.adb \ + tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb uname.ads \ + unchconv.ads unchdeal.ads urealp.ads validsw.ads widechar.ads + +sem_ch7.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads elists.adb errout.ads \ + exp_dbug.ads exp_disp.ads exp_util.ads freeze.ads get_targ.ads gnat.ads \ + g-htable.ads g-os_lib.ads hostparm.ads inline.ads lib.ads lib-xref.ads \ + namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \ + output.ads restrict.ads rident.ads rtsfind.ads scans.ads scn.ads \ + sem.ads sem_cat.ads sem_ch12.ads sem_ch3.ads sem_ch6.ads sem_ch7.ads \ + sem_ch7.adb sem_ch8.ads sem_eval.ads sem_res.ads sem_type.ads \ + sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinput.ads \ + snames.ads snames.adb stand.ads stringt.ads style.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads \ + s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ + s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tree_io.ads \ + ttypes.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads \ + urealp.ads widechar.ads + +sem_ch8.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads elists.adb errout.ads \ + exp_util.ads fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads \ + g-htable.ads g-os_lib.ads g-speche.ads hostparm.ads inline.ads lib.ads \ + lib.adb lib-list.adb lib-load.ads lib-sort.adb lib-xref.ads namet.ads \ + namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \ + restrict.ads rident.ads rtsfind.ads scans.ads scn.ads sem.ads \ + sem_ch12.ads sem_ch3.ads sem_ch4.ads sem_ch6.ads sem_ch8.ads \ + sem_ch8.adb sem_eval.ads sem_res.ads sem_type.ads sem_util.ads \ + sem_util.adb sinfo.ads sinfo.adb sinfo-cn.ads sinput.ads snames.ads \ + stand.ads stringt.ads style.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + targparm.ads tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads \ + uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads widechar.ads + +sem_ch9.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + errout.ads exp_ch2.ads exp_ch9.ads exp_util.ads fname.ads fname-uf.ads \ + freeze.ads get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads \ + itypes.ads lib.ads lib-xref.ads namet.ads namet.adb nlists.ads \ + nlists.adb nmake.ads nmake.adb opt.ads output.ads restrict.ads \ + restrict.adb rident.ads rtsfind.ads scans.ads scn.ads sem.ads \ + sem_ch3.ads sem_ch5.ads sem_ch6.ads sem_ch8.ads sem_ch9.ads sem_ch9.adb \ + sem_eval.ads sem_res.ads sem_type.ads sem_util.ads sem_util.adb \ + sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \ + stringt.ads style.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \ + tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb \ + uname.ads unchconv.ads unchdeal.ads urealp.ads validsw.ads widechar.ads + +sem_disp.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads elists.adb errout.ads \ + exp_ch7.ads exp_disp.ads exp_tss.ads exp_util.ads freeze.ads \ + get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads \ + lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb nmake.ads \ + opt.ads output.ads restrict.ads rident.ads rtsfind.ads scans.ads \ + scn.ads sem.ads sem_ch6.ads sem_ch8.ads sem_disp.ads sem_disp.adb \ + sem_eval.ads sem_res.ads sem_type.ads sem_util.ads sem_util.adb \ + sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads stringt.ads \ + style.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \ + tbuild.ads tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb \ + unchconv.ads unchdeal.ads urealp.ads widechar.ads -switch.o : ada.ads a-except.ads debug.ads gnat.ads g-os_lib.ads \ - hostparm.ads opt.ads osint.ads stylesw.ads switch.ads switch.adb \ - system.ads s-exctab.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-wchcon.ads types.ads unchconv.ads unchdeal.ads \ - validsw.ads +sem_dist.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads errout.ads exp_dist.ads \ + exp_tss.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads \ + namet.ads nlists.ads nlists.adb nmake.ads nmake.adb opt.ads output.ads \ + restrict.ads rident.ads rtsfind.ads sem.ads sem_dist.ads sem_dist.adb \ + sem_res.ads sem_util.ads sinfo.ads sinfo.adb sinput.ads snames.ads \ + stand.ads stringt.ads stringt.adb system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tbuild.ads tbuild.adb tree_io.ads types.ads types.adb uintp.ads \ + uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads -system.o : system.ads +sem_elab.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + elists.adb errout.ads exp_ch2.ads exp_util.ads expander.ads fname.ads \ + freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \ + hostparm.ads lib.ads lib.adb lib-list.adb lib-load.ads lib-sort.adb \ + lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb nmake.ads \ + nmake.adb opt.ads output.ads restrict.ads rident.ads rtsfind.ads \ + scans.ads scn.ads sem.ads sem_cat.ads sem_ch7.ads sem_ch8.ads \ + sem_elab.ads sem_elab.adb sem_eval.ads sem_res.ads sem_type.ads \ + sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb sinput.ads \ + sinput.adb snames.ads stand.ads stringt.ads style.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads \ + s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ + s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tbuild.adb \ + tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb uname.ads \ + unchconv.ads unchdeal.ads urealp.ads validsw.ads widechar.ads + +sem_elim.o : ada.ads a-except.ads a-uncdea.ads alloc.ads atree.ads \ + atree.adb casing.ads debug.ads einfo.ads einfo.adb elists.ads \ + errout.ads gnat.ads g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads \ + namet.ads nlists.ads nlists.adb opt.ads output.ads sem_elim.ads \ + sem_elim.adb sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \ + stringt.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads -table.o : debug.ads gnat.ads g-os_lib.ads hostparm.ads opt.ads output.ads \ - system.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads table.adb \ - tree_io.ads types.ads unchconv.ads unchdeal.ads +sem_eval.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads einfo.ads einfo.adb elists.ads \ + elists.adb errout.ads eval_fat.ads exp_ch2.ads exp_util.ads freeze.ads \ + get_targ.ads gnat.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads \ + lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb nmake.ads \ + nmake.adb opt.ads output.ads restrict.ads rident.ads rtsfind.ads \ + scans.ads scn.ads sem.ads sem_cat.ads sem_ch8.ads sem_eval.ads \ + sem_eval.adb sem_res.ads sem_type.ads sem_util.ads sem_util.adb \ + sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \ + stringt.ads stringt.adb style.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + targparm.ads tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads \ + uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads urealp.adb \ + validsw.ads widechar.ads + +sem_intr.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads errout.ads fname.ads gnat.ads \ + g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb \ + lib-list.adb lib-sort.adb namet.ads nlists.ads nlists.adb opt.ads \ + output.ads sem_eval.ads sem_intr.ads sem_intr.adb sem_util.ads \ + sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads stringt.ads \ + stringt.adb system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads \ + tree_io.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \ + unchdeal.ads urealp.ads + +sem_maps.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads gnat.ads g-htable.ads \ + g-os_lib.ads hostparm.ads namet.ads nlists.ads nlists.adb opt.ads \ + output.ads sem_maps.ads sem_maps.adb sinfo.ads sinfo.adb sinput.ads \ + snames.ads stand.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads + +sem_mech.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads errout.ads gnat.ads \ + g-htable.ads g-os_lib.ads hostparm.ads namet.ads nlists.ads nlists.adb \ + opt.ads output.ads sem.ads sem_mech.ads sem_mech.adb sem_util.ads \ + sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads \ + s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ + s-wchcon.ads table.ads table.adb targparm.ads tree_io.ads types.ads \ + uintp.ads uintp.adb unchconv.ads unchdeal.ads urealp.ads + +sem_prag.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + casing.adb checks.ads csets.ads debug.ads einfo.ads einfo.adb \ + elists.ads elists.adb errout.ads eval_fat.ads exp_dist.ads expander.ads \ + fname.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \ + g-speche.ads hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb \ + namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \ + output.ads restrict.ads rident.ads rtsfind.ads sem.ads sem_cat.ads \ + sem_ch13.ads sem_ch8.ads sem_disp.ads sem_elim.ads sem_eval.ads \ + sem_eval.adb sem_intr.ads sem_mech.ads sem_prag.ads sem_prag.adb \ + sem_res.ads sem_type.ads sem_util.ads sem_vfpt.ads sem_warn.ads \ + sinfo.ads sinfo.adb sinfo-cn.ads sinput.ads sinput.adb snames.ads \ + snames.adb stand.ads stringt.ads stringt.adb stylesw.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-exctab.adb s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads \ + tree_io.ads ttypes.ads types.ads types.adb uintp.ads uintp.adb \ + uname.ads unchconv.ads unchdeal.ads urealp.ads urealp.adb validsw.ads \ + widechar.ads + +sem_res.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + checks.ads checks.adb debug.ads debug_a.ads debug_a.adb einfo.ads \ + einfo.adb elists.ads errout.ads eval_fat.ads exp_ch11.ads exp_ch2.ads \ + exp_ch7.ads exp_util.ads exp_util.adb expander.ads fname.ads freeze.ads \ + get_targ.ads gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads \ + hostparm.ads inline.ads itypes.ads lib.ads lib.adb lib-list.adb \ + lib-sort.adb lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb \ + nmake.ads nmake.adb opt.ads output.ads restrict.ads rident.ads \ + rtsfind.ads scans.ads scn.ads sem.ads sem_aggr.ads sem_attr.ads \ + sem_cat.ads sem_ch4.ads sem_ch6.ads sem_ch8.ads sem_disp.ads \ + sem_dist.ads sem_elab.ads sem_eval.ads sem_eval.adb sem_intr.ads \ + sem_res.ads sem_res.adb sem_type.ads sem_util.ads sem_util.adb \ + sem_warn.ads sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads \ + stringt.ads stringt.adb style.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + targparm.ads tbuild.ads tbuild.adb tree_io.ads ttypes.ads types.ads \ + types.adb uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads \ + urealp.ads urealp.adb validsw.ads widechar.ads + +sem_smem.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads errout.ads gnat.ads \ + g-htable.ads g-os_lib.ads hostparm.ads namet.ads nlists.ads nlists.adb \ + opt.ads output.ads sem_smem.ads sem_smem.adb sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tree_io.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads \ + urealp.ads -targparm.o : ada.ads a-except.ads alloc.ads casing.ads fname.ads \ - fname-uf.ads namet.ads output.ads sinput.ads sinput-l.ads system.ads \ - s-assert.ads s-exctab.ads s-stalib.ads table.ads targparm.ads \ - targparm.adb types.ads unchconv.ads unchdeal.ads +sem_type.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads errout.ads exp_util.ads \ + fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \ + g-os_lib.ads hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb \ + lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb nmake.ads \ + opt.ads output.ads restrict.ads rident.ads rtsfind.ads scans.ads \ + scn.ads sem.ads sem_ch6.ads sem_ch8.ads sem_eval.ads sem_res.ads \ + sem_type.ads sem_type.adb sem_util.ads sem_util.adb sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads stringt.ads style.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads \ + s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ + s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads tree_io.ads \ + ttypes.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \ + unchdeal.ads urealp.ads widechar.ads + +sem_util.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + casing.adb checks.ads csets.ads debug.ads einfo.ads einfo.adb \ + elists.ads elists.adb errout.ads eval_fat.ads exp_ch11.ads exp_ch7.ads \ + exp_util.ads exp_util.adb fname.ads freeze.ads get_targ.ads gnat.ads \ + g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads inline.ads \ + itypes.ads lib.ads lib.adb lib-list.adb lib-sort.adb lib-xref.ads \ + namet.ads namet.adb nlists.ads nlists.adb nmake.ads nmake.adb opt.ads \ + output.ads restrict.ads rident.ads rtsfind.ads scans.ads scn.ads \ + sem.ads sem_cat.ads sem_ch8.ads sem_eval.ads sem_eval.adb sem_res.ads \ + sem_type.ads sem_util.ads sem_util.adb sem_warn.ads sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads stringt.ads stringt.adb style.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads \ + tbuild.adb tree_io.ads ttypes.ads types.ads types.adb uintp.ads \ + uintp.adb uname.ads unchconv.ads unchdeal.ads urealp.ads urealp.adb \ + validsw.ads widechar.ads + +sem_vfpt.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + cstand.ads debug.ads einfo.ads einfo.adb elists.ads gnat.ads \ + g-htable.ads g-os_lib.ads hostparm.ads namet.ads nlists.ads nlists.adb \ + opt.ads output.ads sem_vfpt.ads sem_vfpt.adb sinfo.ads sinfo.adb \ + sinput.ads snames.ads stand.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + targparm.ads tree_io.ads ttypef.ads types.ads uintp.ads uintp.adb \ + unchconv.ads unchdeal.ads urealp.ads + +sem_warn.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads errout.ads exp_util.ads \ + fname.ads freeze.ads get_targ.ads gnat.ads g-hesora.ads g-htable.ads \ + g-os_lib.ads hostparm.ads lib.ads lib.adb lib-list.adb lib-sort.adb \ + lib-xref.ads namet.ads namet.adb nlists.ads nlists.adb nmake.ads \ + opt.ads output.ads restrict.ads rident.ads rtsfind.ads scans.ads \ + scn.ads sem.ads sem_ch8.ads sem_eval.ads sem_res.ads sem_type.ads \ + sem_util.ads sem_util.adb sem_warn.ads sem_warn.adb sinfo.ads sinfo.adb \ + sinput.ads sinput.adb snames.ads stand.ads stringt.ads style.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb targparm.ads tbuild.ads \ + tree_io.ads ttypes.ads types.ads uintp.ads uintp.adb uname.ads \ + unchconv.ads unchdeal.ads urealp.ads widechar.ads -tbuild.o : alloc.ads atree.ads einfo.ads lib.ads namet.ads nlists.ads \ - nmake.ads restrict.ads rident.ads sinfo.ads snames.ads stand.ads \ - system.ads s-assert.ads s-exctab.ads s-stalib.ads s-stoele.ads \ - table.ads tbuild.ads tbuild.adb types.ads uintp.ads unchconv.ads \ +sinfo-cn.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads elists.ads gnat.ads g-htable.ads g-os_lib.ads \ + hostparm.ads nlists.ads nlists.adb opt.ads output.ads sinfo.ads \ + sinfo-cn.ads sinfo-cn.adb sinput.ads snames.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb tree_io.ads types.ads uintp.ads unchconv.ads \ unchdeal.ads urealp.ads -tree_gen.o : alloc.ads atree.ads casing.ads einfo.ads elists.ads fname.ads \ - gnat.ads g-os_lib.ads hostparm.ads lib.ads namet.ads nlists.ads opt.ads \ - osint.ads repinfo.ads sinfo.ads sinput.ads snames.ads stand.ads \ - stringt.ads system.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads \ - tree_gen.ads tree_gen.adb types.ads uintp.ads unchconv.ads unchdeal.ads \ +sinfo.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads elists.ads gnat.ads g-htable.ads g-os_lib.ads \ + hostparm.ads nlists.ads nlists.adb opt.ads output.ads sinfo.ads \ + sinfo.adb sinput.ads snames.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tree_io.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads \ urealp.ads -tree_io.o : ada.ads a-except.ads debug.ads gnat.ads g-os_lib.ads \ - output.ads system.ads s-exctab.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads tree_io.ads tree_io.adb types.ads \ +sinput-d.o : ada.ads a-except.ads alloc.ads casing.ads debug.ads gnat.ads \ + g-os_lib.ads hostparm.ads opt.ads osint.ads osint-c.ads output.ads \ + sinput.ads sinput-d.ads sinput-d.adb system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-memory.ads s-stalib.ads s-wchcon.ads \ + table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads + +sinput-l.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads elists.ads gnat.ads g-htable.ads g-os_lib.ads \ + hostparm.ads namet.ads nlists.ads nlists.adb opt.ads osint.ads \ + output.ads scans.ads scn.ads sinfo.ads sinfo.adb sinput.ads \ + sinput-l.ads sinput-l.adb snames.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb tree_io.ads types.ads uintp.ads unchconv.ads \ + unchdeal.ads urealp.ads + +sinput.o : ada.ads a-except.ads alloc.ads casing.ads debug.ads gnat.ads \ + g-os_lib.ads hostparm.ads namet.ads namet.adb opt.ads output.ads \ + sinput.ads sinput.adb system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-memory.ads s-secsta.ads s-stalib.ads s-stoele.ads s-wchcon.ads \ + table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads \ + widechar.ads + +snames.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \ + hostparm.ads namet.ads opt.ads output.ads snames.ads snames.adb \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-memory.ads \ + s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ unchconv.ads unchdeal.ads -treepr.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads csets.ads \ - debug.ads einfo.ads elists.ads lib.ads namet.ads nlists.ads output.ads \ - sem_mech.ads sinfo.ads sinput.ads snames.ads stand.ads stringt.ads \ - system.ads s-exctab.ads s-imgenu.ads s-secsta.ads s-soflin.ads \ - s-stache.ads s-stalib.ads s-stoele.ads table.ads treepr.ads treepr.adb \ - treeprs.ads types.ads uintp.ads uname.ads unchconv.ads unchdeal.ads \ - urealp.ads +sprint.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + csets.ads debug.ads einfo.ads einfo.adb elists.ads fname.ads gnat.ads \ + g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb \ + lib-list.adb lib-sort.adb namet.ads nlists.ads nlists.adb opt.ads \ + output.ads output.adb rtsfind.ads sinfo.ads sinfo.adb sinput.ads \ + sinput-d.ads snames.ads sprint.ads sprint.adb stand.ads stringt.ads \ + stringt.adb system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads uintp.ads uintp.adb uname.ads unchconv.ads unchdeal.ads \ + urealp.ads urealp.adb -treeprs.o : alloc.ads sinfo.ads system.ads s-exctab.ads s-stalib.ads \ - table.ads treeprs.ads types.ads uintp.ads unchconv.ads unchdeal.ads \ - urealp.ads +stand.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \ + hostparm.ads namet.ads opt.ads output.ads stand.ads stand.adb \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-memory.ads \ + s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ + unchconv.ads unchdeal.ads + +stringt.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \ + hostparm.ads namet.ads opt.ads output.ads stringt.ads stringt.adb \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-memory.ads \ + s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ + types.adb unchconv.ads unchdeal.ads + +style.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + csets.ads debug.ads einfo.ads elists.ads errout.ads gnat.ads \ + g-htable.ads g-os_lib.ads hostparm.ads interfac.ads namet.ads namet.adb \ + nlists.ads nlists.adb opt.ads output.ads scans.ads scn.ads scn.adb \ + scn-nlit.adb scn-slit.adb sinfo.ads sinfo.adb sinput.ads sinput.adb \ + snames.ads stand.ads stringt.ads style.ads style.adb stylesw.ads \ + system.ads s-atacco.ads s-atacco.adb s-crc32.ads s-crc32.adb \ + s-exctab.ads s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tree_io.ads types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads \ + widechar.ads + +stylesw.o : hostparm.ads opt.ads stylesw.ads stylesw.adb system.ads \ + s-exctab.ads s-stalib.ads s-wchcon.ads types.ads unchconv.ads \ + unchdeal.ads + +switch-b.o : ada.ads a-except.ads debug.ads gnat.ads g-os_lib.ads \ + hostparm.ads opt.ads osint.ads switch.ads switch-b.ads switch-b.adb \ + system.ads s-exctab.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads types.ads unchconv.ads unchdeal.ads + +switch-c.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads \ + g-os_lib.ads hostparm.ads lib.ads opt.ads osint.ads output.ads \ + stylesw.ads switch.ads switch-c.ads switch-c.adb system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-memory.ads s-soflin.ads \ + s-stache.ads s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb \ + tree_io.ads types.ads unchconv.ads unchdeal.ads validsw.ads + +switch.o : ada.ads a-except.ads gnat.ads g-htable.ads switch.ads \ + switch.adb system.ads s-exctab.ads s-exctab.adb s-stalib.ads types.ads \ + unchconv.ads unchdeal.ads + +system.o : system.ads + +table.o : debug.ads gnat.ads g-os_lib.ads hostparm.ads opt.ads output.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-memory.ads \ + s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ + unchconv.ads unchdeal.ads + +targparm.o : ada.ads a-except.ads alloc.ads casing.ads debug.ads gnat.ads \ + g-os_lib.ads hostparm.ads namet.ads opt.ads output.ads sinput.ads \ + sinput.adb sinput-l.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-memory.ads s-stalib.ads s-wchcon.ads table.ads table.adb \ + targparm.ads targparm.adb tree_io.ads types.ads unchconv.ads \ + unchdeal.ads + +tbuild.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads fname.ads gnat.ads \ + g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb \ + lib-list.adb lib-sort.adb namet.ads namet.adb nlists.ads nlists.adb \ + nmake.ads nmake.adb opt.ads output.ads restrict.ads rident.ads \ + sinfo.ads sinfo.adb sinput.ads snames.ads stand.ads stringt.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads \ + s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ + s-stoele.ads s-wchcon.ads table.ads table.adb tbuild.ads tbuild.adb \ + tree_io.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \ + unchdeal.ads urealp.ads widechar.ads + +tree_gen.o : ada.ads a-except.ads alloc.ads atree.ads casing.ads debug.ads \ + einfo.ads elists.ads fname.ads gnat.ads g-os_lib.ads hostparm.ads \ + lib.ads namet.ads nlists.ads opt.ads osint.ads osint-c.ads output.ads \ + repinfo.ads sinfo.ads sinput.ads snames.ads stand.ads stringt.ads \ + system.ads s-atacco.ads s-atacco.adb s-exctab.ads s-memory.ads \ + s-stalib.ads s-wchcon.ads table.ads table.adb tree_gen.ads tree_gen.adb \ + tree_io.ads types.ads uintp.ads unchconv.ads unchdeal.ads urealp.ads + +tree_io.o : ada.ads a-except.ads debug.ads gnat.ads g-htable.ads \ + g-os_lib.ads output.ads system.ads s-exctab.ads s-exctab.adb \ + s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads tree_io.ads \ + tree_io.adb types.ads unchconv.ads unchdeal.ads + +treepr.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + csets.ads debug.ads einfo.ads einfo.adb elists.ads elists.adb fname.ads \ + gnat.ads g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads \ + lib.adb lib-list.adb lib-sort.adb namet.ads nlists.ads nlists.adb \ + opt.ads output.ads output.adb sem_mech.ads sinfo.ads sinfo.adb \ + sinput.ads sinput.adb snames.ads stand.ads stringt.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-imgenu.ads s-memory.ads \ + s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads s-stoele.ads \ + s-wchcon.ads table.ads table.adb tree_io.ads treepr.ads treepr.adb \ + treeprs.ads types.ads uintp.ads uintp.adb uname.ads unchconv.ads \ + unchdeal.ads urealp.ads + +treeprs.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \ + hostparm.ads opt.ads output.ads sinfo.ads system.ads s-atacco.ads \ + s-atacco.adb s-exctab.ads s-memory.ads s-stalib.ads s-wchcon.ads \ + table.ads table.adb tree_io.ads treeprs.ads types.ads uintp.ads \ + unchconv.ads unchdeal.ads urealp.ads ttypef.o : system.ads ttypef.ads ttypes.o : get_targ.ads system.ads s-exctab.ads s-stalib.ads ttypes.ads \ types.ads unchconv.ads unchdeal.ads -types.o : system.ads s-exctab.ads s-stalib.ads types.ads types.adb \ - unchconv.ads unchdeal.ads +types.o : gnat.ads g-htable.ads system.ads s-exctab.ads s-exctab.adb \ + s-stalib.ads types.ads types.adb unchconv.ads unchdeal.ads uintp.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \ - hostparm.ads opt.ads output.ads system.ads s-assert.ads s-exctab.ads \ - s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ - uintp.ads uintp.adb unchconv.ads unchdeal.ads - -uname.o : alloc.ads atree.ads casing.ads einfo.ads hostparm.ads lib.ads \ - namet.ads nlists.ads output.ads sinfo.ads sinput.ads snames.ads \ - system.ads s-assert.ads s-exctab.ads s-stalib.ads table.ads types.ads \ - uintp.ads uname.ads uname.adb unchconv.ads unchdeal.ads urealp.ads + hostparm.ads opt.ads output.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-memory.ads s-stalib.ads s-wchcon.ads table.ads table.adb \ + tree_io.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads + +uname.o : ada.ads a-except.ads alloc.ads atree.ads atree.adb casing.ads \ + debug.ads einfo.ads einfo.adb elists.ads fname.ads gnat.ads \ + g-hesora.ads g-htable.ads g-os_lib.ads hostparm.ads lib.ads lib.adb \ + lib-list.adb lib-sort.adb namet.ads nlists.ads nlists.adb opt.ads \ + output.ads sinfo.ads sinfo.adb sinput.ads sinput.adb snames.ads \ + stand.ads stringt.ads system.ads s-atacco.ads s-atacco.adb s-exctab.ads \ + s-imgenu.ads s-memory.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads uintp.ads uintp.adb uname.ads uname.adb unchconv.ads \ + unchdeal.ads urealp.ads urealp.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \ - hostparm.ads opt.ads output.ads system.ads s-assert.ads s-exctab.ads \ - s-stalib.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ - uintp.ads unchconv.ads unchdeal.ads urealp.ads urealp.adb - -usage.o : alloc.ads gnat.ads g-os_lib.ads hostparm.ads namet.ads osint.ads \ - output.ads system.ads s-exctab.ads s-stalib.ads s-wchcon.ads table.ads \ - types.ads unchconv.ads unchdeal.ads usage.ads usage.adb + hostparm.ads opt.ads output.ads system.ads s-atacco.ads s-atacco.adb \ + s-exctab.ads s-memory.ads s-stalib.ads s-wchcon.ads table.ads table.adb \ + tree_io.ads types.ads uintp.ads uintp.adb unchconv.ads unchdeal.ads \ + urealp.ads urealp.adb + +usage.o : ada.ads a-except.ads alloc.ads debug.ads gnat.ads g-os_lib.ads \ + hostparm.ads namet.ads opt.ads osint.ads output.ads system.ads \ + s-atacco.ads s-atacco.adb s-exctab.ads s-memory.ads s-stalib.ads \ + s-wchcon.ads table.ads table.adb tree_io.ads types.ads unchconv.ads \ + unchdeal.ads usage.ads usage.adb validsw.o : hostparm.ads opt.ads system.ads s-exctab.ads s-stalib.ads \ s-wchcon.ads types.ads unchconv.ads unchdeal.ads validsw.ads \ @@ -4267,47 +4043,4 @@ widechar.o : ada.ads a-except.ads hostparm.ads interfac.ads opt.ads \ s-stoele.ads s-wchcnv.ads s-wchcnv.adb s-wchcon.ads s-wchjis.ads \ types.ads unchconv.ads unchdeal.ads widechar.ads widechar.adb -xref_lib.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-finali.ads \ - a-filico.ads a-ioexce.ads a-stream.ads a-string.ads a-strfix.ads \ - a-strmap.ads a-strunb.ads a-tags.ads a-textio.ads gnat.ads g-comlin.ads \ - g-dirope.ads g-dyntab.ads g-dyntab.adb g-io_aux.ads g-os_lib.ads \ - g-regexp.ads hostparm.ads interfac.ads i-cstrea.ads osint.ads \ - output.ads system.ads s-exctab.ads s-ficobl.ads s-finimp.ads \ - s-finroo.ads s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads \ - s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads s-sopco3.ads \ - s-sopco4.ads s-sopco5.ads s-unstyp.ads s-valint.ads types.ads \ - unchconv.ads unchdeal.ads xr_tabls.ads xref_lib.ads xref_lib.adb - -xr_tabls.o : ada.ads a-charac.ads a-chlat1.ads a-except.ads a-finali.ads \ - a-filico.ads a-ioexce.ads a-stream.ads a-string.ads a-strfix.ads \ - a-strmap.ads a-strunb.ads a-tags.ads a-textio.ads gnat.ads g-dirope.ads \ - g-io_aux.ads g-os_lib.ads hostparm.ads interfac.ads i-cstrea.ads \ - osint.ads system.ads s-exctab.ads s-ficobl.ads s-finimp.ads \ - s-finroo.ads s-imgint.ads s-parame.ads s-secsta.ads s-soflin.ads \ - s-stache.ads s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads \ - s-sopco3.ads s-unstyp.ads types.ads unchconv.ads unchdeal.ads \ - xr_tabls.ads xr_tabls.adb - # end of regular dependencies - -#In GNU Make, ignore whether `stage*' exists. -.PHONY: stage1 stage2 stage3 stage4 clean realclean TAGS bootstrap -.PHONY: risky-stage1 risky-stage2 risky-stage3 risky-stage4 - -force: - -# Gnatlbr is only used on VMS - -GNATLBR_RTL_C_OBJS = adaint.o argv.o cio.o cstreams.o exit.o final.o init.o \ - raise.o sysdep.o tracebak.o -GNATLBR_C_OBJS = $(GNATLBR_RTL_C_OBJS) - -../gnatlbr$(exeext):: sdefault.o $(GNATLBR_C_OBJS) \ - $(EXTRA_GNATTOOLS_OBJS) - $(RM) $@ -../gnatlbr$(exeext):: force - $(GNATMAKE) -a --GCC="$(CC)" $(ALL_ADAFLAGS) $(ADA_INCLUDES) \ - --GNATBIND="$(GNATBIND)" --GNATLINK="$(GNATLINK)" \ - -nostdlib $(fsrcpfx)gnatlbr -o $@ \ - -largs --GCC="$(CC) $(ALL_CFLAGS) $(LDFLAGS)" \ - $(GNATLBR_C_OBJS) $(EXTRA_GNATTOOLS_OBJS) diff --git a/gcc/ada/a-caldel.adb b/gcc/ada/a-caldel.adb index bada6b4c7bc..9a5aa29a1ce 100644 --- a/gcc/ada/a-caldel.adb +++ b/gcc/ada/a-caldel.adb @@ -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; -------------------- diff --git a/gcc/ada/a-chlat9.ads b/gcc/ada/a-chlat9.ads new file mode 100644 index 00000000000..b1fbd9e434a --- /dev/null +++ b/gcc/ada/a-chlat9.ads @@ -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; diff --git a/gcc/ada/a-comlin.ads b/gcc/ada/a-comlin.ads index b7848e7aa5f..e2637b7f639 100644 --- a/gcc/ada/a-comlin.ads +++ b/gcc/ada/a-comlin.ads @@ -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 diff --git a/gcc/ada/a-cwila9.ads b/gcc/ada/a-cwila9.ads new file mode 100644 index 00000000000..7dcf532ec6a --- /dev/null +++ b/gcc/ada/a-cwila9.ads @@ -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; diff --git a/gcc/ada/a-dynpri.adb b/gcc/ada/a-dynpri.adb index fd33b4f5fd2..c7ba5bcc685 100644 --- a/gcc/ada/a-dynpri.adb +++ b/gcc/ada/a-dynpri.adb @@ -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; diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index cc21e035e04..89932751dc2 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -89,9 +89,119 @@ package body Ada.Exceptions is -- Boolean indicating whether tracebacks should be stored in exception -- occurrences. + Zero_Cost_Exceptions : Integer; + pragma Import (C, Zero_Cost_Exceptions, "__gl_zero_cost_exceptions"); + -- Boolean indicating if we are handling exceptions using a zero cost + -- mechanism. + -- + -- ??? We currently have two alternatives for this scheme : one using + -- front-end tables and one using back-end tables. The former is known to + -- only work for GNAT3 and the latter is known to only work for GNAT5. + -- Both are present in this implementation and it would be good to have + -- separate bodies at some point. + -- + -- Note that although we currently do not support it, the GCC3 back-end + -- tables are also potentially useable for setjmp/longjmp processing. + Nline : constant String := String' (1 => ASCII.LF); -- Convenient shortcut + ------------------------------------------------ + -- Entities to interface with the GCC runtime -- + ------------------------------------------------ + + -- These come from "C++ ABI for Itanium : Exception handling", which is + -- the reference for GCC. They are used only when we are relying on + -- back-end tables for exception propagation, which in turn is currenly + -- only the case for Zero_Cost_Exceptions in GNAT5. + + -- Return codes from the GCC runtime functions used to propagate + -- an exception. + + type Unwind_Reason_Code is + (URC_NO_REASON, + URC_FOREIGN_EXCEPTION_CAUGHT, + URC_PHASE2_ERROR, + URC_PHASE1_ERROR, + URC_NORMAL_STOP, + URC_END_OF_STACK, + URC_HANDLER_FOUND, + URC_INSTALL_CONTEXT, + URC_CONTINUE_UNWIND); + + -- ??? pragma Unreferenced is unknown until 3.15, so we need to disable + -- warnings around it to fix the bootstrap path. + + pragma Warnings (Off); + pragma Unreferenced + (URC_NO_REASON, + URC_FOREIGN_EXCEPTION_CAUGHT, + URC_PHASE2_ERROR, + URC_PHASE1_ERROR, + URC_NORMAL_STOP, + URC_END_OF_STACK, + URC_HANDLER_FOUND, + URC_INSTALL_CONTEXT, + URC_CONTINUE_UNWIND); + pragma Warnings (On); + + pragma Convention (C, Unwind_Reason_Code); + + -- Mandatory common header for any exception object handled by the + -- GCC unwinding runtime. + + subtype Exception_Class is String (1 .. 8); + + GNAT_Exception_Class : constant Exception_Class + := "GNU" & ASCII.NUL & "Ada" & ASCII.NUL; + + type Unwind_Exception is record + Class : Exception_Class := GNAT_Exception_Class; + Cleanup : System.Address := System.Null_Address; + Private1 : Integer; + Private2 : Integer; + end record; + + pragma Convention (C, Unwind_Exception); + + for Unwind_Exception'Alignment use Standard'Maximum_Alignment; + + -- A GNAT exception object to be dealt with by the personality routine + -- called by the GCC unwinding runtime. This structure shall match the + -- one in raise.c and is currently experimental as it might be merged + -- with the GNAT runtime definition some day. + + type GNAT_GCC_Exception is record + Header : Unwind_Exception; + -- Exception header first, as required by the ABI. + + Id : Exception_Id; + -- Usual Exception identifier + + Handled_By_Others : Boolean; + -- Is this exception handled by "when others" ? + + Has_Cleanup : Boolean; + -- Did we see any at-end handler while walking up the stack + -- searching for a handler ? This is used to determine if we + -- start the propagation again after having tried once without + -- finding a true handler for the exception. + + Select_Cleanups : Boolean; + -- Do we consider at-end handlers as legitimate handlers for the + -- exception ? This is used to control the propagation process + -- as described in Raise_Current_Excep. + end record; + + pragma Convention (C, GNAT_GCC_Exception); + + -- GCC runtime functions used + + function Unwind_RaiseException + (E : access GNAT_GCC_Exception) + return Unwind_Reason_Code; + pragma Import (C, Unwind_RaiseException, "_Unwind_RaiseException"); + ----------------------- -- Local Subprograms -- ----------------------- @@ -106,30 +216,69 @@ package body Ada.Exceptions is procedure ZZZ; -- Mark end of procedures in this package - Address_Image_Length : constant := - 13 + 10 * Boolean'Pos (Standard'Address_Size > 32); - -- Length of string returned by Address_Image function - function Address_Image (A : System.Address) return String; -- Returns at string of the form 0xhhhhhhhhh for 32-bit addresses -- or 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are -- in lower case. + procedure Call_Chain (Excep : EOA); + -- Store up to Max_Tracebacks in Excep, corresponding to the current + -- call chain. + procedure Free is new Ada.Unchecked_Deallocation (Subprogram_Descriptor_List, Subprogram_Descriptor_List_Ptr); + procedure Process_Raise_Exception + (E : Exception_Id; + From_Signal_Handler : Boolean); + pragma Inline (Process_Raise_Exception); + pragma No_Return (Process_Raise_Exception); + -- This is the lowest level raise routine. It raises the exception + -- referenced by Current_Excep.all in the TSD, without deferring abort + -- (the caller must ensure that abort is deferred on entry). + -- + -- This is actually the common implementation for Raise_Current_Excep and + -- Raise_From_Signal_Handler, with a couple of operations inhibited when + -- called from the latter. The origin of the call is indicated by the + -- From_Signal_Handler argument. + -- + -- The Inline pragma is there for efficiency reasons. + + procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State); + pragma No_Return (Propagate_Exception_With_FE_Support); + -- This procedure propagates the exception represented by the occurrence + -- referenced by Current_Excep in the TSD for the current task. M is the + -- initial machine state, representing the site of the exception raise + -- operation. + -- + -- The procedure searches the front end exception tables for an applicable + -- handler, calling Pop_Frame as needed. If and when it locates an + -- applicable handler, Enter_Handler is called to actually enter this + -- handler. If the search is unable to locate an applicable handler, + -- execution is terminated by calling Unhandled_Exception_Terminate. + + procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State); + pragma No_Return (Propagate_Exception_With_GCC_Support); + -- This procedure propagates the exception represented by the occurrence + -- referenced by Current_Excep in the TSD for the current task. M is the + -- initial machine state, representing the site of the exception raise + -- operation. It is currently not used and is there for the purpose of + -- interface consistency against Propagate_Exception_With_FE_Support. + -- + -- The procedure builds an object suitable for the libgcc processing and + -- calls Unwind_RaiseException to actually throw, taking care of handling + -- the two phase scheme it implements. + procedure Raise_Current_Excep (E : Exception_Id); pragma No_Return (Raise_Current_Excep); pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg"); - -- This is the lowest level raise routine. It raises the exception - -- referenced by Current_Excep.all in the TSD, without deferring - -- abort (the caller must ensure that abort is deferred on entry). - -- The parameter E is ignored. + -- This is a simple wrapper to Process_Raise_Exception setting the + -- From_Signal_Handler argument to False. -- -- This external name for Raise_Current_Excep is historical, and probably - -- should be changed but for now we keep it, because gdb knows about it. - -- The parameter is also present for historical compatibility. ??? + -- should be changed but for now we keep it, because gdb and gigi know + -- about it. procedure Raise_Exception_No_Defer (E : Exception_Id; Message : String := ""); @@ -148,31 +297,74 @@ package body Ada.Exceptions is procedure Raise_With_Location (E : Exception_Id; - F : SSL.Big_String_Ptr; + F : Big_String_Ptr; L : Integer); pragma No_Return (Raise_With_Location); -- Raise an exception with given exception id value. A filename and line -- number is associated with the raise and is stored in the exception -- occurrence. + procedure Raise_With_Location_And_Msg + (E : Exception_Id; + F : Big_String_Ptr; + L : Integer; + M : Big_String_Ptr); + pragma No_Return (Raise_With_Location_And_Msg); + -- Raise an exception with given exception id value. A filename and line + -- number is associated with the raise and is stored in the exception + -- occurrence and in addition a string message M is appended to this. + procedure Raise_Constraint_Error - (File : SSL.Big_String_Ptr; Line : Integer); + (File : Big_String_Ptr; + Line : Integer); pragma No_Return (Raise_Constraint_Error); - pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error"); + pragma Export + (C, Raise_Constraint_Error, "__gnat_raise_constraint_error"); -- Raise constraint error with file:line information + procedure Raise_Constraint_Error_Msg + (File : Big_String_Ptr; + Line : Integer; + Msg : Big_String_Ptr); + pragma No_Return (Raise_Constraint_Error_Msg); + pragma Export + (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg"); + -- Raise constraint error with file:line + msg information + procedure Raise_Program_Error - (File : SSL.Big_String_Ptr; Line : Integer); + (File : Big_String_Ptr; + Line : Integer); pragma No_Return (Raise_Program_Error); - pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error"); + pragma Export + (C, Raise_Program_Error, "__gnat_raise_program_error"); -- Raise program error with file:line information + procedure Raise_Program_Error_Msg + (File : Big_String_Ptr; + Line : Integer; + Msg : Big_String_Ptr); + pragma No_Return (Raise_Program_Error_Msg); + pragma Export + (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg"); + -- Raise program error with file:line + msg information + procedure Raise_Storage_Error - (File : SSL.Big_String_Ptr; Line : Integer); + (File : Big_String_Ptr; + Line : Integer); pragma No_Return (Raise_Storage_Error); - pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error"); + pragma Export + (C, Raise_Storage_Error, "__gnat_raise_storage_error"); -- Raise storage error with file:line information + procedure Raise_Storage_Error_Msg + (File : Big_String_Ptr; + Line : Integer; + Msg : Big_String_Ptr); + pragma No_Return (Raise_Storage_Error_Msg); + pragma Export + (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg"); + -- Raise storage error with file:line + reason msg information + -- The exception raising process and the automatic tracing mechanism rely -- on some careful use of flags attached to the exception occurrence. The -- graph below illustrates the relations between the Raise_ subprograms @@ -211,12 +403,16 @@ package body Ada.Exceptions is procedure Set_Exception_C_Msg (Id : Exception_Id; - Msg : SSL.Big_String_Ptr; - Line : Integer := 0); + Msg1 : Big_String_Ptr; + Line : Integer := 0; + Msg2 : Big_String_Ptr := null); -- This routine is called to setup the exception referenced by the -- Current_Excep field in the TSD to contain the indicated Id value - -- and message. Msg is a null terminated string. when Line > 0, - -- Msg is the filename and line the line number of the exception location. + -- and message. Msg1 is a null terminated string which is generated + -- as the exception message. If line is non-zero, then a colon and + -- the decimal representation of this integer is appended to the + -- message. When Msg2 is non-null, a space and this additional null + -- terminated string is added to the message. procedure To_Stderr (S : String); pragma Export (Ada, To_Stderr, "__gnat_to_stderr"); @@ -261,6 +457,264 @@ package body Ada.Exceptions is -- which are somewhat redundant is historical. Notify_Exception -- certainly is complete enough, but GDB still uses this routine. + ----------------------------- + -- Run-Time Check Routines -- + ----------------------------- + + -- These routines are called from the runtime to raise a specific + -- exception with a reason message attached. The parameters are + -- the file name and line number in each case. The names are keyed + -- to the codes defined in Types.ads and a-types.h (for example, + -- the name Rcheck_05 refers to the Reason whose Pos code is 5). + + procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer); + procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer); + + pragma Export (C, Rcheck_00, "__gnat_rcheck_00"); + pragma Export (C, Rcheck_01, "__gnat_rcheck_01"); + pragma Export (C, Rcheck_02, "__gnat_rcheck_02"); + pragma Export (C, Rcheck_03, "__gnat_rcheck_03"); + pragma Export (C, Rcheck_04, "__gnat_rcheck_04"); + pragma Export (C, Rcheck_05, "__gnat_rcheck_05"); + pragma Export (C, Rcheck_06, "__gnat_rcheck_06"); + pragma Export (C, Rcheck_07, "__gnat_rcheck_07"); + pragma Export (C, Rcheck_08, "__gnat_rcheck_08"); + pragma Export (C, Rcheck_09, "__gnat_rcheck_09"); + pragma Export (C, Rcheck_10, "__gnat_rcheck_10"); + pragma Export (C, Rcheck_11, "__gnat_rcheck_11"); + pragma Export (C, Rcheck_12, "__gnat_rcheck_12"); + pragma Export (C, Rcheck_13, "__gnat_rcheck_13"); + pragma Export (C, Rcheck_14, "__gnat_rcheck_14"); + pragma Export (C, Rcheck_15, "__gnat_rcheck_15"); + pragma Export (C, Rcheck_16, "__gnat_rcheck_16"); + pragma Export (C, Rcheck_17, "__gnat_rcheck_17"); + pragma Export (C, Rcheck_18, "__gnat_rcheck_18"); + pragma Export (C, Rcheck_19, "__gnat_rcheck_19"); + pragma Export (C, Rcheck_20, "__gnat_rcheck_20"); + pragma Export (C, Rcheck_21, "__gnat_rcheck_21"); + pragma Export (C, Rcheck_22, "__gnat_rcheck_22"); + pragma Export (C, Rcheck_23, "__gnat_rcheck_23"); + pragma Export (C, Rcheck_24, "__gnat_rcheck_24"); + pragma Export (C, Rcheck_25, "__gnat_rcheck_25"); + pragma Export (C, Rcheck_26, "__gnat_rcheck_26"); + pragma Export (C, Rcheck_27, "__gnat_rcheck_27"); + pragma Export (C, Rcheck_28, "__gnat_rcheck_28"); + + --------------------------------------------- + -- Reason Strings for Run-Time Check Calls -- + --------------------------------------------- + + -- These strings are null-terminated and are used by Rcheck_nn. The + -- strings correspond to the definitions for Types.RT_Exception_Code. + + use ASCII; + + Rmsg_00 : constant String := "access check failed" & NUL; + Rmsg_01 : constant String := "access parameter is null" & NUL; + Rmsg_02 : constant String := "discriminant check failed" & NUL; + Rmsg_03 : constant String := "divide by zero" & NUL; + Rmsg_04 : constant String := "explicit raise" & NUL; + Rmsg_05 : constant String := "index check failed" & NUL; + Rmsg_06 : constant String := "invalid data" & NUL; + Rmsg_07 : constant String := "length check failed" & NUL; + Rmsg_08 : constant String := "overflow check failed" & NUL; + Rmsg_09 : constant String := "partition check failed" & NUL; + Rmsg_10 : constant String := "range check failed" & NUL; + Rmsg_11 : constant String := "tag check failed" & NUL; + Rmsg_12 : constant String := "access before elaboration" & NUL; + Rmsg_13 : constant String := "accessibility check failed" & NUL; + Rmsg_14 : constant String := "all guards closed" & NUL; + Rmsg_15 : constant String := "duplicated entry address" & NUL; + Rmsg_16 : constant String := "explicit raise" & NUL; + Rmsg_17 : constant String := "finalize raised exception" & NUL; + Rmsg_18 : constant String := "invalid data" & NUL; + Rmsg_19 : constant String := "misaligned address value" & NUL; + Rmsg_20 : constant String := "missing return" & NUL; + Rmsg_21 : constant String := "potentially blocking operation" & NUL; + Rmsg_22 : constant String := "stubbed subprogram called" & NUL; + Rmsg_23 : constant String := "unchecked union restriction" & NUL; + Rmsg_24 : constant String := "empty storage pool" & NUL; + Rmsg_25 : constant String := "explicit raise" & NUL; + Rmsg_26 : constant String := "infinite recursion" & NUL; + Rmsg_27 : constant String := "object too large" & NUL; + Rmsg_28 : constant String := "restriction violation" & NUL; + + -------------------------------------- + -- Calls to Run-Time Check Routines -- + -------------------------------------- + + procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_00'Address)); + end Rcheck_00; + + procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_01'Address)); + end Rcheck_01; + + procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_02'Address)); + end Rcheck_02; + + procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_03'Address)); + end Rcheck_03; + + procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_04'Address)); + end Rcheck_04; + + procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_05'Address)); + end Rcheck_05; + + procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_06'Address)); + end Rcheck_06; + + procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_07'Address)); + end Rcheck_07; + + procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_08'Address)); + end Rcheck_08; + + procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_09'Address)); + end Rcheck_09; + + procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_10'Address)); + end Rcheck_10; + + procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_11'Address)); + end Rcheck_11; + + procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_12'Address)); + end Rcheck_12; + + procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_13'Address)); + end Rcheck_13; + + procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_14'Address)); + end Rcheck_14; + + procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_15'Address)); + end Rcheck_15; + + procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_16'Address)); + end Rcheck_16; + + procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_17'Address)); + end Rcheck_17; + + procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_18'Address)); + end Rcheck_18; + + procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_19'Address)); + end Rcheck_19; + + procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_20'Address)); + end Rcheck_20; + + procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_21'Address)); + end Rcheck_21; + + procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_22'Address)); + end Rcheck_22; + + procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_23'Address)); + end Rcheck_23; + + procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_24'Address)); + end Rcheck_24; + + procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_25'Address)); + end Rcheck_25; + + procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_26'Address)); + end Rcheck_26; + + procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_27'Address)); + end Rcheck_27; + + procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_28'Address)); + end Rcheck_28; + --------------------------------------- -- Exception backtracing subprograms -- --------------------------------------- @@ -307,18 +761,18 @@ package body Ada.Exceptions is (N : Natural; Info : in out String; Ptr : in out Natural); - -- Append the image of N at the end of the provided information string. + -- Append the image of N at the end of the provided information string procedure Append_Info_NL (Info : in out String; Ptr : in out Natural); - -- Append a CR/LF couple at the end of the provided information string. + -- Append a LF at the end of the provided information string procedure Append_Info_String (S : String; Info : in out String; Ptr : in out Natural); - -- Append a string at the end of the provided information string. + -- Append a string at the end of the provided information string -- To build Exception_Information and Tailored_Exception_Information, -- we then use three intermediate functions : @@ -408,22 +862,6 @@ package body Ada.Exceptions is procedure Unhandled_Terminate; pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); - procedure Propagate_Exception (Mstate : Machine_State); - pragma No_Return (Propagate_Exception); - -- This procedure propagates the exception represented by the occurrence - -- referenced by Current_Excep in the TSD for the current task. M is - -- the initial machine state, representing the site of the exception - -- raise operation. Propagate_Exception searches the exception tables - -- for an applicable handler, calling Pop_Frame as needed. If and when - -- it locates an applicable handler Propagate_Exception makes a call - -- to Enter_Handler to actually enter the handler. If the search is - -- unable to locate an applicable handler, execution is terminated by - -- calling Unhandled_Exception_Terminate. - - procedure Call_Chain (Excep : EOA); - -- Store up to Max_Tracebacks in Excep, corresponding to the current - -- call chain. - ----------------------- -- Polling Interface -- ----------------------- @@ -504,8 +942,6 @@ package body Ada.Exceptions is is begin Ptr := Ptr + 1; - Info (Ptr) := ASCII.CR; - Ptr := Ptr + 1; Info (Ptr) := ASCII.LF; end Append_Info_NL; @@ -823,11 +1259,98 @@ package body Ada.Exceptions is return Name (P .. Name'Length); end Exception_Name_Simple; - ------------------------- - -- Propagate_Exception -- - ------------------------- + ----------------------------- + -- Process_Raise_Exception -- + ----------------------------- + + procedure Process_Raise_Exception + (E : Exception_Id; + From_Signal_Handler : Boolean) + is + pragma Inspection_Point (E); + -- This is so the debugger can reliably inspect the parameter + + Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; + Mstate_Ptr : constant Machine_State := + Machine_State (Get_Machine_State_Addr.all); + Excep : EOA := Get_Current_Excep.all; + + begin + -- WARNING : There should be no exception handler for this body + -- because this would cause gigi to prepend a setup for a new + -- jmpbuf to the sequence of statements. We would then always get + -- this new buf in Jumpbuf_Ptr instead of the one for the exception + -- we are handling, which would completely break the whole design + -- of this procedure. + + -- Processing varies between zero cost and setjmp/lonjmp processing. + + if Zero_Cost_Exceptions /= 0 then + + -- Use the front-end tables to propagate if we have them, otherwise + -- resort to the GCC back-end alternative. The backtrace for the + -- occurrence is stored while walking up the stack, and thus stops + -- in the handler's frame if there is one. Notifications are also + -- not performed here since it is not yet known if the exception is + -- handled. + + -- Set the machine state unless we are raising from a signal handler + -- since it has already been set properly in that case. + + if not From_Signal_Handler then + Set_Machine_State (Mstate_Ptr); + end if; + + if Subprogram_Descriptors /= null then + Propagate_Exception_With_FE_Support (Mstate_Ptr); + else + Propagate_Exception_With_GCC_Support (Mstate_Ptr); + end if; + + else + + -- Compute the backtrace for this occurrence if the corresponding + -- binder option has been set and we are not raising from a signal + -- handler. Call_Chain takes care of the reraise case. + + if not From_Signal_Handler + and then Exception_Tracebacks /= 0 + then + Call_Chain (Excep); + end if; + + -- If the jump buffer pointer is non-null, transfer control using + -- it. Otherwise announce an unhandled exception (note that this + -- means that we have no finalizations to do other than at the outer + -- level). Perform the necessary notification tasks in both cases. + + if Jumpbuf_Ptr /= Null_Address then + + if not Excep.Exception_Raised then + Excep.Exception_Raised := True; + Notify_Handled_Exception (Null_Loc, False, False); + + -- The low level debugger notification is skipped from the + -- call above because we do not have the necessary information + -- to "feed" it properly. - procedure Propagate_Exception (Mstate : Machine_State) is + end if; + + builtin_longjmp (Jumpbuf_Ptr, 1); + + else + Notify_Unhandled_Exception (E); + Unhandled_Exception_Terminate; + end if; + end if; + + end Process_Raise_Exception; + + ----------------------------------------- + -- Propagate_Exception_With_FE_Support -- + ----------------------------------------- + + procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State) is Excep : constant EOA := Get_Current_Excep.all; Loc : Code_Loc; Lo, Hi : Natural; @@ -872,10 +1395,10 @@ package body Ada.Exceptions is FH_Mstate : aliased Machine_State_Record; -- Records the machine state for the finalization handler - FH_Handler : Code_Loc; + FH_Handler : Code_Loc := Null_Address; -- Record handler address for finalization handler - FH_Num_Trb : Natural; + FH_Num_Trb : Natural := 0; -- Save number of tracebacks for finalization handler begin @@ -1034,75 +1557,111 @@ package body Ada.Exceptions is Unhandled_Exception_Terminate; - end Propagate_Exception; + end Propagate_Exception_With_FE_Support; - ------------------------- - -- Raise_Current_Excep -- - ------------------------- - - procedure Raise_Current_Excep (E : Exception_Id) is - - pragma Inspection_Point (E); - -- This is so the debugger can reliably inspect the parameter + ------------------------------------------ + -- Propagate_Exception_With_GCC_Support -- + ------------------------------------------ - Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; - Mstate_Ptr : constant Machine_State := - Machine_State (Get_Machine_State_Addr.all); - Excep : EOA; + procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State) is + Excep : EOA := Get_Current_Excep.all; + This_Exception : aliased GNAT_GCC_Exception; + Status : Unwind_Reason_Code; begin - -- WARNING : There should be no exception handler for this body - -- because this would cause gigi to prepend a setup for a new - -- jmpbuf to the sequence of statements. We would then always get - -- this new buf in Jumpbuf_Ptr instead of the one for the exception - -- we are handling, which would completely break the whole design - -- of this procedure. + -- ??? Nothing is currently done for backtracing purposes. We could + -- have used the personality routine to record the addresses while + -- walking up the stack, but this method has two drawbacks : 1/ the + -- trace is incomplete if the exception is handled since we don't walk + -- up the frame with the handler, and 2/ we will miss frames if the + -- exception propagates through frames for which our personality + -- routine is not called (e.g. if C or C++ frames are on the way). + + -- Fill in the useful flags for the personality routine called for each + -- frame via the call to Unwind_RaiseException below. + + This_Exception.Id := Excep.Id; + This_Exception.Handled_By_Others := not Excep.Id.Not_Handled_By_Others; + This_Exception.Has_Cleanup := False; + + -- We are looking for a regular handler first. If there is one, either + -- it or the first at-end handler before it will be entered. If there + -- is none, control will normally get back to after the call, with + -- Has_Cleanup set to true if at least one at-end handler has been + -- found while walking up the stack. + + This_Exception.Select_Cleanups := False; + + Status := Unwind_RaiseException (This_Exception'Access); + + -- If we get here we know the exception is not handled, as otherwise + -- Unwind_RaiseException arranges for a handler to be entered. We might + -- have met cleanups handlers, though, requiring to start again with + -- the Select_Cleanups flag set to True. + + -- Before restarting for cleanups, take the necessary steps to enable + -- the debugger to gain control while the stack is still intact. Flag + -- the occurrence as raised to avoid notifying again in case cleanup + -- handlers are entered later. + + if not Excep.Exception_Raised then + Excep.Exception_Raised := True; + Notify_Unhandled_Exception (Excep.Id); + end if; - -- If the jump buffer pointer is non-null, it means that a jump - -- buffer was allocated (obviously that happens only in the case - -- of zero cost exceptions not implemented, or if a jump buffer - -- was manually set up by C code). + -- Now raise again selecting cleanups as true handlers. Only do this if + -- we know at least one such handler exists since otherwise we would + -- perform a complete stack upwalk for nothing. - if Jumpbuf_Ptr /= Null_Address then - Excep := Get_Current_Excep.all; + if This_Exception.Has_Cleanup then + This_Exception.Select_Cleanups := True; + Status := Unwind_RaiseException (This_Exception'Access); - if Exception_Tracebacks /= 0 then - Call_Chain (Excep); - end if; + -- The first cleanup found is entered. It performs its job, raises + -- the initial exception again, and the flow goes back to the first + -- step above with the stack in a different state. + end if; - -- Perform the necessary notification tasks if this is not a - -- reraise. Actually ask to skip the low level debugger notification - -- call since we do not have the necessary information to "feed" - -- it properly. + -- We get here when there is no handler to be run at all. The debugger + -- has been notified before the second step above. - if not Excep.Exception_Raised then - Excep.Exception_Raised := True; - Notify_Handled_Exception (Null_Loc, False, False); - end if; + Unhandled_Exception_Terminate; - builtin_longjmp (Jumpbuf_Ptr, 1); + end Propagate_Exception_With_GCC_Support; - -- If we have no jump buffer, then either zero cost exception - -- handling is in place, or we have no handlers anyway. In - -- either case we have an unhandled exception. If zero cost - -- exception handling is in place, propagate the exception + ---------------------------- + -- Raise_Constraint_Error -- + ---------------------------- - elsif Subprogram_Descriptors /= null then - Set_Machine_State (Mstate_Ptr); - Propagate_Exception (Mstate_Ptr); + procedure Raise_Constraint_Error + (File : Big_String_Ptr; + Line : Integer) + is + begin + Raise_With_Location (Constraint_Error_Def'Access, File, Line); + end Raise_Constraint_Error; - -- Otherwise, we know the exception is unhandled by the absence - -- of an allocated jump buffer. Note that this means that we also - -- have no finalizations to do other than at the outer level. + -------------------------------- + -- Raise_Constraint_Error_Msg -- + -------------------------------- - else - if Exception_Tracebacks /= 0 then - Call_Chain (Get_Current_Excep.all); - end if; + procedure Raise_Constraint_Error_Msg + (File : Big_String_Ptr; + Line : Integer; + Msg : Big_String_Ptr) + is + begin + Raise_With_Location_And_Msg + (Constraint_Error_Def'Access, File, Line, Msg); + end Raise_Constraint_Error_Msg; - Notify_Unhandled_Exception (E); - Unhandled_Exception_Terminate; - end if; + ------------------------- + -- Raise_Current_Excep -- + ------------------------- + + procedure Raise_Current_Excep (E : Exception_Id) is + begin + Process_Raise_Exception (E => E, From_Signal_Handler => False); end Raise_Current_Excep; --------------------- @@ -1150,51 +1709,12 @@ package body Ada.Exceptions is procedure Raise_From_Signal_Handler (E : Exception_Id; - M : SSL.Big_String_Ptr) + M : Big_String_Ptr) is - Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; - Mstate_Ptr : constant Machine_State := - Machine_State (Get_Machine_State_Addr.all); - begin Set_Exception_C_Msg (E, M); Abort_Defer.all; - - -- Now we raise the exception. The following code is essentially - -- identical to the Raise_Current_Excep routine, except that in the - -- zero cost exception case, we do not call Set_Machine_State, since - -- the signal handler that passed control here has already set the - -- machine state directly. - -- - -- We also do not compute the backtrace for the occurrence since going - -- through the signal handler is far from trivial and it is not a - -- problem to fail providing a backtrace in the "raised from signal - -- handler" case. - - -- If the jump buffer pointer is non-null, it means that a jump - -- buffer was allocated (obviously that happens only in the case - -- of zero cost exceptions not implemented, or if a jump buffer - -- was manually set up by C code). - - if Jumpbuf_Ptr /= Null_Address then - builtin_longjmp (Jumpbuf_Ptr, 1); - - -- If we have no jump buffer, then either zero cost exception - -- handling is in place, or we have no handlers anyway. In - -- either case we have an unhandled exception. If zero cost - -- exception handling is in place, propagate the exception - - elsif Subprogram_Descriptors /= null then - Propagate_Exception (Mstate_Ptr); - - -- Otherwise, we know the exception is unhandled by the absence - -- of an allocated jump buffer. Note that this means that we also - -- have no finalizations to do other than at the outer level. - - else - Notify_Unhandled_Exception (E); - Unhandled_Exception_Terminate; - end if; + Process_Raise_Exception (E => E, From_Signal_Handler => True); end Raise_From_Signal_Handler; ------------------ @@ -1210,62 +1730,102 @@ package body Ada.Exceptions is end Raise_No_Msg; ------------------------- - -- Raise_With_Location -- - ------------------------- - - procedure Raise_With_Location - (E : Exception_Id; - F : SSL.Big_String_Ptr; - L : Integer) is - begin - Set_Exception_C_Msg (E, F, L); - Abort_Defer.all; - Raise_Current_Excep (E); - end Raise_With_Location; - - ---------------------------- - -- Raise_Constraint_Error -- - ---------------------------- - - procedure Raise_Constraint_Error - (File : SSL.Big_String_Ptr; Line : Integer) is - begin - Raise_With_Location (Constraint_Error_Def'Access, File, Line); - end Raise_Constraint_Error; - - ------------------------- -- Raise_Program_Error -- ------------------------- procedure Raise_Program_Error - (File : SSL.Big_String_Ptr; Line : Integer) is + (File : Big_String_Ptr; + Line : Integer) + is begin Raise_With_Location (Program_Error_Def'Access, File, Line); end Raise_Program_Error; + ----------------------------- + -- Raise_Program_Error_Msg -- + ----------------------------- + + procedure Raise_Program_Error_Msg + (File : Big_String_Ptr; + Line : Integer; + Msg : Big_String_Ptr) + is + begin + Raise_With_Location_And_Msg + (Program_Error_Def'Access, File, Line, Msg); + end Raise_Program_Error_Msg; + ------------------------- -- Raise_Storage_Error -- ------------------------- procedure Raise_Storage_Error - (File : SSL.Big_String_Ptr; Line : Integer) is + (File : Big_String_Ptr; + Line : Integer) + is begin Raise_With_Location (Storage_Error_Def'Access, File, Line); end Raise_Storage_Error; + ----------------------------- + -- Raise_Storage_Error_Msg -- + ----------------------------- + + procedure Raise_Storage_Error_Msg + (File : Big_String_Ptr; + Line : Integer; + Msg : Big_String_Ptr) + is + begin + Raise_With_Location_And_Msg + (Storage_Error_Def'Access, File, Line, Msg); + end Raise_Storage_Error_Msg; + ---------------------- -- Raise_With_C_Msg -- ---------------------- procedure Raise_With_C_Msg - (E : Exception_Id; - M : SSL.Big_String_Ptr) is + (E : Exception_Id; + M : Big_String_Ptr) + is begin Set_Exception_C_Msg (E, M); Abort_Defer.all; Raise_Current_Excep (E); end Raise_With_C_Msg; + ------------------------- + -- Raise_With_Location -- + ------------------------- + + procedure Raise_With_Location + (E : Exception_Id; + F : Big_String_Ptr; + L : Integer) + is + begin + Set_Exception_C_Msg (E, F, L); + Abort_Defer.all; + Raise_Current_Excep (E); + end Raise_With_Location; + + --------------------------------- + -- Raise_With_Location_And_Msg -- + --------------------------------- + + procedure Raise_With_Location_And_Msg + (E : Exception_Id; + F : Big_String_Ptr; + L : Integer; + M : Big_String_Ptr) + is + begin + Set_Exception_C_Msg (E, F, L, M); + Abort_Defer.all; + Raise_Current_Excep (E); + end Raise_With_Location_And_Msg; + -------------------- -- Raise_With_Msg -- -------------------- @@ -1513,13 +2073,15 @@ package body Ada.Exceptions is procedure Set_Exception_C_Msg (Id : Exception_Id; - Msg : Big_String_Ptr; - Line : Integer := 0) + Msg1 : Big_String_Ptr; + Line : Integer := 0; + Msg2 : Big_String_Ptr := null) is Excep : constant EOA := Get_Current_Excep.all; Val : Integer := Line; Remind : Integer; Size : Integer := 1; + Ptr : Natural; begin Excep.Exception_Raised := False; @@ -1529,14 +2091,17 @@ package body Ada.Exceptions is Excep.Msg_Length := 0; Excep.Cleanup_Flag := False; - while Msg (Excep.Msg_Length + 1) /= ASCII.NUL + while Msg1 (Excep.Msg_Length + 1) /= ASCII.NUL and then Excep.Msg_Length < Exception_Msg_Max_Length loop Excep.Msg_Length := Excep.Msg_Length + 1; - Excep.Msg (Excep.Msg_Length) := Msg (Excep.Msg_Length); + Excep.Msg (Excep.Msg_Length) := Msg1 (Excep.Msg_Length); end loop; + -- Append line number if present + if Line > 0 then + -- Compute the number of needed characters while Val > 0 loop @@ -1561,6 +2126,24 @@ package body Ada.Exceptions is end loop; end if; end if; + + -- Append second message if present + + if Msg2 /= null + and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length + then + Excep.Msg_Length := Excep.Msg_Length + 1; + Excep.Msg (Excep.Msg_Length) := ' '; + + Ptr := 1; + while Msg2 (Ptr) /= ASCII.NUL + and then Excep.Msg_Length < Exception_Msg_Max_Length + loop + Excep.Msg_Length := Excep.Msg_Length + 1; + Excep.Msg (Excep.Msg_Length) := Msg2 (Ptr); + Ptr := Ptr + 1; + end loop; + end if; end Set_Exception_C_Msg; ------------------- @@ -1593,7 +2176,7 @@ package body Ada.Exceptions is procedure Next_String; -- On entry, To points to last character of previous line of the - -- message, terminated by CR/LF. On return, From .. To are set to + -- message, terminated by LF. On return, From .. To are set to -- specify the next string, or From > To if there are no more lines. procedure Bad_EO is @@ -1605,15 +2188,15 @@ package body Ada.Exceptions is procedure Next_String is begin - From := To + 3; + From := To + 2; if From < S'Last then To := From + 1; - while To < S'Last - 2 loop + while To < S'Last - 1 loop if To >= S'Last then Bad_EO; - elsif S (To + 1) = ASCII.CR then + elsif S (To + 1) = ASCII.LF then exit; else To := To + 1; @@ -1631,7 +2214,7 @@ package body Ada.Exceptions is else X.Cleanup_Flag := False; - To := S'First - 3; + To := S'First - 2; Next_String; if S (From .. From + 15) /= "Exception name: " then @@ -1885,8 +2468,14 @@ package body Ada.Exceptions is type int is new Integer; procedure Unhandled_Exception_Terminate is - Excep : constant EOA := Get_Current_Excep.all; - Msg : constant String := Exception_Message (Excep.all); + + Excep : constant EOA := Save_Occurrence (Get_Current_Excep.all.all); + -- This occurrence will be used to display a message after finalization. + -- It is necessary to save a copy here, or else the designated value + -- could be overwritten if an exception is raised during finalization + -- (even if that exception is caught). + + Msg : constant String := Exception_Message (Excep.all); -- Start of processing for Unhandled_Exception_Terminate diff --git a/gcc/ada/a-except.ads b/gcc/ada/a-except.ads index ff9a135e22b..bdc2d38c577 100644 --- a/gcc/ada/a-except.ads +++ b/gcc/ada/a-except.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.50 $ +-- $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 -- @@ -85,7 +85,7 @@ package Ada.Exceptions is -- PID=nnnn -- 0xyyyyyyyy 0xyyyyyyyy ... -- - -- The lines are separated by an ASCII.CR/ASCII.LF sequence. + -- The lines are separated by a ASCII.LF character -- The nnnn is the partition Id given as decimal digits. -- The 0x... line represents traceback program counter locations, -- in order with the first one being the exception location. @@ -100,7 +100,7 @@ package Ada.Exceptions is function Save_Occurrence (Source : Exception_Occurrence) - return Exception_Occurrence_Access; + return Exception_Occurrence_Access; private package SSL renames System.Standard_Library; diff --git a/gcc/ada/a-finali.adb b/gcc/ada/a-finali.adb index cb04381d778..d6513ca07d4 100644 --- a/gcc/ada/a-finali.adb +++ b/gcc/ada/a-finali.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.10 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -51,6 +51,8 @@ package body Ada.Finalization is ------------ procedure Adjust (Object : in out Controlled) is + pragma Warnings (Off, Object); + begin null; end Adjust; @@ -60,11 +62,15 @@ package body Ada.Finalization is -------------- procedure Finalize (Object : in out Controlled) is + pragma Warnings (Off, Object); + begin null; end Finalize; procedure Finalize (Object : in out Limited_Controlled) is + pragma Warnings (Off, Object); + begin null; end Finalize; @@ -74,11 +80,15 @@ package body Ada.Finalization is ---------------- procedure Initialize (Object : in out Controlled) is + pragma Warnings (Off, Object); + begin null; end Initialize; procedure Initialize (Object : in out Limited_Controlled) is + pragma Warnings (Off, Object); + begin null; end Initialize; diff --git a/gcc/ada/a-ncelfu.ads b/gcc/ada/a-ncelfu.ads index 089ee09a66d..f45e84a72f1 100644 --- a/gcc/ada/a-ncelfu.ads +++ b/gcc/ada/a-ncelfu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.3 $ -- +-- $Revision$ -- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- @@ -21,3 +21,5 @@ with Ada.Numerics.Generic_Complex_Elementary_Functions; package Ada.Numerics.Complex_Elementary_Functions is new Ada.Numerics.Generic_Complex_Elementary_Functions (Ada.Numerics.Complex_Types); + +pragma Pure (Ada.Numerics.Complex_Elementary_Functions); diff --git a/gcc/ada/a-reatim.adb b/gcc/ada/a-reatim.adb index 1d9048951c3..155e2715715 100644 --- a/gcc/ada/a-reatim.adb +++ b/gcc/ada/a-reatim.adb @@ -8,7 +8,7 @@ -- -- -- $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- -- @@ -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). -- -- -- ------------------------------------------------------------------------------ @@ -46,11 +45,13 @@ package body Ada.Real_Time is -- Note that Constraint_Error may be propagated function "*" (Left : Time_Span; Right : Integer) return Time_Span is + pragma Unsuppress (Overflow_Check); begin return Time_Span (Duration (Left) * Right); end "*"; function "*" (Left : Integer; Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); begin return Time_Span (Left * Duration (Right)); end "*"; @@ -62,16 +63,19 @@ package body Ada.Real_Time is -- Note that Constraint_Error may be propagated function "+" (Left : Time; Right : Time_Span) return Time is + pragma Unsuppress (Overflow_Check); begin return Time (Duration (Left) + Duration (Right)); end "+"; function "+" (Left : Time_Span; Right : Time) return Time is + pragma Unsuppress (Overflow_Check); begin return Time (Duration (Left) + Duration (Right)); end "+"; function "+" (Left, Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); begin return Time_Span (Duration (Left) + Duration (Right)); end "+"; @@ -83,21 +87,25 @@ package body Ada.Real_Time is -- Note that Constraint_Error may be propagated function "-" (Left : Time; Right : Time_Span) return Time is + pragma Unsuppress (Overflow_Check); begin return Time (Duration (Left) - Duration (Right)); end "-"; function "-" (Left, Right : Time) return Time_Span is + pragma Unsuppress (Overflow_Check); begin return Time_Span (Duration (Left) - Duration (Right)); end "-"; function "-" (Left, Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); begin return Time_Span (Duration (Left) - Duration (Right)); end "-"; function "-" (Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); begin return Time_Span_Zero - Right; end "-"; @@ -109,11 +117,13 @@ package body Ada.Real_Time is -- Note that Constraint_Error may be propagated function "/" (Left, Right : Time_Span) return Integer is + pragma Unsuppress (Overflow_Check); begin return Integer (Duration (Left) / Duration (Right)); end "/"; function "/" (Left : Time_Span; Right : Integer) return Time_Span is + pragma Unsuppress (Overflow_Check); begin return Time_Span (Duration (Left) / Right); end "/"; @@ -190,7 +200,7 @@ package body Ada.Real_Time is SC := SC - 1; end if; - TS := T - Time (SC); + TS := Time_Span (Duration (T) - Duration (SC)); end Split; ------------- diff --git a/gcc/ada/a-retide.adb b/gcc/ada/a-retide.adb index 4f33a429f9d..9c64e96e0ac 100644 --- a/gcc/ada/a-retide.adb +++ b/gcc/ada/a-retide.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.28 $ +-- $Revision$ -- -- --- Copyright (C) 1991-1999 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,21 +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). -- -- -- ------------------------------------------------------------------------------ with System.Task_Primitives.Operations; -- Used for Timed_Delay -with System.OS_Primitives; --- Used for Delay_Modes - package body Ada.Real_Time.Delays is package STPO renames System.Task_Primitives.Operations; - package OSP renames System.OS_Primitives; + + Absolute_RT : constant := 2; ----------------- -- Delay_Until -- @@ -51,7 +48,7 @@ package body Ada.Real_Time.Delays is procedure Delay_Until (T : Time) is begin - STPO.Timed_Delay (STPO.Self, To_Duration (T), OSP.Absolute_RT); + STPO.Timed_Delay (STPO.Self, To_Duration (T), Absolute_RT); end Delay_Until; ----------------- diff --git a/gcc/ada/a-stream.ads b/gcc/ada/a-stream.ads index c05c0b45962..c0818c3c1a8 100644 --- a/gcc/ada/a-stream.ads +++ b/gcc/ada/a-stream.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.9 $ -- +-- $Revision$ -- -- --- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -53,7 +53,7 @@ pragma Pure (Streams); Stream_Element_Offset range 0 .. Stream_Element_Offset'Last; type Stream_Element_Array is - array (Stream_Element_Offset range <>) of Stream_Element; + array (Stream_Element_Offset range <>) of aliased Stream_Element; procedure Read (Stream : in out Root_Stream_Type; diff --git a/gcc/ada/a-ststio.adb b/gcc/ada/a-ststio.adb index f262b2ec990..eacf0c5f1d3 100644 --- a/gcc/ada/a-ststio.adb +++ b/gcc/ada/a-ststio.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.32 $ +-- $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- -- @@ -64,6 +64,8 @@ package body Ada.Streams.Stream_IO is ------------------- function AFCB_Allocate (Control_Block : Stream_AFCB) return FCB.AFCB_Ptr is + pragma Warnings (Off, Control_Block); + begin return new Stream_AFCB; end AFCB_Allocate; @@ -75,6 +77,8 @@ package body Ada.Streams.Stream_IO is -- No special processing required for closing Stream_IO file procedure AFCB_Close (File : access Stream_AFCB) is + pragma Warnings (Off, File); + begin null; end AFCB_Close; @@ -149,7 +153,7 @@ package body Ada.Streams.Stream_IO is -- Flush -- ----------- - procedure Flush (File : in out File_Type) is + procedure Flush (File : File_Type) is begin FIO.Flush (AP (File)); end Flush; @@ -261,10 +265,6 @@ package body Ada.Streams.Stream_IO is if File.Last_Op /= Op_Read or else File.Shared_Status = FCB.Yes then - if End_Of_File (File) then - raise End_Error; - end if; - Locked_Processing : begin SSL.Lock_Task.all; Set_Position (File); diff --git a/gcc/ada/a-ststio.ads b/gcc/ada/a-ststio.ads index 5f225ea970d..2c20a6fbe80 100644 --- a/gcc/ada/a-ststio.ads +++ b/gcc/ada/a-ststio.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.14 $ -- +-- $Revision$ -- -- --- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -128,7 +128,10 @@ package Ada.Streams.Stream_IO is procedure Set_Mode (File : in out File_Type; Mode : in File_Mode); - procedure Flush (File : in out File_Type); + -- Note: The parameter file is IN OUT in the RM, but this is clearly + -- an oversight, and was intended to be IN, see AI95-00057. + + procedure Flush (File : File_Type); ---------------- -- Exceptions -- diff --git a/gcc/ada/a-stwifi.adb b/gcc/ada/a-stwifi.adb index e998bcdbfae..900951e7428 100644 --- a/gcc/ada/a-stwifi.adb +++ b/gcc/ada/a-stwifi.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.17 $ -- +-- $Revision$ -- -- --- Copyright (C) 1992-1997 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,7 +33,6 @@ -- -- ------------------------------------------------------------------------------ - with Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps; with Ada.Strings.Wide_Search; @@ -158,9 +157,11 @@ package body Ada.Strings.Wide_Fixed is else declare - Result : constant Wide_String := - Source (Source'First .. From - 1) & - Source (Through + 1 .. Source'Last); + Len : constant Integer := Source'Length - (Through - From + 1); + Result : constant + Wide_String (Source'First .. Source'First + Len - 1) := + Source (Source'First .. From - 1) & + Source (Through + 1 .. Source'Last); begin return Result; end; @@ -381,13 +382,15 @@ package body Ada.Strings.Wide_Fixed is else declare Result_Length : Natural := - Natural'Max (Source'Length, - Position - Source'First + New_Item'Length); + Natural'Max + (Source'Length, + Position - Source'First + New_Item'Length); + Result : Wide_String (1 .. Result_Length); begin Result := Source (Source'First .. Position - 1) & New_Item & - Source (Position + New_Item'Length .. Source'Last); + Source (Position + New_Item'Length .. Source'Last); return Result; end; end if; diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index b11330d41cb..661c3099916 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.30 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -63,8 +63,6 @@ package body Ada.Tags is -- | tags | -- +-------------------+ - use System; - subtype Cstring is String (Positive); type Cstring_Ptr is access all Cstring; type Tag_Table is array (Natural range <>) of Tag; @@ -93,21 +91,20 @@ package body Ada.Tags is ------------------------------------------- function To_Type_Specific_Data_Ptr is - new Unchecked_Conversion (Address, Type_Specific_Data_Ptr); + new Unchecked_Conversion (S.Address, Type_Specific_Data_Ptr); - function To_Address is new Unchecked_Conversion (Tag, Address); function To_Address is - new Unchecked_Conversion (Type_Specific_Data_Ptr, Address); + new Unchecked_Conversion (Type_Specific_Data_Ptr, S.Address); --------------------------------------------- -- Unchecked Conversions for String Fields -- --------------------------------------------- function To_Cstring_Ptr is - new Unchecked_Conversion (Address, Cstring_Ptr); + new Unchecked_Conversion (S.Address, Cstring_Ptr); function To_Address is - new Unchecked_Conversion (Cstring_Ptr, Address); + new Unchecked_Conversion (Cstring_Ptr, S.Address); ----------------------- -- Local Subprograms -- @@ -130,8 +127,8 @@ package body Ada.Tags is package HTable_Subprograms is procedure Set_HT_Link (T : Tag; Next : Tag); function Get_HT_Link (T : Tag) return Tag; - function Hash (F : Address) return HTable_Headers; - function Equal (A, B : Address) return Boolean; + function Hash (F : S.Address) return HTable_Headers; + function Equal (A, B : S.Address) return Boolean; end HTable_Subprograms; package External_Tag_HTable is new GNAT.HTable.Static_HTable ( @@ -141,7 +138,7 @@ package body Ada.Tags is Null_Ptr => null, Set_Next => HTable_Subprograms.Set_HT_Link, Next => HTable_Subprograms.Get_HT_Link, - Key => Address, + Key => S.Address, Get_Key => Get_External_Tag, Hash => HTable_Subprograms.Hash, Equal => HTable_Subprograms.Equal); @@ -158,7 +155,7 @@ package body Ada.Tags is -- Equal -- ----------- - function Equal (A, B : Address) return Boolean is + function Equal (A, B : S.Address) return Boolean is Str1 : Cstring_Ptr := To_Cstring_Ptr (A); Str2 : Cstring_Ptr := To_Cstring_Ptr (B); J : Integer := 1; @@ -190,7 +187,7 @@ package body Ada.Tags is -- Hash -- ---------- - function Hash (F : Address) return HTable_Headers is + function Hash (F : S.Address) return HTable_Headers is function H is new GNAT.HTable.Hash (HTable_Headers); Str : Cstring_Ptr := To_Cstring_Ptr (F); Res : constant HTable_Headers := H (Str (1 .. Length (Str))); @@ -262,7 +259,7 @@ package body Ada.Tags is -- Get_Expanded_Name -- ----------------------- - function Get_Expanded_Name (T : Tag) return Address is + function Get_Expanded_Name (T : Tag) return S.Address is begin return To_Address (T.TSD.Expanded_Name); end Get_Expanded_Name; @@ -271,7 +268,7 @@ package body Ada.Tags is -- Get_External_Tag -- ---------------------- - function Get_External_Tag (T : Tag) return Address is + function Get_External_Tag (T : Tag) return S.Address is begin return To_Address (T.TSD.External_Tag); end Get_External_Tag; @@ -292,7 +289,7 @@ package body Ada.Tags is function Get_Prim_Op_Address (T : Tag; Position : Positive) - return Address + return S.Address is begin return T.Prims_Ptr (Position); @@ -320,7 +317,7 @@ package body Ada.Tags is -- Get_TSD -- ------------- - function Get_TSD (T : Tag) return Address is + function Get_TSD (T : Tag) return S.Address is begin return To_Address (T.TSD); end Get_TSD; @@ -345,7 +342,7 @@ package body Ada.Tags is -- Inherit_TSD -- ----------------- - procedure Inherit_TSD (Old_TSD : Address; New_Tag : Tag) is + procedure Inherit_TSD (Old_TSD : S.Address; New_Tag : Tag) is TSD : constant Type_Specific_Data_Ptr := To_Type_Specific_Data_Ptr (Old_TSD); New_TSD : Type_Specific_Data renames New_Tag.TSD.all; @@ -422,14 +419,14 @@ package body Ada.Tags is type T_Ptr is access all T; - function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr); + function To_T_Ptr is new Unchecked_Conversion (S.Address, T_Ptr); -- The profile of the implicitly defined _size primitive - type Acc_Size is access function (A : Address) return Long_Long_Integer; - function To_Acc_Size is new Unchecked_Conversion (Address, Acc_Size); + type Acc_Size is access function (A : S.Address) return Long_Long_Integer; + function To_Acc_Size is new Unchecked_Conversion (S.Address, Acc_Size); - function Parent_Size (Obj : Address) return SSE.Storage_Count is + function Parent_Size (Obj : S.Address) return SSE.Storage_Count is -- Get the tag of the object @@ -463,7 +460,7 @@ package body Ada.Tags is -- Set_Expanded_Name -- ----------------------- - procedure Set_Expanded_Name (T : Tag; Value : Address) is + procedure Set_Expanded_Name (T : Tag; Value : S.Address) is begin T.TSD.Expanded_Name := To_Cstring_Ptr (Value); end Set_Expanded_Name; @@ -472,7 +469,7 @@ package body Ada.Tags is -- Set_External_Tag -- ---------------------- - procedure Set_External_Tag (T : Tag; Value : Address) is + procedure Set_External_Tag (T : Tag; Value : S.Address) is begin T.TSD.External_Tag := To_Cstring_Ptr (Value); end Set_External_Tag; @@ -496,7 +493,7 @@ package body Ada.Tags is procedure Set_Prim_Op_Address (T : Tag; Position : Positive; - Value : Address) + Value : S.Address) is begin T.Prims_Ptr (Position) := Value; @@ -528,7 +525,7 @@ package body Ada.Tags is -- Set_TSD -- ------------- - procedure Set_TSD (T : Tag; Value : Address) is + procedure Set_TSD (T : Tag; Value : S.Address) is begin T.TSD := To_Type_Specific_Data_Ptr (Value); end Set_TSD; diff --git a/gcc/ada/a-tasatt.adb b/gcc/ada/a-tasatt.adb index 18c11d34d68..594bfec935e 100644 --- a/gcc/ada/a-tasatt.adb +++ b/gcc/ada/a-tasatt.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- --- Copyright (C) 1991-2000 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- -- @@ -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). -- -- -- ------------------------------------------------------------------------------ @@ -182,8 +181,7 @@ -- The latter initialization requires a list of all the instantiation -- descriptors. Updates to this list, as well as the bit-vector that -- is used to reserve slots for attributes in the TCB, require mutual --- exclusion. That is provided by the lock --- System.Tasking.Task_Attributes.All_Attrs_L. +-- exclusion. That is provided by the Lock/Unlock_RTS. -- One special problem that added complexity to the design is that -- the per-task list of indirect attributes contains objects of @@ -243,7 +241,7 @@ with System.Storage_Elements; with System.Task_Primitives.Operations; -- used for Write_Lock -- Unlock --- Lock/Unlock_All_Tasks_List +-- Lock/Unlock_RTS with System.Tasking; -- used for Access_Address @@ -301,6 +299,14 @@ package body Ada.Task_Attributes is type Wrapper; type Access_Wrapper is access all Wrapper; + pragma Warnings (Off); + -- We turn warnings off for the following declarations of the + -- To_Attribute_Handle conversions, since these are used only + -- for small attributes where we know that there are no problems + -- with alignment, but the compiler will generate warnings for + -- the occurrences in the large attribute case, even though + -- they will not actually be used. + function To_Attribute_Handle is new Unchecked_Conversion (Access_Address, Attribute_Handle); -- For reference to directly addressed task attributes @@ -312,6 +318,10 @@ package body Ada.Task_Attributes is (Access_Integer_Address, Attribute_Handle); -- For reference to directly addressed task attributes + pragma Warnings (On); + -- End of warnings off region for directly addressed + -- attribute conversion functions. + function To_Access_Address is new Unchecked_Conversion (Access_Node, Access_Address); -- To store pointer to list of indirect attributes @@ -320,9 +330,15 @@ package body Ada.Task_Attributes is (Access_Address, Access_Node); -- To fetch pointer to list of indirect attributes + pragma Warnings (Off); function To_Access_Wrapper is new Unchecked_Conversion (Access_Dummy_Wrapper, Access_Wrapper); - -- To fetch pointer to actual wrapper of attribute node + pragma Warnings (On); + -- To fetch pointer to actual wrapper of attribute node. We turn off + -- warnings since this may generate an alignment warning. The warning + -- can be ignored since Dummy_Wrapper is only a non-generic standin + -- for the real wrapper type (we never actually allocate objects of + -- type Dummy_Wrapper). function To_Access_Dummy_Wrapper is new Unchecked_Conversion (Access_Wrapper, Access_Dummy_Wrapper); @@ -388,7 +404,7 @@ package body Ada.Task_Attributes is (T : Task_Identification.Task_Id := Task_Identification.Current_Task) return Attribute_Handle is - TT : Task_ID := To_Task_ID (T); + TT : Task_ID := To_Task_ID (T); Error_Message : constant String := "Trying to get the reference of a"; begin @@ -404,13 +420,24 @@ package body Ada.Task_Attributes is begin Defer_Abortion; - POP.Write_Lock (All_Attrs_L'Access); + POP.Lock_RTS; + + -- Directly addressed case if Local.Index /= 0 then - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; Undefer_Abortion; + + -- Return the attribute handle. Warnings off because this return + -- statement generates alignment warnings for large attributes + -- (but will never be executed in this case anyway). + + pragma Warnings (Off); return To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Access); + pragma Warnings (On); + + -- Not directly addressed else declare @@ -420,7 +447,7 @@ package body Ada.Task_Attributes is begin while P /= null loop if P.Instance = Access_Instance'(Local'Unchecked_Access) then - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; Undefer_Abortion; return To_Access_Wrapper (P.Wrapper).Value'Access; end if; @@ -428,20 +455,20 @@ package body Ada.Task_Attributes is P := P.Next; end loop; - -- Unlock All_Attrs_L here to follow the lock ordering rule + -- Unlock the RTS here to follow the lock ordering rule -- that prevent us from using new (i.e the Global_Lock) while -- holding any other lock. - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; W := new Wrapper' ((null, Local'Unchecked_Access, null), Initial_Value); - POP.Write_Lock (All_Attrs_L'Access); + POP.Lock_RTS; P := W.Noed'Unchecked_Access; P.Wrapper := To_Access_Dummy_Wrapper (W); P.Next := To_Access_Node (TT.Indirect_Attributes); TT.Indirect_Attributes := To_Access_Address (P); - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; Undefer_Abortion; return W.Value'Access; end; @@ -452,7 +479,7 @@ package body Ada.Task_Attributes is exception when others => - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; Undefer_Abortion; raise; end; @@ -493,9 +520,9 @@ package body Ada.Task_Attributes is begin Defer_Abortion; - POP.Write_Lock (All_Attrs_L'Access); - + POP.Lock_RTS; Q := To_Access_Node (TT.Indirect_Attributes); + while Q /= null loop if Q.Instance = Access_Instance'(Local'Unchecked_Access) then if P = null then @@ -506,7 +533,7 @@ package body Ada.Task_Attributes is W := To_Access_Wrapper (Q.Wrapper); Free (W); - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; Undefer_Abortion; return; end if; @@ -515,12 +542,12 @@ package body Ada.Task_Attributes is Q := Q.Next; end loop; - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; Undefer_Abortion; exception when others => - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; Undefer_Abortion; end; @@ -560,15 +587,27 @@ package body Ada.Task_Attributes is begin Defer_Abortion; - POP.Write_Lock (All_Attrs_L'Access); + POP.Lock_RTS; + + -- Directly addressed case if Local.Index /= 0 then + + -- Set attribute handle, warnings off, because this code can + -- generate alignment warnings with large attributes (but of + -- course wil not be executed in this case, since we never + -- have direct addressing in such cases). + + pragma Warnings (Off); To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Access).all := Val; - POP.Unlock (All_Attrs_L'Access); + pragma Warnings (On); + POP.Unlock_RTS; Undefer_Abortion; return; + -- Not directly addressed + else declare P : Access_Node := To_Access_Node (TT.Indirect_Attributes); @@ -579,7 +618,7 @@ package body Ada.Task_Attributes is if P.Instance = Access_Instance'(Local'Unchecked_Access) then To_Access_Wrapper (P.Wrapper).Value := Val; - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; Undefer_Abortion; return; end if; @@ -587,15 +626,14 @@ package body Ada.Task_Attributes is P := P.Next; end loop; - -- Unlock TT here to follow the lock ordering rule that + -- Unlock RTS here to follow the lock ordering rule that -- prevent us from using new (i.e the Global_Lock) while -- holding any other lock. - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; W := new Wrapper' ((null, Local'Unchecked_Access, null), Val); - POP.Write_Lock (All_Attrs_L'Access); - + POP.Lock_RTS; P := W.Noed'Unchecked_Access; P.Wrapper := To_Access_Dummy_Wrapper (W); P.Next := To_Access_Node (TT.Indirect_Attributes); @@ -603,12 +641,12 @@ package body Ada.Task_Attributes is end; end if; - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; Undefer_Abortion; exception when others => - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; Undefer_Abortion; raise; end; @@ -648,10 +686,22 @@ package body Ada.Task_Attributes is end if; begin + -- Directly addressed case + if Local.Index /= 0 then + + -- Get value of attribute. Warnings off, because for large + -- attributes, this code can generate alignment warnings. + -- But of course large attributes are never directly addressed + -- so in fact we will never execute the code in this case. + + pragma Warnings (Off); Result := To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Access).all; + pragma Warnings (On); + + -- Not directly addressed else declare @@ -659,12 +709,12 @@ package body Ada.Task_Attributes is begin Defer_Abortion; - POP.Write_Lock (All_Attrs_L'Access); - + POP.Lock_RTS; P := To_Access_Node (TT.Indirect_Attributes); + while P /= null loop if P.Instance = Access_Instance'(Local'Unchecked_Access) then - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; Undefer_Abortion; return To_Access_Wrapper (P.Wrapper).Value; end if; @@ -673,12 +723,12 @@ package body Ada.Task_Attributes is end loop; Result := Initial_Value; - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; Undefer_Abortion; exception when others => - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; Undefer_Abortion; raise; end; @@ -707,11 +757,15 @@ begin pragma Warnings (On); declare - Two_To_J : Direct_Index_Vector; - + Two_To_J : Direct_Index_Vector; begin Defer_Abortion; - POP.Write_Lock (All_Attrs_L'Access); + + -- Need protection for updating links to per-task initialization and + -- finalization routines, in case some task is being created or + -- terminated concurrently. + + POP.Lock_RTS; -- Add this instantiation to the list of all instantiations. @@ -749,12 +803,6 @@ begin end loop; end if; - -- Need protection of All_Tasks_L for updating links to - -- per-task initialization and finalization routines, - -- in case some task is being created or terminated concurrently. - - POP.Lock_All_Tasks_List; - -- Attribute goes directly in the TCB if Local.Index /= 0 then @@ -791,8 +839,7 @@ begin end if; - POP.Unlock_All_Tasks_List; - POP.Unlock (All_Attrs_L'Access); + POP.Unlock_RTS; Undefer_Abortion; exception @@ -804,5 +851,4 @@ begin -- any initializations that succeeded up to this point, or we will -- risk a dangling reference when the task terminates. end; - end Ada.Task_Attributes; diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb index 36a6a167ba8..d8e156cb133 100644 --- a/gcc/ada/a-textio.adb +++ b/gcc/ada/a-textio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.81 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -58,6 +58,8 @@ package body Ada.Text_IO is ------------------- function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr is + pragma Warnings (Off, Control_Block); + begin return new Text_AFCB; end AFCB_Allocate; diff --git a/gcc/ada/a-tideau.adb b/gcc/ada/a-tideau.adb index d8ccce01b27..48593ce4797 100644 --- a/gcc/ada/a-tideau.adb +++ b/gcc/ada/a-tideau.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.12 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -68,7 +68,7 @@ package body Ada.Text_IO.Decimal_Aux is end if; Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); - Check_End_Of_Field (File, Buf, Stop, Ptr, Width); + Check_End_Of_Field (Buf, Stop, Ptr, Width); return Item; end Get_Dec; @@ -97,7 +97,7 @@ package body Ada.Text_IO.Decimal_Aux is end if; Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); - Check_End_Of_Field (File, Buf, Stop, Ptr, Width); + Check_End_Of_Field (Buf, Stop, Ptr, Width); return Item; end Get_LLD; diff --git a/gcc/ada/a-tiflau.adb b/gcc/ada/a-tiflau.adb index edd3f9c5c84..685de685083 100644 --- a/gcc/ada/a-tiflau.adb +++ b/gcc/ada/a-tiflau.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.16 $ -- +-- $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- -- @@ -63,7 +63,7 @@ package body Ada.Text_IO.Float_Aux is Item := Scan_Real (Buf, Ptr'Access, Stop); - Check_End_Of_Field (File, Buf, Stop, Ptr, Width); + Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get; ---------- diff --git a/gcc/ada/a-tigeau.adb b/gcc/ada/a-tigeau.adb index f3c67af8246..82e9a0372ec 100644 --- a/gcc/ada/a-tigeau.adb +++ b/gcc/ada/a-tigeau.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.17 $ +-- $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- -- @@ -48,8 +48,7 @@ package body Ada.Text_IO.Generic_Aux is ------------------------ procedure Check_End_Of_Field - (File : File_Type; - Buf : String; + (Buf : String; Stop : Integer; Ptr : Integer; Width : Field) diff --git a/gcc/ada/a-tigeau.ads b/gcc/ada/a-tigeau.ads index 448d6855112..19aa099130c 100644 --- a/gcc/ada/a-tigeau.ads +++ b/gcc/ada/a-tigeau.ads @@ -46,8 +46,7 @@ private package Ada.Text_IO.Generic_Aux is -- so one of these two routines must be called first. procedure Check_End_Of_Field - (File : File_Type; - Buf : String; + (Buf : String; Stop : Integer; Ptr : Integer; Width : Field); diff --git a/gcc/ada/a-tiinau.adb b/gcc/ada/a-tiinau.adb index 3e44a206b89..0e7c443a121 100644 --- a/gcc/ada/a-tiinau.adb +++ b/gcc/ada/a-tiinau.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.9 $ +-- $Revision$ -- -- --- Copyright (C) 1992-1999 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- -- @@ -80,7 +80,7 @@ package body Ada.Text_IO.Integer_Aux is end if; Item := Scan_Integer (Buf, Ptr'Access, Stop); - Check_End_Of_Field (File, Buf, Stop, Ptr, Width); + Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_Int; ------------- @@ -105,7 +105,7 @@ package body Ada.Text_IO.Integer_Aux is end if; Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); - Check_End_Of_Field (File, Buf, Stop, Ptr, Width); + Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_LLI; -------------- diff --git a/gcc/ada/a-timoau.adb b/gcc/ada/a-timoau.adb index 78425b812aa..cb11a06d206 100644 --- a/gcc/ada/a-timoau.adb +++ b/gcc/ada/a-timoau.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.10 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -82,7 +82,7 @@ package body Ada.Text_IO.Modular_Aux is end if; Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (File, Buf, Stop, Ptr, Width); + Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_LLU; ------------- @@ -107,7 +107,7 @@ package body Ada.Text_IO.Modular_Aux is end if; Item := Scan_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (File, Buf, Stop, Ptr, Width); + Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_Uns; -------------- diff --git a/gcc/ada/a-witeio.adb b/gcc/ada/a-witeio.adb index ce3612051e3..b464b3e47aa 100644 --- a/gcc/ada/a-witeio.adb +++ b/gcc/ada/a-witeio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.25 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -88,6 +88,8 @@ package body Ada.Wide_Text_IO is (Control_Block : Wide_Text_AFCB) return FCB.AFCB_Ptr is + pragma Warnings (Off, Control_Block); + begin return new Wide_Text_AFCB; end AFCB_Allocate; diff --git a/gcc/ada/a-wtdeau.adb b/gcc/ada/a-wtdeau.adb index 830c93c93b7..9ea4978076e 100644 --- a/gcc/ada/a-wtdeau.adb +++ b/gcc/ada/a-wtdeau.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.3 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -68,7 +68,7 @@ package body Ada.Wide_Text_IO.Decimal_Aux is end if; Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); - Check_End_Of_Field (File, Buf, Stop, Ptr, Width); + Check_End_Of_Field (Buf, Stop, Ptr, Width); return Item; end Get_Dec; @@ -97,7 +97,7 @@ package body Ada.Wide_Text_IO.Decimal_Aux is end if; Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); - Check_End_Of_Field (File, Buf, Stop, Ptr, Width); + Check_End_Of_Field (Buf, Stop, Ptr, Width); return Item; end Get_LLD; diff --git a/gcc/ada/a-wtenau.adb b/gcc/ada/a-wtenau.adb index ddbbee9eab9..1aa1afe1e4c 100644 --- a/gcc/ada/a-wtenau.adb +++ b/gcc/ada/a-wtenau.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.6 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -48,8 +48,7 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is ----------------------- procedure Store_Char - (File : File_Type; - WC : Wide_Character; + (WC : Wide_Character; Buf : out Wide_String; Ptr : in out Integer); -- Store a single character in buffer, checking for overflow. @@ -59,7 +58,6 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is -- least in the OS/2 version. function To_Lower (C : Character) return Character; - function To_Upper (C : Character) return Character; ------------------ -- Get_Enum_Lit -- @@ -83,7 +81,7 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is if ch = Character'Pos (''') then Get (File, WC); - Store_Char (File, WC, Buf, Buflen); + Store_Char (WC, Buf, Buflen); ch := Nextc (TFT (File)); @@ -92,7 +90,7 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is end if; Get (File, WC); - Store_Char (File, WC, Buf, Buflen); + Store_Char (WC, Buf, Buflen); ch := Nextc (TFT (File)); @@ -101,7 +99,7 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is end if; Get (File, WC); - Store_Char (File, WC, Buf, Buflen); + Store_Char (WC, Buf, Buflen); -- Similarly for identifiers, read as far as we can, in particular, -- do read a trailing underscore (again see ACVC test CE3905L to @@ -121,7 +119,7 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is loop Get (File, WC); - Store_Char (File, WC, Buf, Buflen); + Store_Char (WC, Buf, Buflen); ch := Nextc (TFT (File)); @@ -328,8 +326,7 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is ---------------- procedure Store_Char - (File : File_Type; - WC : Wide_Character; + (WC : Wide_Character; Buf : out Wide_String; Ptr : in out Integer) is @@ -355,17 +352,4 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is end if; end To_Lower; - -------------- - -- To_Upper -- - -------------- - - function To_Upper (C : Character) return Character is - begin - if C in 'a' .. 'z' then - return Character'Val (Character'Pos (C) - 32); - else - return C; - end if; - end To_Upper; - end Ada.Wide_Text_IO.Enumeration_Aux; diff --git a/gcc/ada/a-wtflau.adb b/gcc/ada/a-wtflau.adb index e4331c4b961..8122d9166a0 100644 --- a/gcc/ada/a-wtflau.adb +++ b/gcc/ada/a-wtflau.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.4 $ -- +-- $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- -- @@ -63,7 +63,7 @@ package body Ada.Wide_Text_IO.Float_Aux is Item := Scan_Real (Buf, Ptr'Access, Stop); - Check_End_Of_Field (File, Buf, Stop, Ptr, Width); + Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get; ---------- diff --git a/gcc/ada/a-wtgeau.adb b/gcc/ada/a-wtgeau.adb index cc10554ce60..d539f46bcc6 100644 --- a/gcc/ada/a-wtgeau.adb +++ b/gcc/ada/a-wtgeau.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $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- -- @@ -48,8 +48,7 @@ package body Ada.Wide_Text_IO.Generic_Aux is ------------------------ procedure Check_End_Of_Field - (File : File_Type; - Buf : String; + (Buf : String; Stop : Integer; Ptr : Integer; Width : Field) diff --git a/gcc/ada/a-wtgeau.ads b/gcc/ada/a-wtgeau.ads index f6fd42d6d87..59b6e37bb49 100644 --- a/gcc/ada/a-wtgeau.ads +++ b/gcc/ada/a-wtgeau.ads @@ -52,8 +52,7 @@ package Ada.Wide_Text_IO.Generic_Aux is -- so one of these two routines must be called first. procedure Check_End_Of_Field - (File : File_Type; - Buf : String; + (Buf : String; Stop : Integer; Ptr : Integer; Width : Field); diff --git a/gcc/ada/a-wtinau.adb b/gcc/ada/a-wtinau.adb index 31027980228..ab3040b2bb6 100644 --- a/gcc/ada/a-wtinau.adb +++ b/gcc/ada/a-wtinau.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ -- +-- $Revision$ -- -- --- Copyright (C) 1992,1993,1994,1995,1996 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- -- @@ -80,7 +80,7 @@ package body Ada.Wide_Text_IO.Integer_Aux is end if; Item := Scan_Integer (Buf, Ptr'Access, Stop); - Check_End_Of_Field (File, Buf, Stop, Ptr, Width); + Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_Int; ------------- @@ -105,7 +105,7 @@ package body Ada.Wide_Text_IO.Integer_Aux is end if; Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); - Check_End_Of_Field (File, Buf, Stop, Ptr, Width); + Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_LLI; -------------- diff --git a/gcc/ada/a-wtmoau.adb b/gcc/ada/a-wtmoau.adb index 16e37db2d03..1ef8a603662 100644 --- a/gcc/ada/a-wtmoau.adb +++ b/gcc/ada/a-wtmoau.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.3 $ -- +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -82,7 +82,7 @@ package body Ada.Wide_Text_IO.Modular_Aux is end if; Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (File, Buf, Stop, Ptr, Width); + Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_LLU; ------------- @@ -107,7 +107,7 @@ package body Ada.Wide_Text_IO.Modular_Aux is end if; Item := Scan_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (File, Buf, Stop, Ptr, Width); + Check_End_Of_Field (Buf, Stop, Ptr, Width); end Get_Uns; -------------- diff --git a/gcc/ada/ada-tree.def b/gcc/ada/ada-tree.def index b583c935eec..4c1f6874623 100644 --- a/gcc/ada/ada-tree.def +++ b/gcc/ada/ada-tree.def @@ -6,7 +6,7 @@ * * * Specification * * * - * $Revision: 1.1 $ + * $Revision: 1.3 $ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * @@ -35,18 +35,11 @@ DEFTREECODE (TRANSFORM_EXPR, "transform_expr", 'e', 0) -/* Perform an unchecked conversion between the input and the output. - if TREE_ADDRESSABLE is set, it means this is in an LHS; in that case, - we can only use techniques, such as pointer punning, that leave the - expression a "name". */ - -DEFTREECODE (UNCHECKED_CONVERT_EXPR, "unchecked_convert_expr", '1', 1) - /* Dynamically allocate on the stack a number of bytes of memory given by operand 0 at the alignment given by operand 1 and return the address of the resulting memory. */ -DEFTREECODE (ALLOCATE_EXPR, "allocate_expr", '2', 2) +DEFTREECODE (ALLOCATE_EXPR, "allocate_expr", 's', 2) /* A type that is an unconstrained array itself. This node is never passed to GCC. TREE_TYPE is the type of the fat pointer and TYPE_OBJECT_RECORD_TYPE diff --git a/gcc/ada/ada-tree.h b/gcc/ada/ada-tree.h index 73e8d78102c..34a7a0255de 100644 --- a/gcc/ada/ada-tree.h +++ b/gcc/ada/ada-tree.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * $Revision: 1.1 $ + * $Revision$ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * @@ -115,17 +115,13 @@ enum gnat_tree_code { || TREE_CODE (NODE) == UNION_TYPE || TREE_CODE (NODE) == ENUMERAL_TYPE) \ && TYPE_DUMMY_P (NODE)) -/* Nonzero if this corresponds to a type where alignment is guaranteed - by other mechanisms (a tagged or packed type). */ -#define TYPE_ALIGN_OK_P(NODE) TYPE_LANG_FLAG_5 (NODE) - /* For an INTEGER_TYPE, nonzero if TYPE_ACTUAL_BOUNDS is present. */ #define TYPE_HAS_ACTUAL_BOUNDS_P(NODE) \ - TYPE_LANG_FLAG_6 (INTEGER_TYPE_CHECK (NODE)) + TYPE_LANG_FLAG_5 (INTEGER_TYPE_CHECK (NODE)) /* For a RECORD_TYPE, nonzero if this was made just to supply needed padding or alignment. */ -#define TYPE_IS_PADDING_P(NODE) TYPE_LANG_FLAG_6 (RECORD_TYPE_CHECK (NODE)) +#define TYPE_IS_PADDING_P(NODE) TYPE_LANG_FLAG_5 (RECORD_TYPE_CHECK (NODE)) /* This field is only defined for FUNCTION_TYPE nodes. If the Ada subprogram contains no parameters passed by copy in/copy out then this diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 8ce557ab8bd..2e40648418f 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -4,11 +4,11 @@ * * * A D A I N T * * * - * $Revision: 1.6 $ + * $Revision$ * * * C Implementation File * * * - * Copyright (C) 1992-2001, 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- * @@ -32,16 +32,16 @@ * * ****************************************************************************/ -/* This file contains those routines named by Import pragmas in packages */ -/* in the GNAT hierarchy (especially GNAT.OS_Lib) and in package Osint. */ -/* Many of the subprograms in OS_Lib import standard library calls */ -/* directly. This file contains all other routines. */ +/* This file contains those routines named by Import pragmas in + packages in the GNAT hierarchy (especially GNAT.OS_Lib) and in + package Osint. Many of the subprograms in OS_Lib import standard + library calls directly. This file contains all other routines. */ #ifdef __vxworks -/* No need to redefine exit here */ -#ifdef exit + +/* No need to redefine exit here. */ #undef exit -#endif + /* We want to use the POSIX variants of include files. */ #define POSIX #include "vxWorks.h" @@ -59,8 +59,9 @@ #include <fcntl.h> #include <time.h> -/* We don't have libiberty, so us malloc. */ +/* We don't have libiberty, so use malloc. */ #define xmalloc(S) malloc (S) +#define xrealloc(V,S) realloc (V,S) #else #include "config.h" #include "system.h" @@ -70,7 +71,7 @@ #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32) #elif defined (VMS) -/* Header files and definitions for __gnat_set_file_time_name. */ +/* Header files and definitions for __gnat_set_file_time_name. */ #include <rms.h> #include <atrdef.h> @@ -82,7 +83,7 @@ #include <string.h> #include <unixlib.h> -/* use native 64-bit arithmetic */ +/* Use native 64-bit arithmetic. */ #define unix_time_to_vms(X,Y) \ { unsigned long long reftime, tmptime = (X); \ $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \ @@ -109,10 +110,9 @@ static char *tryfile; struct vstring { short length; - char string [NAM$C_MAXRSS+1]; + char string[NAM$C_MAXRSS+1]; }; - #else #include <utime.h> #endif @@ -192,12 +192,12 @@ char __gnat_path_separator = PATH_SEPARATOR; ??? This should be part of a GNAT host-specific compiler file instead of being included in all user applications - as well. This is only a temporary work-around for 3.11b. */ + as well. This is only a temporary work-around for 3.11b. */ #ifndef GNAT_LIBRARY_TEMPLATE -#if defined(__EMX__) +#if defined (__EMX__) #define GNAT_LIBRARY_TEMPLATE "*.a" -#elif defined(VMS) +#elif defined (VMS) #define GNAT_LIBRARY_TEMPLATE "*.olb" #else #define GNAT_LIBRARY_TEMPLATE "lib*.a" @@ -206,8 +206,16 @@ char __gnat_path_separator = PATH_SEPARATOR; const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE; +/* This variable is used in hostparm.ads to say whether the host is a VMS + system. */ +#ifdef VMS +const int __gnat_vmsp = 1; +#else +const int __gnat_vmsp = 0; +#endif + /* The following macro HAVE_READDIR_R should be defined if the - system provides the routine readdir_r */ + system provides the routine readdir_r. */ #undef HAVE_READDIR_R void @@ -234,7 +242,7 @@ __gnat_to_gm_time (p_time, p_year, p_month, p_day, p_hours, p_mins, p_secs) *p_hours = res->tm_hour; *p_mins = res->tm_min; *p_secs = res->tm_sec; - } + } else *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0; } @@ -261,10 +269,9 @@ __gnat_readlink (path, buf, bufsiz) #endif } -/* Creates a symbolic link named newpath - which contains the string oldpath. - If newpath exists it will NOT be overwritten. - For Windows, OS/2, vxworks, Interix and VMS, always retur -1. */ +/* Creates a symbolic link named NEWPATH which contains the string OLDPATH. If + NEWPATH exists it will NOT be overwritten. For Windows, OS/2, VxWorks, + Interix and VMS, always return -1. */ int __gnat_symlink (oldpath, newpath) @@ -282,7 +289,7 @@ __gnat_symlink (oldpath, newpath) #endif } -/* Try to lock a file, return 1 if success */ +/* Try to lock a file, return 1 if success. */ #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32) @@ -293,14 +300,14 @@ __gnat_try_lock (dir, file) char *dir; char *file; { - char full_path [256]; + char full_path[256]; int fd; sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file); fd = open (full_path, O_CREAT | O_EXCL, 0600); - if (fd < 0) { + if (fd < 0) return 0; - } + close (fd); return 1; } @@ -315,7 +322,7 @@ __gnat_try_lock (dir, file) char *dir; char *file; { - char full_path [256]; + char full_path[256]; int fd; sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file); @@ -328,6 +335,7 @@ __gnat_try_lock (dir, file) } #else + /* Version using link(), more secure over NFS. */ int @@ -335,26 +343,26 @@ __gnat_try_lock (dir, file) char *dir; char *file; { - char full_path [256]; - char temp_file [256]; + char full_path[256]; + char temp_file[256]; struct stat stat_result; int fd; sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file); sprintf (temp_file, "%s-%d-%d", dir, getpid(), getppid ()); - /* Create the temporary file and write the process number */ + /* Create the temporary file and write the process number. */ fd = open (temp_file, O_CREAT | O_WRONLY, 0600); if (fd < 0) return 0; close (fd); - /* Link it with the new file */ + /* Link it with the new file. */ link (temp_file, full_path); /* Count the references on the old one. If we have a count of two, then - the link did succeed. Remove the temporary file before returning. */ + the link did succeed. Remove the temporary file before returning. */ __gnat_stat (temp_file, &stat_result); unlink (temp_file); return stat_result.st_nlink == 2; @@ -366,7 +374,7 @@ __gnat_try_lock (dir, file) int __gnat_get_maximum_file_name_length () { -#if defined(MSDOS) +#if defined (MSDOS) return 8; #elif defined (VMS) if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS")) @@ -378,24 +386,12 @@ __gnat_get_maximum_file_name_length () #endif } -/* Return the default switch character. */ - -char -__gnat_get_switch_character () -{ - /* Under MSDOS, the switch character is not normally a hyphen, but this is - the convention DJGPP uses. Similarly under OS2, the switch character is - not normally a hypen, but this is the convention EMX uses. */ - - return '-'; -} - /* Return nonzero if file names are case sensitive. */ int __gnat_get_file_names_case_sensitive () { -#if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined(WINNT) +#if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT) return 0; #else return 1; @@ -412,7 +408,7 @@ __gnat_get_default_identifier_character_set () #endif } -/* Return the current working directory */ +/* Return the current working directory. */ void __gnat_get_current_dir (dir, length) @@ -428,12 +424,12 @@ __gnat_get_current_dir (dir, length) *length = strlen (dir); - dir [*length] = DIR_SEPARATOR; - ++(*length); - dir [*length] = '\0'; + dir[*length] = DIR_SEPARATOR; + ++*length; + dir[*length] = '\0'; } -/* Return the suffix for object files. */ +/* Return the suffix for object files. */ void __gnat_get_object_suffix_ptr (len, value) @@ -450,7 +446,7 @@ __gnat_get_object_suffix_ptr (len, value) return; } -/* Return the suffix for executable files */ +/* Return the suffix for executable files. */ void __gnat_get_executable_suffix_ptr (len, value) @@ -467,7 +463,7 @@ __gnat_get_executable_suffix_ptr (len, value) } /* Return the suffix for debuggable files. Usually this is the same as the - executable extension. */ + executable extension. */ void __gnat_get_debuggable_suffix_ptr (len, value) @@ -477,7 +473,7 @@ __gnat_get_debuggable_suffix_ptr (len, value) #ifndef MSDOS *value = HOST_EXECUTABLE_SUFFIX; #else - /* On DOS, the extensionless COFF file is what gdb likes. */ + /* On DOS, the extensionless COFF file is what gdb likes. */ *value = ""; #endif @@ -500,15 +496,16 @@ __gnat_open_read (path, fmode) if (fmode) o_fmode = O_TEXT; -#if defined(VMS) - /* Optional arguments mbc,deq,fop increase read performance */ +#if defined (VMS) + /* Optional arguments mbc,deq,fop increase read performance. */ fd = open (path, O_RDONLY | o_fmode, 0444, "mbc=16", "deq=64", "fop=tef"); -#elif defined(__vxworks) +#elif defined (__vxworks) fd = open (path, O_RDONLY | o_fmode, 0444); #else fd = open (path, O_RDONLY | o_fmode); #endif + return fd < 0 ? -1 : fd; } @@ -529,7 +526,7 @@ __gnat_open_rw (path, fmode) if (fmode) o_fmode = O_TEXT; -#if defined(VMS) +#if defined (VMS) fd = open (path, O_RDWR | o_fmode, PERM, "mbc=16", "deq=64", "fop=tef"); #else @@ -550,7 +547,7 @@ __gnat_open_create (path, fmode) if (fmode) o_fmode = O_TEXT; -#if defined(VMS) +#if defined (VMS) fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM, "mbc=16", "deq=64", "fop=tef"); #else @@ -571,7 +568,7 @@ __gnat_open_append (path, fmode) if (fmode) o_fmode = O_TEXT; -#if defined(VMS) +#if defined (VMS) fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM, "mbc=16", "deq=64", "fop=tef"); #else @@ -581,7 +578,7 @@ __gnat_open_append (path, fmode) return fd < 0 ? -1 : fd; } -/* Open a new file. Return error (-1) if the file already exists. */ +/* Open a new file. Return error (-1) if the file already exists. */ int __gnat_open_new (path, fmode) @@ -594,7 +591,7 @@ __gnat_open_new (path, fmode) if (fmode) o_fmode = O_TEXT; -#if defined(VMS) +#if defined (VMS) fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM, "mbc=16", "deq=64", "fop=tef"); #else @@ -605,9 +602,8 @@ __gnat_open_new (path, fmode) } /* Open a new temp file. Return error (-1) if the file already exists. - Special options for VMS allow the file to be shared between parent and - child processes, however they really slow down output. Used in - gnatchop. */ + Special options for VMS allow the file to be shared between parent and child + processes, however they really slow down output. Used in gnatchop. */ int __gnat_open_new_temp (path, fmode) @@ -631,7 +627,7 @@ __gnat_open_new_temp (path, fmode) if (fmode) o_fmode = O_TEXT; -#if defined(VMS) +#if defined (VMS) fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM, "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd", "mbc=16", "deq=64", "fop=tef"); @@ -642,25 +638,7 @@ __gnat_open_new_temp (path, fmode) return fd < 0 ? -1 : fd; } -int -__gnat_mkdir (dir_name) - char *dir_name; -{ - /* On some systems, mkdir has two args and on some it has one. If we - are being built as part of the compiler, autoconf has figured that out - for us. Otherwise, we have to do it ourselves. */ -#ifndef IN_RTS - return mkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO); -#else -#if defined (_WIN32) || defined (__vxworks) - return mkdir (dir_name); -#else - return mkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO); -#endif -#endif -} - -/* Return the number of bytes in the specified file. */ +/* Return the number of bytes in the specified file. */ long __gnat_file_length (fd) @@ -677,7 +655,7 @@ __gnat_file_length (fd) } /* Create a temporary filename and put it in string pointed to by - tmp_filename */ + TMP_FILENAME. */ void __gnat_tmp_name (tmp_filename) @@ -694,8 +672,8 @@ __gnat_tmp_name (tmp_filename) pname = (char *) tempnam ("c:\\temp", "gnat-"); - /* if pname start with a back slash and not path information it means that - the filename is valid for the current working directory */ + /* If pname start with a back slash and not path information it means that + the filename is valid for the current working directory. */ if (pname[0] == '\\') { @@ -707,6 +685,7 @@ __gnat_tmp_name (tmp_filename) free (pname); } + #elif defined (linux) char *tmpdir = getenv ("TMPDIR"); @@ -779,7 +758,7 @@ win32_filetime (h) FILETIME t_write; unsigned long long timestamp; - /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */ + /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */ unsigned long long offset = 11644473600; /* GetFileTime returns FILETIME data which are the number of 100 nanosecs @@ -821,7 +800,7 @@ __gnat_file_time_name (name) (void) __gnat_stat (name, &statbuf); #ifdef VMS - /* VMS has file versioning */ + /* VMS has file versioning. */ return statbuf.st_ctime; #else return statbuf.st_mtime; @@ -839,7 +818,7 @@ __gnat_file_time_fd (fd) DJGPP fstat attempts to convert time values to GMT rather than keep the actual OS timestamp of the file. By using the OS2/DOS functions directly the GNAT timestamp are independent of this behavior, which is desired to - facilitate the distribution of GNAT compiled libraries. */ + facilitate the distribution of GNAT compiled libraries. */ #if defined (__EMX__) || defined (MSDOS) #ifdef __EMX__ @@ -871,10 +850,10 @@ __gnat_file_time_fd (fd) the whole days passed. The value for years returned by the DOS and OS2 functions count years from 1980, so to compensate for the UNIX epoch which begins in 1970 start with 10 years worth of days and add days for each - four year period since then. */ + four year period since then. */ time_t tot_secs; - int cum_days [12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334}; + int cum_days[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334}; int days_passed = 3652 + (file_year / 4) * 1461; int years_since_leap = file_year % 4; @@ -888,13 +867,13 @@ __gnat_file_time_fd (fd) if (file_year > 20) days_passed -= 1; - days_passed += cum_days [file_month - 1]; + days_passed += cum_days[file_month - 1]; if (years_since_leap == 0 && file_year != 20 && file_month > 2) days_passed++; days_passed += file_day - 1; - /* OK - have whole days. Multiply -- then add in other parts. */ + /* OK - have whole days. Multiply -- then add in other parts. */ tot_secs = days_passed * 86400; tot_secs += file_hour * 3600; @@ -905,7 +884,6 @@ __gnat_file_time_fd (fd) #elif defined (_WIN32) HANDLE h = (HANDLE) _get_osfhandle (fd); time_t ret = win32_filetime (h); - CloseHandle (h); return ret; #else @@ -914,7 +892,7 @@ __gnat_file_time_fd (fd) (void) fstat (fd, &statbuf); #ifdef VMS - /* VMS has file versioning */ + /* VMS has file versioning. */ return statbuf.st_ctime; #else return statbuf.st_mtime; @@ -922,7 +900,7 @@ __gnat_file_time_fd (fd) #endif } -/* Set the file time stamp */ +/* Set the file time stamp. */ void __gnat_set_file_time_name (name, time_stamp) @@ -932,7 +910,7 @@ __gnat_set_file_time_name (name, time_stamp) #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32) \ || defined (__vxworks) -/* Code to implement __gnat_set_file_time_name for these systems. */ +/* Code to implement __gnat_set_file_time_name for these systems. */ #elif defined (VMS) struct FAB fab; @@ -953,15 +931,15 @@ __gnat_set_file_time_name (name, time_stamp) unsigned world : 4; } bits; } prot; - } Fat = { 0 }; + } Fat = { 0, 0, 0, 0, 0, { 0 }}; - ATRDEF atrlst [] + ATRDEF atrlst[] = { { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create }, { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise }, { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire }, { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup }, - n{ ATR$S_FPRO, ATR$C_FPRO, &Fat.prot }, + { ATR$S_FPRO, ATR$C_FPRO, &Fat.prot }, { ATR$S_UIC, ATR$C_UIC, &Fat.uic }, { 0, 0, 0} }; @@ -991,7 +969,7 @@ __gnat_set_file_time_name (name, time_stamp) tryfile = (char *) __gnat_to_host_dir_spec (name, 0); - /* Allocate and initialize a fab and nam structures. */ + /* Allocate and initialize a FAB and NAM structures. */ fab = cc$rms_fab; nam = cc$rms_nam; @@ -1003,22 +981,22 @@ __gnat_set_file_time_name (name, time_stamp) fab.fab$b_fns = strlen (tryfile); fab.fab$l_nam = &nam; - /*Validate filespec syntax and device existence. */ + /* Validate filespec syntax and device existence. */ status = SYS$PARSE (&fab, 0, 0); if ((status & 1) != 1) LIB$SIGNAL (status); - file.string [nam.nam$b_esl] = 0; + file.string[nam.nam$b_esl] = 0; - /* Find matching filespec. */ + /* Find matching filespec. */ status = SYS$SEARCH (&fab, 0, 0); if ((status & 1) != 1) LIB$SIGNAL (status); - file.string [nam.nam$b_esl] = 0; - result.string [result.length=nam.nam$b_rsl] = 0; + file.string[nam.nam$b_esl] = 0; + result.string[result.length=nam.nam$b_rsl] = 0; - /* Get the device name and assign an IO channel. */ + /* Get the device name and assign an IO channel. */ strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev); devicedsc.dsc$w_length = nam.nam$b_dev; chan = 0; @@ -1026,16 +1004,16 @@ __gnat_set_file_time_name (name, time_stamp) if ((status & 1) != 1) LIB$SIGNAL (status); - /* Initialize the FIB and fill in the directory id field. */ - bzero (&fib, sizeof (fib)); - fib.fib$w_did [0] = nam.nam$w_did [0]; - fib.fib$w_did [1] = nam.nam$w_did [1]; - fib.fib$w_did [2] = nam.nam$w_did [2]; + /* Initialize the FIB and fill in the directory id field. */ + memset (&fib, 0, sizeof (fib)); + fib.fib$w_did[0] = nam.nam$w_did[0]; + fib.fib$w_did[1] = nam.nam$w_did[1]; + fib.fib$w_did[2] = nam.nam$w_did[2]; fib.fib$l_acctl = 0; fib.fib$l_wcc = 0; strcpy (file.string, (strrchr (result.string, ']') + 1)); filedsc.dsc$w_length = strlen (file.string); - result.string [result.length = 0] = 0; + result.string[result.length = 0] = 0; /* Open and close the file to fill in the attributes. */ status @@ -1046,29 +1024,31 @@ __gnat_set_file_time_name (name, time_stamp) if ((iosb.status & 1) != 1) LIB$SIGNAL (iosb.status); - result.string [result.length] = 0; - status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, - &fibdsc, 0, 0, 0, &atrlst, 0); + result.string[result.length] = 0; + status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, &fibdsc, 0, 0, 0, + &atrlst, 0); if ((status & 1) != 1) LIB$SIGNAL (status); if ((iosb.status & 1) != 1) LIB$SIGNAL (iosb.status); - /* Set creation time to requested time */ - unix_time_to_vms (time_stamp, newtime); - { time_t t; struct tm *ts; + ts = localtime (&time_stamp); + + /* Set creation time to requested time. */ + unix_time_to_vms (time_stamp + ts->tm_gmtoff, newtime); + t = time ((time_t) 0); ts = localtime (&t); - /* Set revision time to now in local time. */ + /* Set revision time to now in local time. */ unix_time_to_vms (t + ts->tm_gmtoff, revtime); } - /* Reopen the file, modify the times and then close. */ + /* Reopen the file, modify the times and then close. */ fib.fib$l_acctl = FIB$M_WRITE; status = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0, @@ -1088,7 +1068,7 @@ __gnat_set_file_time_name (name, time_stamp) if ((iosb.status & 1) != 1) LIB$SIGNAL (iosb.status); - /* Deassign the channel and exit. */ + /* Deassign the channel and exit. */ status = SYS$DASSGN (chan); if ((status & 1) != 1) LIB$SIGNAL (status); @@ -1096,10 +1076,10 @@ __gnat_set_file_time_name (name, time_stamp) struct utimbuf utimbuf; time_t t; - /* Set modification time to requested time */ + /* Set modification time to requested time. */ utimbuf.modtime = time_stamp; - /* Set access time to now in local time */ + /* Set access time to now in local time. */ t = time ((time_t) 0); utimbuf.actime = mktime (localtime (&t)); @@ -1126,7 +1106,7 @@ __gnat_get_env_value_ptr (name, len, value) #ifdef VMS -static char *to_host_path_spec PROTO ((char *)); +static char *to_host_path_spec PARAMS ((char *)); struct descriptor_s { @@ -1152,7 +1132,7 @@ __gnat_set_env_value (name, value) #elif defined (VMS) struct descriptor_s name_desc; - /* Put in JOB table for now, so that the project stuff at least works */ + /* Put in JOB table for now, so that the project stuff at least works. */ struct descriptor_s table_desc = {7, 0, "LNM$JOB"}; char *host_pathspec = to_host_path_spec (value); char *copy_pathspec; @@ -1186,22 +1166,22 @@ __gnat_set_env_value (name, value) next = strchr (curr, 0); *next = 0; - ile_array [i].len = strlen (curr); + ile_array[i].len = strlen (curr); - /* Code 2 from lnmdef.h means its a string */ - ile_array [i].code = 2; - ile_array [i].adr = curr; + /* Code 2 from lnmdef.h means its a string. */ + ile_array[i].code = 2; + ile_array[i].adr = curr; - /* retlen_adr is ignored */ - ile_array [i].retlen_adr = 0; + /* retlen_adr is ignored. */ + ile_array[i].retlen_adr = 0; curr = next + 1; } - /* Terminating item must be zero */ - ile_array [i].len = 0; - ile_array [i].code = 0; - ile_array [i].adr = 0; - ile_array [i].retlen_adr = 0; + /* Terminating item must be zero. */ + ile_array[i].len = 0; + ile_array[i].code = 0; + ile_array[i].adr = 0; + ile_array[i].retlen_adr = 0; status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array); if ((status & 1) != 1) @@ -1291,19 +1271,19 @@ __gnat_stat (name, statbuf) /* Under Windows the directory name for the stat function must not be terminated by a directory separator except if just after a drive name. */ int name_len = strlen (name); - char last_char = name [name_len - 1]; - char win32_name [4096]; + char last_char = name[name_len - 1]; + char win32_name[4096]; strcpy (win32_name, name); while (name_len > 1 && (last_char == '\\' || last_char == '/')) { - win32_name [name_len - 1] = '\0'; + win32_name[name_len - 1] = '\0'; name_len--; last_char = win32_name[name_len - 1]; } - if (name_len == 2 && win32_name [1] == ':') + if (name_len == 2 && win32_name[1] == ':') strcat (win32_name, "\\"); return stat (win32_name, statbuf); @@ -1327,8 +1307,8 @@ __gnat_is_absolute_path (name) char *name; { return (*name == '/' || *name == DIR_SEPARATOR -#if defined(__EMX__) || defined(MSDOS) || defined(WINNT) - || strlen (name) > 1 && isalpha (name [0]) && name [1] == ':' +#if defined (__EMX__) || defined (MSDOS) || defined (WINNT) + || strlen (name) > 1 && isalpha (name[0]) && name[1] == ':' #endif ); } @@ -1369,7 +1349,7 @@ __gnat_is_writable_file (name) } #ifdef VMS -/* Defined in VMS header files */ +/* Defined in VMS header files. */ #define fork() (decc$$alloc_vfork_blocks() >= 0 ? \ LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1) #endif @@ -1390,47 +1370,52 @@ __gnat_portable_spawn (args) int pid; #if defined (MSDOS) || defined (_WIN32) - status = spawnvp (P_WAIT, args [0], args); + status = spawnvp (P_WAIT, args[0], args); if (status < 0) - return 4; + return -1; else return status; -#elif defined(__vxworks) /* Mods for VxWorks */ - pid = sp (args[0], args); /* Spawn process and save pid */ - if (pid == -1) - return (4); - - while (taskIdVerify(pid) >= 0) - /* Wait until spawned task is complete then continue. */ - ; +#elif defined (__vxworks) + return -1; #else #ifdef __EMX__ - pid = spawnvp (P_NOWAIT, args [0], args); + pid = spawnvp (P_NOWAIT, args[0], args); if (pid == -1) - return (4); + return -1; + #else pid = fork (); - if (pid == -1) - return (4); + if (pid < 0) + return -1; - if (pid == 0 && execv (args [0], args) != 0) - _exit (1); + if (pid == 0) + { + /* The child. */ + if (execv (args[0], args) != 0) +#if defined (VMS) + return -1; /* execv is in parent context on VMS. */ +#else + _exit (1); +#endif + } #endif - /* The parent */ + /* The parent. */ finished = waitpid (pid, &status, 0); if (finished != pid || WIFEXITED (status) == 0) - return 4; + return -1; return WEXITSTATUS (status); #endif + return 0; } -/* WIN32 code to implement a wait call that wait for any child process */ +/* WIN32 code to implement a wait call that wait for any child process. */ + #ifdef _WIN32 /* Synchronization code, to be thread safe. */ @@ -1449,7 +1434,7 @@ plist_enter () EnterCriticalSection (&plist_cs); } -void +static void plist_leave () { LeaveCriticalSection (&plist_cs); @@ -1527,10 +1512,20 @@ win32_no_block_spawn (command, args) STARTUPINFO SI; PROCESS_INFORMATION PI; SECURITY_ATTRIBUTES SA; - - char full_command [2000]; + int csize = 1; + char *full_command; int k; + /* compute the total command line length */ + k = 0; + while (args[k]) + { + csize += strlen (args[k]) + 1; + k++; + } + + full_command = (char *) xmalloc (csize); + /* Startup info. */ SI.cb = sizeof (STARTUPINFO); SI.lpReserved = NULL; @@ -1561,6 +1556,8 @@ win32_no_block_spawn (command, args) result = CreateProcess (NULL, (char *) full_command, &SA, NULL, TRUE, NORMAL_PRIORITY_CLASS, NULL, NULL, &SI, &PI); + free (full_command); + if (result == TRUE) { add_handle (PI.hProcess); @@ -1605,7 +1602,7 @@ win32_wait (status) plist_leave(); res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE); - h = hl [res - WAIT_OBJECT_0]; + h = hl[res - WAIT_OBJECT_0]; free (hl); remove_handle (h); @@ -1635,7 +1632,7 @@ __gnat_portable_no_block_spawn (args) portable_wait below systematically returns a pid of 0 and reports that the subprocess terminated successfully. */ - if (spawnvp (P_WAIT, args [0], args) != 0) + if (spawnvp (P_WAIT, args[0], args) != 0) return -1; #elif defined (_WIN32) @@ -1643,18 +1640,23 @@ __gnat_portable_no_block_spawn (args) pid = win32_no_block_spawn (args[0], args); return pid; -#elif defined (__vxworks) /* Mods for VxWorks */ - pid = sp (args[0], args); /* Spawn task and then return (no waiting) */ - if (pid == -1) - return (4); - - return pid; +#elif defined (__vxworks) + return -1; #else pid = fork (); - if (pid == 0 && execv (args [0], args) != 0) - _exit (1); + if (pid == 0) + { + /* The child. */ + if (execv (args[0], args) != 0) +#if defined (VMS) + return -1; /* execv is in parent context on VMS. */ +#else + _exit (1); +#endif + } + #endif return pid; @@ -1672,19 +1674,14 @@ __gnat_portable_wait (process_status) pid = win32_wait (&status); #elif defined (__EMX__) || defined (MSDOS) - /* ??? See corresponding comment in portable_no_block_spawn. */ + /* ??? See corresponding comment in portable_no_block_spawn. */ #elif defined (__vxworks) /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but - return zero. */ + return zero. */ #else -#ifdef VMS - /* Wait doesn't do the right thing on VMS */ pid = waitpid (-1, &status, 0); -#else - pid = wait (&status); -#endif status = status & 0xffff; #endif @@ -1692,19 +1689,37 @@ __gnat_portable_wait (process_status) return pid; } +int +__gnat_waitpid (pid) + int pid; +{ + int status = 0; + +#if defined (_WIN32) + cwait (&status, pid, _WAIT_CHILD); +#elif defined (__EMX__) || defined (MSDOS) || defined (__vxworks) + /* Status is already zero, so nothing to do. */ +#else + waitpid (pid, &status, 0); + status = WEXITSTATUS (status); +#endif + + return status; +} + void __gnat_os_exit (status) int status; { #ifdef VMS - /* Exit without changing 0 to 1 */ + /* Exit without changing 0 to 1. */ __posix_exit (status); #else exit (status); #endif } -/* Locate a regular file, give a Path value */ +/* Locate a regular file, give a Path value. */ char * __gnat_locate_regular_file (file_name, path_val) @@ -1713,13 +1728,13 @@ __gnat_locate_regular_file (file_name, path_val) { char *ptr; - /* Handle absolute pathnames. */ + /* Handle absolute pathnames. */ for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++) ; if (*ptr != 0 -#if defined(__EMX__) || defined(MSDOS) || defined(WINNT) - || isalpha (file_name [0]) && file_name [1] == ':' +#if defined (__EMX__) || defined (MSDOS) || defined (WINNT) + || isalpha (file_name[0]) && file_name[1] == ':' #endif ) { @@ -1761,10 +1776,9 @@ __gnat_locate_regular_file (file_name, path_val) return 0; } - /* Locate an executable given a Path argument. This routine is only used by gnatbl and should not be used otherwise. Use locate_exec_on_path - instead. */ + instead. */ char * __gnat_locate_exec (exec_name, path_val) @@ -1784,7 +1798,7 @@ __gnat_locate_exec (exec_name, path_val) return __gnat_locate_regular_file (exec_name, path_val); } -/* Locate an executable using the Systems default PATH */ +/* Locate an executable using the Systems default PATH. */ char * __gnat_locate_exec_on_path (exec_name) @@ -1804,45 +1818,45 @@ __gnat_locate_exec_on_path (exec_name) #ifdef VMS /* These functions are used to translate to and from VMS and Unix syntax - file, directory and path specifications. */ + file, directory and path specifications. */ #define MAXNAMES 256 #define NEW_CANONICAL_FILELIST_INCREMENT 64 -static char new_canonical_dirspec [255]; -static char new_canonical_filespec [255]; -static char new_canonical_pathspec [MAXNAMES*255]; +static char new_canonical_dirspec[255]; +static char new_canonical_filespec[255]; +static char new_canonical_pathspec[MAXNAMES*255]; static unsigned new_canonical_filelist_index; static unsigned new_canonical_filelist_in_use; static unsigned new_canonical_filelist_allocated; static char **new_canonical_filelist; -static char new_host_pathspec [MAXNAMES*255]; -static char new_host_dirspec [255]; -static char new_host_filespec [255]; +static char new_host_pathspec[MAXNAMES*255]; +static char new_host_dirspec[255]; +static char new_host_filespec[255]; /* Routine is called repeatedly by decc$from_vms via - __gnat_to_canonical_file_list_init until it returns 0 or the expansion - runs out. */ + __gnat_to_canonical_file_list_init until it returns 0 or the expansion runs + out. */ static int wildcard_translate_unix (name) char *name; { char *ver; - char buff [256]; + char buff[256]; strcpy (buff, name); ver = strrchr (buff, '.'); - /* Chop off the version */ + /* Chop off the version. */ if (ver) *ver = 0; - /* Dynamically extend the allocation by the increment */ + /* Dynamically extend the allocation by the increment. */ if (new_canonical_filelist_in_use == new_canonical_filelist_allocated) { new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT; - new_canonical_filelist = (char **) realloc + new_canonical_filelist = (char **) xrealloc (new_canonical_filelist, new_canonical_filelist_allocated * sizeof (char *)); } @@ -1852,10 +1866,9 @@ wildcard_translate_unix (name) return 1; } -/* Translate a wildcard VMS file spec into a list of Unix file - specs. First do full translation and copy the results into a list (_init), - then return them one at a time (_next). If onlydirs set, only expand - directory files. */ +/* Translate a wildcard VMS file spec into a list of Unix file specs. First do + full translation and copy the results into a list (_init), then return them + one at a time (_next). If onlydirs set, only expand directory files. */ int __gnat_to_canonical_file_list_init (filespec, onlydirs) @@ -1863,18 +1876,18 @@ __gnat_to_canonical_file_list_init (filespec, onlydirs) int onlydirs; { int len; - char buff [256]; + char buff[256]; len = strlen (filespec); strcpy (buff, filespec); - /* Only look for directories */ - if (onlydirs && !strstr (&buff [len-5], "*.dir")) + /* Only look for directories. */ + if (onlydirs && !strstr (&buff[len - 5], "*.dir")) strcat (buff, "*.dir"); decc$from_vms (buff, wildcard_translate_unix, 1); - /* Remove the .dir extension */ + /* Remove the .dir extension. */ if (onlydirs) { int i; @@ -1882,7 +1895,7 @@ __gnat_to_canonical_file_list_init (filespec, onlydirs) for (i = 0; i < new_canonical_filelist_in_use; i++) { - ext = strstr (new_canonical_filelist [i], ".dir"); + ext = strstr (new_canonical_filelist[i], ".dir"); if (ext) *ext = 0; } @@ -1891,15 +1904,15 @@ __gnat_to_canonical_file_list_init (filespec, onlydirs) return new_canonical_filelist_in_use; } -/* Return the next filespec in the list */ +/* Return the next filespec in the list. */ char * __gnat_to_canonical_file_list_next () { - return new_canonical_filelist [new_canonical_filelist_index++]; + return new_canonical_filelist[new_canonical_filelist_index++]; } -/* Free up storage used in the wildcard expansion */ +/* Free storage used in the wildcard expansion. */ void __gnat_to_canonical_file_list_free () @@ -1907,7 +1920,7 @@ __gnat_to_canonical_file_list_free () int i; for (i = 0; i < new_canonical_filelist_in_use; i++) - free (new_canonical_filelist [i]); + free (new_canonical_filelist[i]); free (new_canonical_filelist); @@ -1917,13 +1930,13 @@ __gnat_to_canonical_file_list_free () new_canonical_filelist = 0; } -/* Translate a VMS syntax directory specification in to Unix syntax. - If prefixflag is set, append an underscore "/". If no indicators - of VMS syntax found, return input string. Also translate a dirname - that contains no slashes, in case it's a logical name. */ +/* Translate a VMS syntax directory specification in to Unix syntax. If + PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax + found, return input string. Also translate a dirname that contains no + slashes, in case it's a logical name. */ char * -__gnat_to_canonical_dir_spec (dirspec,prefixflag) +__gnat_to_canonical_dir_spec (dirspec, prefixflag) char *dirspec; int prefixflag; { @@ -1943,7 +1956,7 @@ __gnat_to_canonical_dir_spec (dirspec,prefixflag) } len = strlen (new_canonical_dirspec); - if (prefixflag && new_canonical_dirspec [len-1] != '/') + if (prefixflag && new_canonical_dirspec[len - 1] != '/') strcat (new_canonical_dirspec, "/"); return new_canonical_dirspec; @@ -1951,7 +1964,7 @@ __gnat_to_canonical_dir_spec (dirspec,prefixflag) } /* Translate a VMS syntax file specification into Unix syntax. - If no indicators of VMS syntax found, return input string. */ + If no indicators of VMS syntax found, return input string. */ char * __gnat_to_canonical_file_spec (filespec) @@ -1967,22 +1980,22 @@ __gnat_to_canonical_file_spec (filespec) } /* Translate a VMS syntax path specification into Unix syntax. - If no indicators of VMS syntax found, return input string. */ + If no indicators of VMS syntax found, return input string. */ char * __gnat_to_canonical_path_spec (pathspec) char *pathspec; { - char *curr, *next, buff [256]; + char *curr, *next, buff[256]; if (pathspec == 0) return pathspec; - /* If there are /'s, assume it's a Unix path spec and return */ + /* If there are /'s, assume it's a Unix path spec and return. */ if (strchr (pathspec, '/')) return pathspec; - new_canonical_pathspec [0] = 0; + new_canonical_pathspec[0] = 0; curr = pathspec; for (;;) @@ -1992,9 +2005,9 @@ __gnat_to_canonical_path_spec (pathspec) next = strchr (curr, 0); strncpy (buff, curr, next - curr); - buff [next - curr] = 0; + buff[next - curr] = 0; - /* Check for wildcards and expand if present */ + /* Check for wildcards and expand if present. */ if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "...")) { int i, dirs; @@ -2007,7 +2020,7 @@ __gnat_to_canonical_path_spec (pathspec) next_dir = __gnat_to_canonical_file_list_next (); strcat (new_canonical_pathspec, next_dir); - /* Don't append the separator after the last expansion */ + /* Don't append the separator after the last expansion. */ if (i+1 < dirs) strcat (new_canonical_pathspec, ":"); } @@ -2028,7 +2041,7 @@ __gnat_to_canonical_path_spec (pathspec) return new_canonical_pathspec; } -static char filename_buff [256]; +static char filename_buff[256]; static int translate_unix (name, type) @@ -2039,23 +2052,23 @@ translate_unix (name, type) return 0; } -/* Translate a Unix syntax path spec into a VMS style (comma separated - list of directories. Only used in this file so make it static */ +/* Translate a Unix syntax path spec into a VMS style (comma separated list of + directories. */ static char * to_host_path_spec (pathspec) char *pathspec; { - char *curr, *next, buff [256]; + char *curr, *next, buff[256]; if (pathspec == 0) return pathspec; - /* Can't very well test for colons, since that's the Unix separator! */ + /* Can't very well test for colons, since that's the Unix separator! */ if (strchr (pathspec, ']') || strchr (pathspec, ',')) return pathspec; - new_host_pathspec [0] = 0; + new_host_pathspec[0] = 0; curr = pathspec; for (;;) @@ -2065,7 +2078,7 @@ to_host_path_spec (pathspec) next = strchr (curr, 0); strncpy (buff, curr, next - curr); - buff [next - curr] = 0; + buff[next - curr] = 0; strcat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0)); if (*next == 0) @@ -2077,15 +2090,15 @@ to_host_path_spec (pathspec) return new_host_pathspec; } -/* Translate a Unix syntax directory specification into VMS syntax. - The prefixflag has no effect, but is kept for symmetry with - to_canonical_dir_spec. - If indicators of VMS syntax found, return input string. */ +/* Translate a Unix syntax directory specification into VMS syntax. The + PREFIXFLAG has no effect, but is kept for symmetry with + to_canonical_dir_spec. If indicators of VMS syntax found, return input + string. */ char * __gnat_to_host_dir_spec (dirspec, prefixflag) char *dirspec; - int prefixflag; + int prefixflag ATTRIBUTE_UNUSED; { int len = strlen (dirspec); @@ -2094,9 +2107,9 @@ __gnat_to_host_dir_spec (dirspec, prefixflag) if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':')) return new_host_dirspec; - while (len > 1 && new_host_dirspec [len-1] == '/') + while (len > 1 && new_host_dirspec[len - 1] == '/') { - new_host_dirspec [len-1] = 0; + new_host_dirspec[len - 1] = 0; len--; } @@ -2108,7 +2121,7 @@ __gnat_to_host_dir_spec (dirspec, prefixflag) } /* Translate a Unix syntax file specification into VMS syntax. - If indicators of VMS syntax found, return input string. */ + If indicators of VMS syntax found, return input string. */ char * __gnat_to_host_file_spec (filespec) @@ -2134,7 +2147,7 @@ __gnat_adjust_os_resource_limits () #else -/* Dummy functions for Osint import for non-VMS systems */ +/* Dummy functions for Osint import for non-VMS systems. */ int __gnat_to_canonical_file_list_init (dirspec, onlydirs) @@ -2199,9 +2212,9 @@ __gnat_adjust_os_resource_limits () #endif -/* for EMX, we cannot include dummy in libgcc, since it is too difficult +/* For EMX, we cannot include dummy in libgcc, since it is too difficult to coordinate this with the EMX distribution. Consequently, we put the - definition of dummy() which is used for exception handling, here */ + definition of dummy which is used for exception handling, here. */ #if defined (__EMX__) void __dummy () {} @@ -2217,13 +2230,13 @@ int _flush_cache() #if defined (CROSS_COMPILE) \ || (! (defined (sparc) && defined (sun) && defined (__SVR4)) \ && ! defined (linux) \ - && ! defined (sgi) \ && ! defined (hpux) \ && ! (defined (__alpha__) && defined (__osf__)) \ && ! defined (__MINGW32__)) -/* Dummy function to satisfy g-trasym.o. - Currently Solaris sparc, HP/UX, IRIX, GNU/Linux, Tru64 & Windows provide a - non-dummy version of this procedure in libaddr2line.a */ + +/* Dummy function to satisfy g-trasym.o. Currently Solaris sparc, HP/UX, + GNU/Linux, Tru64 & Windows provide a non-dummy version of this procedure in + libaddr2line.a. */ void convert_addresses (addrs, n_addr, buf, len) @@ -2235,3 +2248,9 @@ convert_addresses (addrs, n_addr, buf, len) *len = 0; } #endif + +#if defined (_WIN32) +int __gnat_argument_needs_quote = 1; +#else +int __gnat_argument_needs_quote = 0; +#endif diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 737e478d299..649ece1c19b 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -4,11 +4,11 @@ * * * A D A I N T * * * - * $Revision: 1.4 $ + * $Revision$ * * * C Header File * * * - * Copyright (C) 1992-2001 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- * @@ -39,7 +39,6 @@ extern void __gnat_to_gm_time PARAMS ((int *, int *, int *, int *, int *)); extern int __gnat_get_maximum_file_name_length PARAMS ((void)); -extern char __gnat_get_switch_character PARAMS ((void)); extern int __gnat_get_switches_case_sensitive PARAMS ((void)); extern int __gnat_get_file_names_case_sensitive PARAMS ((void)); extern char __gnat_get_default_identifier_character_set PARAMS ((void)); @@ -80,6 +79,7 @@ extern int __gnat_is_writable_file PARAMS ((char *)); extern int __gnat_portable_spawn PARAMS ((char *[])); extern int __gnat_portable_no_block_spawn PARAMS ((char *[])); extern int __gnat_portable_wait PARAMS ((int *)); +extern int __gnat_waitpid PARAMS ((int)); extern char *__gnat_locate_exec PARAMS ((char *, char *)); extern char *__gnat_locate_exec_on_path PARAMS ((char *)); extern char *__gnat_locate_regular_file PARAMS ((char *, char *)); diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb index 6b1829d067f..cb2a8877a1d 100644 --- a/gcc/ada/ali-util.adb +++ b/gcc/ada/ali-util.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -32,6 +32,8 @@ with Opt; use Opt; with Osint; use Osint; with System.CRC32; +with System.Memory; +with System.Address_To_Access_Conversions; package body ALI.Util is @@ -91,11 +93,12 @@ package body ALI.Util is -- Free source file buffer procedure Free_Source is - procedure free (Arg : Source_Buffer_Ptr); - pragma Import (C, free, "free"); + + package SB is + new System.Address_To_Access_Conversions (Big_Source_Buffer); begin - free (Src); + System.Memory.Free (SB.To_Address (SB.Object_Pointer (Src))); end Free_Source; -- Start of processing for Get_File_Checksum diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 5a4c21bcffa..b654e32efc6 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -127,14 +127,14 @@ package body ALI is function Get_Name (Lower : Boolean := False) return Name_Id; -- Skip blanks, then scan out a name (name is left in Name_Buffer with - -- length in Name_Len, as well as being returned in Name_Id form). The - -- name is adjusted appropriately if it refers to a file that is to be - -- substituted by another name as a result of a configuration pragma. - -- If Lower is set to true then the Name_Buffer will be converted to - -- all lower case. This only happends for systems where file names are - -- not case sensitive, and ensures that gnatbind works correctly on - -- such systems, regardless of the case of the file name. Note that - -- a name can be terminated by a right typeref bracket or '='. + -- length in Name_Len, as well as being returned in Name_Id form). + -- If Lower is set to True then the Name_Buffer will be converted to + -- all lower case, for systems where file names are not case sensitive. + -- This ensures that gnatbind works correctly regardless of the case + -- of the file name on all systems. The name is terminated by a either + -- white space or a typeref bracket or an equal sign except for the + -- special case of an operator name starting with a double quite which + -- is terminated by another double quote. function Get_Nat return Nat; -- Skip blanks, then scan out an unsigned integer value in Nat range @@ -305,11 +305,19 @@ package body ALI is loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Getc; - exit when At_End_Of_Field - or else Nextc = ')' - or else Nextc = '}' - or else Nextc = '>' - or else Nextc = '='; + + exit when At_End_Of_Field; + + if Name_Buffer (1) = '"' then + exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"'; + + else + exit when At_End_Of_Field + or else Nextc = '(' or else Nextc = ')' + or else Nextc = '{' or else Nextc = '}' + or else Nextc = '<' or else Nextc = '>' + or else Nextc = '='; + end if; end loop; -- Convert file name to all lower case if file names are not case @@ -639,14 +647,25 @@ package body ALI is Checkc (' '); Skip_Space; - for J in Partition_Restrictions loop + for J in All_Restrictions loop C := Getc; + ALIs.Table (Id).Restrictions (J) := C; - if C = 'v' or else C = 'r' or else C = 'n' then - ALIs.Table (Id).Restrictions (J) := C; - else - Fatal_Error; - end if; + case C is + when 'v' => + Restrictions (J) := 'v'; + + when 'r' => + if Restrictions (J) = 'n' then + Restrictions (J) := 'r'; + end if; + + when 'n' => + null; + + when others => + Fatal_Error; + end case; end loop; if At_Eol then @@ -694,6 +713,8 @@ package body ALI is if Debug_Flag_U then Write_Str (" ----> reading unit "); + Write_Int (Int (Units.Last)); + Write_Str (" "); Write_Unit_Name (Units.Table (Units.Last).Uname); Write_Str (" from file "); Write_Name (Units.Table (Units.Last).Sfile); @@ -710,15 +731,22 @@ package body ALI is and then Units.Table (Units.Last).Sfile /= Units.Table (Unit_Id (Info)).Sfile then - -- If Err is set then treat duplicate unit name as an instance - -- of a bad ALI format. This is the case of being called from - -- gnatmake, and the point is that if anything is wrong with - -- the ALI file, then gnatmake should just recompile. + -- If Err is set then ignore duplicate unit name. This is the + -- case of a call from gnatmake, where the situation can arise + -- from substitution of source files. In such situations, the + -- processing in gnatmake will always result in any required + -- recompilations in any case, and if we consider this to be + -- an error we get strange cases (for example when a generic + -- instantiation is replaced by a normal package) where we + -- read the old ali file, decide to recompile, and then decide + -- that the old and new ali files are incompatible. if Err then - raise Bad_ALI_Format; + null; - -- If Err is not set, then this is a fatal error + -- If Err is not set, then this is a fatal error. This is + -- the case of being called from the binder, where we must + -- definitely diagnose this as an error. else Set_Standard_Error; @@ -991,108 +1019,111 @@ package body ALI is Units.Table (Units.Last).Last_With := Withs.Last; Units.Table (Units.Last).Last_Arg := Args.Last; - end loop Unit_Loop; - - -- End loop through units for one ALI file + -- If there are linker options lines present, scan them - ALIs.Table (Id).Last_Unit := Units.Last; - ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile; + Name_Len := 0; - -- Set types of the units (there can be at most 2 of them) + Linker_Options_Loop : while C = 'L' loop + Checkc (' '); + Skip_Space; + Checkc ('"'); - if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then - Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body; - Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec; + loop + C := Getc; - else - -- Deal with body only and spec only cases, note that the reason we - -- do our own checking of the name (rather than using Is_Body_Name) - -- is that Uname drags in far too much compiler junk! + if C < Character'Val (16#20#) + or else C > Character'Val (16#7E#) + then + Fatal_Error; - Get_Name_String (Units.Table (Units.Last).Uname); + elsif C = '{' then + C := Character'Val (0); - if Name_Buffer (Name_Len) = 'b' then - Units.Table (Units.Last).Utype := Is_Body_Only; - else - Units.Table (Units.Last).Utype := Is_Spec_Only; - end if; - end if; + declare + V : Natural; - -- If there are linker options lines present, scan them + begin + V := 0; + for J in 1 .. 2 loop + C := Getc; - while C = 'L' loop - Checkc (' '); - Skip_Space; - Checkc ('"'); + if C in '0' .. '9' then + V := V * 16 + + Character'Pos (C) - Character'Pos ('0'); - Name_Len := 0; - loop - C := Getc; + elsif C in 'A' .. 'F' then + V := V * 16 + + Character'Pos (C) - Character'Pos ('A') + 10; - if C < Character'Val (16#20#) - or else C > Character'Val (16#7E#) - then - Fatal_Error; + else + Fatal_Error; + end if; + end loop; - elsif C = '{' then - C := Character'Val (0); + Checkc ('}'); - declare - V : Natural; + Add_Char_To_Name_Buffer (Character'Val (V)); + end; - begin - V := 0; - for J in 1 .. 2 loop + else + if C = '"' then + exit when Nextc /= '"'; C := Getc; + end if; - if C in '0' .. '9' then - V := V * 16 + - Character'Pos (C) - Character'Pos ('0'); + Add_Char_To_Name_Buffer (C); + end if; + end loop; - elsif C in 'A' .. 'F' then - V := V * 16 + - Character'Pos (C) - Character'Pos ('A') + 10; + Add_Char_To_Name_Buffer (nul); - else - Fatal_Error; - end if; - end loop; + Skip_Eol; + C := Getc; + end loop Linker_Options_Loop; - Checkc ('}'); + -- Store the linker options entry - Add_Char_To_Name_Buffer (Character'Val (V)); - end; + if Name_Len /= 0 then + Linker_Options.Increment_Last; - else - if C = '"' then - exit when Nextc /= '"'; - C := Getc; - end if; + Linker_Options.Table (Linker_Options.Last).Name := + Name_Enter; - Add_Char_To_Name_Buffer (C); - end if; - end loop; + Linker_Options.Table (Linker_Options.Last).Unit := + Units.Last; - Add_Char_To_Name_Buffer (nul); + Linker_Options.Table (Linker_Options.Last).Internal_File := + Is_Internal_File_Name (F); - Skip_Eol; - C := Getc; + Linker_Options.Table (Linker_Options.Last).Original_Pos := + Linker_Options.Last; + end if; + end loop Unit_Loop; - Linker_Options.Increment_Last; + -- End loop through units for one ALI file - Linker_Options.Table (Linker_Options.Last).Name - := Name_Enter; + ALIs.Table (Id).Last_Unit := Units.Last; + ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile; - Linker_Options.Table (Linker_Options.Last).Unit - := ALIs.Table (Id).First_Unit; + -- Set types of the units (there can be at most 2 of them) - Linker_Options.Table (Linker_Options.Last).Internal_File - := Is_Internal_File_Name (F); + if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then + Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body; + Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec; + + else + -- Deal with body only and spec only cases, note that the reason we + -- do our own checking of the name (rather than using Is_Body_Name) + -- is that Uname drags in far too much compiler junk! - Linker_Options.Table (Linker_Options.Last).Original_Pos - := Linker_Options.Last; + Get_Name_String (Units.Table (Units.Last).Uname); - end loop; + if Name_Buffer (Name_Len) = 'b' then + Units.Table (Units.Last).Utype := Is_Body_Only; + else + Units.Table (Units.Last).Utype := Is_Spec_Only; + end if; + end if; -- Scan out external version references and put in hash table diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index 78b9435f334..a5092594c50 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -81,7 +81,7 @@ package ALI is type Main_Program_Type is (None, Proc, Func); -- Indicator of whether unit can be used as main program - type Restrictions_String is array (Partition_Restrictions) of Character; + type Restrictions_String is array (All_Restrictions) of Character; -- Type used to hold string from R line type ALIs_Record is record @@ -363,6 +363,12 @@ package ALI is -- Set to blank by Initialize_ALI. Set to the appropriate queuing policy -- character if an ali file contains a P line setting the queuing policy. + Restrictions : Restrictions_String := (others => 'n'); + -- This array records the cumulative contributions of R lines in all + -- ali files. An entry is changed will be set to v if any ali file + -- indicates that the restriction is violated, and otherwise will be + -- set to r if the restriction is specified by some unit. + Static_Elaboration_Model_Used : Boolean := False; -- Set to False by Initialize_ALI. Set to True if any ALI file for a -- non-internal unit compiled with the static elaboration model is @@ -447,17 +453,29 @@ package ALI is -- Linker_Options Table -- -------------------------- - -- Each unique linker option (L line) in an ALI file generates - -- an entry in the Linker_Options table. Note that only unique - -- entries are stored, i.e. if the same entry appears twice, the - -- second entry is suppressed. Each entry is a character sequence - -- terminated by a NUL character. + -- If an ALI file has one of more Linker_Options lines, then a single + -- entry is made in this table. If more than one Linker_Options lines + -- appears in a given ALI file, then the arguments are concatenated + -- to form the entry in this table, using a NUL character as the + -- separator, and a final NUL character is appended to the end. type Linker_Option_Record is record - Name : Name_Id; - Unit : Unit_Id; + Name : Name_Id; + -- Name entry containing concatenated list of Linker_Options + -- arguments separated by NUL and ended by NUL as described above. + + Unit : Unit_Id; + -- Unit_Id for the entry + Internal_File : Boolean; - Original_Pos : Positive; + -- Set True if the linker options are from an internal file. This is + -- used to insert certain standard entries after all the user entries + -- but before the entries from the run-time. + + Original_Pos : Positive; + -- Keep track of original position in the linker options table. This + -- is used to implement a stable sort when we sort the linker options + -- table. end record; -- Declare the Linker_Options Table diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 7bfff100a56..f9c24bf2930 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -2354,6 +2354,27 @@ package body Atree is return OK; end if; + when OK_Orig => + declare + Onode : constant Node_Id := Original_Node (Node); + + begin + if Traverse_Field (Union_Id (Field1 (Onode))) = Abandon + or else + Traverse_Field (Union_Id (Field2 (Onode))) = Abandon + or else + Traverse_Field (Union_Id (Field3 (Onode))) = Abandon + or else + Traverse_Field (Union_Id (Field4 (Onode))) = Abandon + or else + Traverse_Field (Union_Id (Field5 (Onode))) = Abandon + then + return Abandon; + + else + return OK_Orig; + end if; + end; end case; end Traverse_Func; diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 8a4da3f9ab6..45d8f08553f 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.155 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- @@ -495,7 +495,7 @@ package Atree is -- function is used only by Sinfo.CN to change nodes into their -- corresponding entities. - type Traverse_Result is (OK, Skip, Abandon); + type Traverse_Result is (OK, OK_Orig, Skip, Abandon); -- This is the type of the result returned by the Process function passed -- to Traverse_Func and Traverse_Proc and also the type of the result of -- Traverse_Func itself. See descriptions below for details. @@ -508,8 +508,11 @@ package Atree is -- Process on each one. The traversal is controlled as follows by the -- result returned by Process: - -- OK The traversal continues normally with the children of - -- the node just processed. + -- OK The traversal continues normally with the syntactic + -- children of the node just processed. + + -- OK_Orig The traversal continues normally with the syntactic + -- children of the original node of the node just processed. -- Skip The children of the node just processed are skipped and -- excluded from the traversal, but otherwise processing diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index 470adfcd6cd..2fced8e02a8 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * $Revision: 1.1 $ + * $Revision$ * * * Copyright (C) 1992-2001, Free Software Foundation, Inc. * * * @@ -46,7 +46,7 @@ struct NFK Boolean rewrite_sub : 1; Boolean rewrite_ins : 1; Boolean analyzed : 1; - Boolean comes_from_source : 1; + Boolean c_f_s : 1; Boolean error_posted : 1; Boolean flag4 : 1; @@ -81,7 +81,7 @@ struct NFNK Boolean rewrite_sub : 1; Boolean rewrite_ins : 1; Boolean analyzed : 1; - Boolean comes_from_source : 1; + Boolean c_f_s : 1; Boolean error_posted : 1; Boolean flag4 : 1; @@ -101,14 +101,14 @@ struct NFNK Boolean flag17 : 1; Boolean flag18 : 1; - Boolean flag65 : 1; - Boolean flag66 : 1; - Boolean flag67 : 1; - Boolean flag68 : 1; - Boolean flag69 : 1; - Boolean flag70 : 1; - Boolean flag71 : 1; - Boolean flag72 : 1; + Boolean flag65 : 1; + Boolean flag66 : 1; + Boolean flag67 : 1; + Boolean flag68 : 1; + Boolean flag69 : 1; + Boolean flag70 : 1; + Boolean flag71 : 1; + Boolean flag72 : 1; }; /* Structure used for extra flags in third component overlaying Field12 */ @@ -313,35 +313,35 @@ extern Node_Id Current_Error_Node; /* Node Access Functions: */ -#define Nkind(N) ((Node_Kind)(Nodes_Ptr [N].U.K.kind)) -#define Ekind(N) ((Entity_Kind)(Nodes_Ptr [N + 1].U.K.kind)) -#define Sloc(N) (Nodes_Ptr [N].V.NX.sloc) -#define Paren_Count(N) (Nodes_Ptr [N].U.K.pflag1 \ - + 2 * Nodes_Ptr [N].U.K.pflag2) - -#define Field1(N) (Nodes_Ptr [N].V.NX.field1) -#define Field2(N) (Nodes_Ptr [N].V.NX.field2) -#define Field3(N) (Nodes_Ptr [N].V.NX.field3) -#define Field4(N) (Nodes_Ptr [N].V.NX.field4) -#define Field5(N) (Nodes_Ptr [N].V.NX.field5) -#define Field6(N) (Nodes_Ptr [(N)+1].V.EX.field6) -#define Field7(N) (Nodes_Ptr [(N)+1].V.EX.field7) -#define Field8(N) (Nodes_Ptr [(N)+1].V.EX.field8) -#define Field9(N) (Nodes_Ptr [(N)+1].V.EX.field9) -#define Field10(N) (Nodes_Ptr [(N)+1].V.EX.field10) -#define Field11(N) (Nodes_Ptr [(N)+1].V.EX.X.field11) -#define Field12(N) (Nodes_Ptr [(N)+1].V.EX.U.field12) -#define Field13(N) (Nodes_Ptr [(N)+2].V.EX.field6) -#define Field14(N) (Nodes_Ptr [(N)+2].V.EX.field7) -#define Field15(N) (Nodes_Ptr [(N)+2].V.EX.field8) -#define Field16(N) (Nodes_Ptr [(N)+2].V.EX.field9) -#define Field17(N) (Nodes_Ptr [(N)+2].V.EX.field10) -#define Field18(N) (Nodes_Ptr [(N)+2].V.EX.X.field11) -#define Field19(N) (Nodes_Ptr [(N)+3].V.EX.field6) -#define Field20(N) (Nodes_Ptr [(N)+3].V.EX.field7) -#define Field21(N) (Nodes_Ptr [(N)+3].V.EX.field8) -#define Field22(N) (Nodes_Ptr [(N)+3].V.EX.field9) -#define Field23(N) (Nodes_Ptr [(N)+3].V.EX.field10) +#define Nkind(N) ((Node_Kind) (Nodes_Ptr[(N) - First_Node_Id].U.K.kind)) +#define Ekind(N) ((Entity_Kind) (Nodes_Ptr[N + 1].U.K.kind)) +#define Sloc(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.sloc) +#define Paren_Count(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.pflag1 \ + + 2 * Nodes_Ptr[(N) - First_Node_Id].U.K.pflag2) + +#define Field1(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field1) +#define Field2(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field2) +#define Field3(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field3) +#define Field4(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field4) +#define Field5(N) (Nodes_Ptr[(N) - First_Node_Id].V.NX.field5) +#define Field6(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field6) +#define Field7(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field7) +#define Field8(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field8) +#define Field9(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field9) +#define Field10(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.field10) +#define Field11(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.X.field11) +#define Field12(N) (Nodes_Ptr[(N) - First_Node_Id + 1].V.EX.U.field12) +#define Field13(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field6) +#define Field14(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field7) +#define Field15(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field8) +#define Field16(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field9) +#define Field17(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.field10) +#define Field18(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.X.field11) +#define Field19(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field6) +#define Field20(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field7) +#define Field21(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field8) +#define Field22(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field9) +#define Field23(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field10) #define Node1(N) Field1 (N) #define Node2(N) Field2 (N) @@ -392,215 +392,214 @@ extern Node_Id Current_Error_Node; #define Str3(N) Field3 (N) -#define Uint3(N) ((Field3 (N)==0) ? Uint_0 : Field3 (N)) -#define Uint4(N) ((Field4 (N)==0) ? Uint_0 : Field4 (N)) -#define Uint5(N) ((Field5 (N)==0) ? Uint_0 : Field5 (N)) -#define Uint8(N) ((Field8 (N)==0) ? Uint_0 : Field8 (N)) -#define Uint9(N) ((Field9 (N)==0) ? Uint_0 : Field9 (N)) -#define Uint10(N) ((Field10 (N)==0) ? Uint_0 : Field10 (N)) -#define Uint11(N) ((Field11 (N)==0) ? Uint_0 : Field11 (N)) -#define Uint12(N) ((Field12 (N)==0) ? Uint_0 : Field12 (N)) -#define Uint13(N) ((Field13 (N)==0) ? Uint_0 : Field13 (N)) -#define Uint14(N) ((Field14 (N)==0) ? Uint_0 : Field14 (N)) -#define Uint15(N) ((Field15 (N)==0) ? Uint_0 : Field15 (N)) -#define Uint16(N) ((Field16 (N)==0) ? Uint_0 : Field16 (N)) -#define Uint17(N) ((Field17 (N)==0) ? Uint_0 : Field17 (N)) -#define Uint22(N) ((Field22 (N)==0) ? Uint_0 : Field22 (N)) +#define Uint3(N) ((Field3 (N) == 0) ? Uint_0 : Field3 (N)) +#define Uint4(N) ((Field4 (N) == 0) ? Uint_0 : Field4 (N)) +#define Uint5(N) ((Field5 (N) == 0) ? Uint_0 : Field5 (N)) +#define Uint8(N) ((Field8 (N) == 0) ? Uint_0 : Field8 (N)) +#define Uint9(N) ((Field9 (N) == 0) ? Uint_0 : Field9 (N)) +#define Uint10(N) ((Field10 (N) == 0) ? Uint_0 : Field10 (N)) +#define Uint11(N) ((Field11 (N) == 0) ? Uint_0 : Field11 (N)) +#define Uint12(N) ((Field12 (N) == 0) ? Uint_0 : Field12 (N)) +#define Uint13(N) ((Field13 (N) == 0) ? Uint_0 : Field13 (N)) +#define Uint14(N) ((Field14 (N) == 0) ? Uint_0 : Field14 (N)) +#define Uint15(N) ((Field15 (N) == 0) ? Uint_0 : Field15 (N)) +#define Uint16(N) ((Field16 (N) == 0) ? Uint_0 : Field16 (N)) +#define Uint17(N) ((Field17 (N) == 0) ? Uint_0 : Field17 (N)) +#define Uint22(N) ((Field22 (N) == 0) ? Uint_0 : Field22 (N)) #define Ureal3(N) Field3 (N) #define Ureal18(N) Field18 (N) #define Ureal21(N) Field21 (N) -#define Analyzed(N) (Nodes_Ptr [N].U.K.analyzed) -#define Comes_From_Source(N) (Nodes_Ptr [N].U.K.comes_from_source) -#define Error_Posted(N) (Nodes_Ptr [N].U.K.error_posted) - -#define Flag4(N) (Nodes_Ptr [N].U.K.flag4) -#define Flag5(N) (Nodes_Ptr [N].U.K.flag5) -#define Flag6(N) (Nodes_Ptr [N].U.K.flag6) -#define Flag7(N) (Nodes_Ptr [N].U.K.flag7) -#define Flag8(N) (Nodes_Ptr [N].U.K.flag8) -#define Flag9(N) (Nodes_Ptr [N].U.K.flag9) -#define Flag10(N) (Nodes_Ptr [N].U.K.flag10) -#define Flag11(N) (Nodes_Ptr [N].U.K.flag11) -#define Flag12(N) (Nodes_Ptr [N].U.K.flag12) -#define Flag13(N) (Nodes_Ptr [N].U.K.flag13) -#define Flag14(N) (Nodes_Ptr [N].U.K.flag14) -#define Flag15(N) (Nodes_Ptr [N].U.K.flag15) -#define Flag16(N) (Nodes_Ptr [N].U.K.flag16) -#define Flag17(N) (Nodes_Ptr [N].U.K.flag17) -#define Flag18(N) (Nodes_Ptr [N].U.K.flag18) - -#define Flag19(N) (Nodes_Ptr [(N)+1].U.K.in_list) -#define Flag20(N) (Nodes_Ptr [(N)+1].U.K.rewrite_sub) -#define Flag21(N) (Nodes_Ptr [(N)+1].U.K.rewrite_ins) -#define Flag22(N) (Nodes_Ptr [(N)+1].U.K.analyzed) -#define Flag23(N) (Nodes_Ptr [(N)+1].U.K.comes_from_source) -#define Flag24(N) (Nodes_Ptr [(N)+1].U.K.error_posted) -#define Flag25(N) (Nodes_Ptr [(N)+1].U.K.flag4) -#define Flag26(N) (Nodes_Ptr [(N)+1].U.K.flag5) -#define Flag27(N) (Nodes_Ptr [(N)+1].U.K.flag6) -#define Flag28(N) (Nodes_Ptr [(N)+1].U.K.flag7) -#define Flag29(N) (Nodes_Ptr [(N)+1].U.K.flag8) -#define Flag30(N) (Nodes_Ptr [(N)+1].U.K.flag9) -#define Flag31(N) (Nodes_Ptr [(N)+1].U.K.flag10) -#define Flag32(N) (Nodes_Ptr [(N)+1].U.K.flag11) -#define Flag33(N) (Nodes_Ptr [(N)+1].U.K.flag12) -#define Flag34(N) (Nodes_Ptr [(N)+1].U.K.flag13) -#define Flag35(N) (Nodes_Ptr [(N)+1].U.K.flag14) -#define Flag36(N) (Nodes_Ptr [(N)+1].U.K.flag15) -#define Flag37(N) (Nodes_Ptr [(N)+1].U.K.flag16) -#define Flag38(N) (Nodes_Ptr [(N)+1].U.K.flag17) -#define Flag39(N) (Nodes_Ptr [(N)+1].U.K.flag18) - -#define Flag40(N) (Nodes_Ptr [(N)+2].U.K.in_list) -#define Flag41(N) (Nodes_Ptr [(N)+2].U.K.rewrite_sub) -#define Flag42(N) (Nodes_Ptr [(N)+2].U.K.rewrite_ins) -#define Flag43(N) (Nodes_Ptr [(N)+2].U.K.analyzed) -#define Flag44(N) (Nodes_Ptr [(N)+2].U.K.comes_from_source) -#define Flag45(N) (Nodes_Ptr [(N)+2].U.K.error_posted) -#define Flag46(N) (Nodes_Ptr [(N)+2].U.K.flag4) -#define Flag47(N) (Nodes_Ptr [(N)+2].U.K.flag5) -#define Flag48(N) (Nodes_Ptr [(N)+2].U.K.flag6) -#define Flag49(N) (Nodes_Ptr [(N)+2].U.K.flag7) -#define Flag50(N) (Nodes_Ptr [(N)+2].U.K.flag8) -#define Flag51(N) (Nodes_Ptr [(N)+2].U.K.flag9) -#define Flag52(N) (Nodes_Ptr [(N)+2].U.K.flag10) -#define Flag53(N) (Nodes_Ptr [(N)+2].U.K.flag11) -#define Flag54(N) (Nodes_Ptr [(N)+2].U.K.flag12) -#define Flag55(N) (Nodes_Ptr [(N)+2].U.K.flag13) -#define Flag56(N) (Nodes_Ptr [(N)+2].U.K.flag14) -#define Flag57(N) (Nodes_Ptr [(N)+2].U.K.flag15) -#define Flag58(N) (Nodes_Ptr [(N)+2].U.K.flag16) -#define Flag59(N) (Nodes_Ptr [(N)+2].U.K.flag17) -#define Flag60(N) (Nodes_Ptr [(N)+2].U.K.flag18) -#define Flag61(N) (Nodes_Ptr [(N)+1].U.K.pflag1) -#define Flag62(N) (Nodes_Ptr [(N)+1].U.K.pflag2) -#define Flag63(N) (Nodes_Ptr [(N)+2].U.K.pflag1) -#define Flag64(N) (Nodes_Ptr [(N)+2].U.K.pflag2) - -#define Flag65(N) (Nodes_Ptr [(N)+2].U.NK.flag65) -#define Flag66(N) (Nodes_Ptr [(N)+2].U.NK.flag66) -#define Flag67(N) (Nodes_Ptr [(N)+2].U.NK.flag67) -#define Flag68(N) (Nodes_Ptr [(N)+2].U.NK.flag68) -#define Flag69(N) (Nodes_Ptr [(N)+2].U.NK.flag69) -#define Flag70(N) (Nodes_Ptr [(N)+2].U.NK.flag70) -#define Flag71(N) (Nodes_Ptr [(N)+2].U.NK.flag71) -#define Flag72(N) (Nodes_Ptr [(N)+2].U.NK.flag72) - -#define Flag73(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag73) -#define Flag74(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag74) -#define Flag75(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag75) -#define Flag76(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag76) -#define Flag77(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag77) -#define Flag78(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag78) -#define Flag79(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag79) -#define Flag80(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag80) -#define Flag81(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag81) -#define Flag82(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag82) -#define Flag83(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag83) -#define Flag84(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag84) -#define Flag85(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag85) -#define Flag86(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag86) -#define Flag87(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag87) -#define Flag88(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag88) -#define Flag89(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag89) -#define Flag90(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag90) -#define Flag91(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag91) -#define Flag92(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag92) -#define Flag93(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag93) -#define Flag94(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag94) -#define Flag95(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag95) -#define Flag96(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.flag96) - -#define Convention(N) (Nodes_Ptr [(N)+2].V.EX.U.fw.convention) - -#define Flag97(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag97) -#define Flag98(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag98) -#define Flag99(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag99) -#define Flag100(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag100) -#define Flag101(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag101) -#define Flag102(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag102) -#define Flag103(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag103) -#define Flag104(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag104) -#define Flag105(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag105) -#define Flag106(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag106) -#define Flag107(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag107) -#define Flag108(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag108) -#define Flag109(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag109) -#define Flag110(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag110) -#define Flag111(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag111) -#define Flag112(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag112) -#define Flag113(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag113) -#define Flag114(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag114) -#define Flag115(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag115) -#define Flag116(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag116) -#define Flag117(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag117) -#define Flag118(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag118) -#define Flag119(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag119) -#define Flag120(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag120) -#define Flag121(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag121) -#define Flag122(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag122) -#define Flag123(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag123) -#define Flag124(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag124) -#define Flag125(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag125) -#define Flag126(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag126) -#define Flag127(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag127) -#define Flag128(N) (Nodes_Ptr [(N)+3].V.EX.U.fw2.flag128) - -#define Flag129(N) (Nodes_Ptr [(N)+3].U.K.in_list) -#define Flag130(N) (Nodes_Ptr [(N)+3].U.K.rewrite_sub) -#define Flag131(N) (Nodes_Ptr [(N)+3].U.K.rewrite_ins) -#define Flag132(N) (Nodes_Ptr [(N)+3].U.K.analyzed) -#define Flag133(N) (Nodes_Ptr [(N)+3].U.K.comes_from_source) -#define Flag134(N) (Nodes_Ptr [(N)+3].U.K.error_posted) -#define Flag135(N) (Nodes_Ptr [(N)+3].U.K.flag4) -#define Flag136(N) (Nodes_Ptr [(N)+3].U.K.flag5) -#define Flag137(N) (Nodes_Ptr [(N)+3].U.K.flag6) -#define Flag138(N) (Nodes_Ptr [(N)+3].U.K.flag7) -#define Flag139(N) (Nodes_Ptr [(N)+3].U.K.flag8) -#define Flag140(N) (Nodes_Ptr [(N)+3].U.K.flag9) -#define Flag141(N) (Nodes_Ptr [(N)+3].U.K.flag10) -#define Flag142(N) (Nodes_Ptr [(N)+3].U.K.flag11) -#define Flag143(N) (Nodes_Ptr [(N)+3].U.K.flag12) -#define Flag144(N) (Nodes_Ptr [(N)+3].U.K.flag13) -#define Flag145(N) (Nodes_Ptr [(N)+3].U.K.flag14) -#define Flag146(N) (Nodes_Ptr [(N)+3].U.K.flag15) -#define Flag147(N) (Nodes_Ptr [(N)+3].U.K.flag16) -#define Flag148(N) (Nodes_Ptr [(N)+3].U.K.flag17) -#define Flag149(N) (Nodes_Ptr [(N)+3].U.K.flag18) -#define Flag150(N) (Nodes_Ptr [(N)+3].U.K.pflag1) -#define Flag151(N) (Nodes_Ptr [(N)+3].U.K.pflag2) - -#define Flag152(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag152) -#define Flag153(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag153) -#define Flag154(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag154) -#define Flag155(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag155) -#define Flag156(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag156) -#define Flag157(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag157) -#define Flag158(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag158) -#define Flag159(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag159) -#define Flag160(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag160) -#define Flag161(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag161) -#define Flag162(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag162) -#define Flag163(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag163) -#define Flag164(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag164) -#define Flag165(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag165) -#define Flag166(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag166) -#define Flag167(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag167) -#define Flag168(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag168) -#define Flag169(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag169) -#define Flag170(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag170) -#define Flag171(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag171) -#define Flag172(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag172) -#define Flag173(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag173) -#define Flag174(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag174) -#define Flag175(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag175) -#define Flag176(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag176) -#define Flag177(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag177) -#define Flag178(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag178) -#define Flag179(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag179) -#define Flag180(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag180) -#define Flag181(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag181) -#define Flag182(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag182) -#define Flag183(N) (Nodes_Ptr [(N)+3].V.EX.X.fw3.flag183) +#define Analyzed(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.analyzed) +#define Comes_From_Source(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.c_f_s) +#define Error_Posted(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.error_posted) +#define Convention(N) \ + (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.convention) + +#define Flag4(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag4) +#define Flag5(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag5) +#define Flag6(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag6) +#define Flag7(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag7) +#define Flag8(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag8) +#define Flag9(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag9) +#define Flag10(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag10) +#define Flag11(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag11) +#define Flag12(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag12) +#define Flag13(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag13) +#define Flag14(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag14) +#define Flag15(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag15) +#define Flag16(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag16) +#define Flag17(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag17) +#define Flag18(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag18) + +#define Flag19(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.in_list) +#define Flag20(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.rewrite_sub) +#define Flag21(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.rewrite_ins) +#define Flag22(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.analyzed) +#define Flag23(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.c_f_s) +#define Flag24(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.error_posted) +#define Flag25(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag4) +#define Flag26(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag5) +#define Flag27(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag6) +#define Flag28(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag7) +#define Flag29(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag8) +#define Flag30(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag9) +#define Flag31(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag10) +#define Flag32(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag11) +#define Flag33(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag12) +#define Flag34(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag13) +#define Flag35(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag14) +#define Flag36(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag15) +#define Flag37(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag16) +#define Flag38(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag17) +#define Flag39(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag18) + +#define Flag40(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.in_list) +#define Flag41(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.rewrite_sub) +#define Flag42(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.rewrite_ins) +#define Flag43(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.analyzed) +#define Flag44(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.c_f_s) +#define Flag45(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.error_posted) +#define Flag46(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag4) +#define Flag47(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag5) +#define Flag48(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag6) +#define Flag49(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag7) +#define Flag50(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag8) +#define Flag51(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag9) +#define Flag52(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag10) +#define Flag53(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag11) +#define Flag54(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag12) +#define Flag55(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag13) +#define Flag56(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag14) +#define Flag57(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag15) +#define Flag58(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag16) +#define Flag59(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag17) +#define Flag60(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag18) +#define Flag61(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.pflag1) +#define Flag62(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.pflag2) +#define Flag63(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.pflag1) +#define Flag64(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.pflag2) + +#define Flag65(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag65) +#define Flag66(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag66) +#define Flag67(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag67) +#define Flag68(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag68) +#define Flag69(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag69) +#define Flag70(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag70) +#define Flag71(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag71) +#define Flag72(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.NK.flag72) + +#define Flag73(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag73) +#define Flag74(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag74) +#define Flag75(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag75) +#define Flag76(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag76) +#define Flag77(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag77) +#define Flag78(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag78) +#define Flag79(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag79) +#define Flag80(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag80) +#define Flag81(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag81) +#define Flag82(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag82) +#define Flag83(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag83) +#define Flag84(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag84) +#define Flag85(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag85) +#define Flag86(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag86) +#define Flag87(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag87) +#define Flag88(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag88) +#define Flag89(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag89) +#define Flag90(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag90) +#define Flag91(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag91) +#define Flag92(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag92) +#define Flag93(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag93) +#define Flag94(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag94) +#define Flag95(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag95) +#define Flag96(N) (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.flag96) +#define Flag97(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag97) +#define Flag98(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag98) +#define Flag99(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag99) +#define Flag100(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag100) +#define Flag101(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag101) +#define Flag102(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag102) +#define Flag103(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag103) +#define Flag104(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag104) +#define Flag105(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag105) +#define Flag106(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag106) +#define Flag107(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag107) +#define Flag108(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag108) +#define Flag109(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag109) +#define Flag110(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag110) +#define Flag111(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag111) +#define Flag112(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag112) +#define Flag113(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag113) +#define Flag114(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag114) +#define Flag115(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag115) +#define Flag116(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag116) +#define Flag117(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag117) +#define Flag118(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag118) +#define Flag119(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag119) +#define Flag120(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag120) +#define Flag121(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag121) +#define Flag122(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag122) +#define Flag123(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag123) +#define Flag124(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag124) +#define Flag125(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag125) +#define Flag126(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag126) +#define Flag127(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag127) +#define Flag128(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag128) + +#define Flag129(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.in_list) +#define Flag130(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.rewrite_sub) +#define Flag131(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.rewrite_ins) +#define Flag132(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.analyzed) +#define Flag133(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.c_f_s) +#define Flag134(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.error_posted) +#define Flag135(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag4) +#define Flag136(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag5) +#define Flag137(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag6) +#define Flag138(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag7) +#define Flag139(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag8) +#define Flag140(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag9) +#define Flag141(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag10) +#define Flag142(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag11) +#define Flag143(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag12) +#define Flag144(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag13) +#define Flag145(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag14) +#define Flag146(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag15) +#define Flag147(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag16) +#define Flag148(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag17) +#define Flag149(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag18) +#define Flag150(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.pflag1) +#define Flag151(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.pflag2) + +#define Flag152(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag152) +#define Flag153(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag153) +#define Flag154(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag154) +#define Flag155(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag155) +#define Flag156(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag156) +#define Flag157(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag157) +#define Flag158(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag158) +#define Flag159(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag159) +#define Flag160(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag160) +#define Flag161(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag161) +#define Flag162(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag162) +#define Flag163(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag163) +#define Flag164(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag164) +#define Flag165(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag165) +#define Flag166(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag166) +#define Flag167(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag167) +#define Flag168(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag168) +#define Flag169(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag169) +#define Flag170(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag170) +#define Flag171(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag171) +#define Flag172(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag172) +#define Flag173(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag173) +#define Flag174(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag174) +#define Flag175(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag175) +#define Flag176(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag176) +#define Flag177(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag177) +#define Flag178(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag178) +#define Flag179(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag179) +#define Flag180(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag180) +#define Flag181(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag181) +#define Flag182(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag182) +#define Flag183(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.X.fw3.flag183) diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb index 366d7c59f49..7f31b57f3dd 100644 --- a/gcc/ada/back_end.adb +++ b/gcc/ada/back_end.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.23 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -26,26 +26,26 @@ -- -- ------------------------------------------------------------------------------ -with Atree; use Atree; -with Debug; use Debug; -with Elists; use Elists; -with Lib; use Lib; -with Osint; use Osint; -with Opt; use Opt; -with Osint; use Osint; -with Namet; use Namet; -with Nlists; use Nlists; -with Stand; use Stand; -with Sinput; use Sinput; -with Stringt; use Stringt; -with Switch; use Switch; -with System; use System; -with Types; use Types; +with Atree; use Atree; +with Debug; use Debug; +with Elists; use Elists; +with Lib; use Lib; +with Osint; use Osint; +with Opt; use Opt; +with Osint; use Osint; +with Osint.C; use Osint.C; +with Namet; use Namet; +with Nlists; use Nlists; +with Stand; use Stand; +with Sinput; use Sinput; +with Stringt; use Stringt; +with Switch; use Switch; +with Switch.C; use Switch.C; +with System; use System; +with Types; use Types; package body Back_End is - -- Local subprograms - ------------------- -- Call_Back_End -- ------------------- @@ -209,17 +209,23 @@ package body Back_End is Last := Last - 1; end if; + -- For dumpbase and o, skip following argument and do not + -- store either the switch or the following argument + if Switch_Chars (First .. Last) = "o" or else Switch_Chars (First .. Last) = "dumpbase" then Next_Arg := Next_Arg + 1; + -- Do not record -quiet switch + elsif Switch_Chars (First .. Last) = "quiet" then - null; -- do not record this switch + null; else -- Store any other GCC switches + Store_Compilation_Switch (Switch_Chars); end if; end Scan_Back_End_Switches; @@ -259,15 +265,15 @@ package body Back_End is elsif not Is_Switch (Argv) then -- must be a file name Add_File (Argv); - elsif Is_Front_End_Switch (Argv) then - Scan_Front_End_Switches (Argv); + -- We must recognize -nostdinc to suppress visibility on the + -- standard GNAT RTL sources. This is also a gcc switch. - -- ??? Should be done in Scan_Front_End_Switches, after - -- Switch is splitted in compiler/make/bind units + elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdinc" then + Opt.No_Stdinc := True; + Scan_Back_End_Switches (Argv); - if Argv (2) /= 'I' then - Store_Compilation_Switch (Argv); - end if; + elsif Is_Front_End_Switch (Argv) then + Scan_Front_End_Switches (Argv); -- All non-front-end switches are back-end switches diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb index 77b3284fc33..7d23d2743ca 100644 --- a/gcc/ada/bcheck.adb +++ b/gcc/ada/bcheck.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -31,7 +31,6 @@ with ALI.Util; use ALI.Util; with Binderr; use Binderr; with Butil; use Butil; with Casing; use Casing; -with Debug; use Debug; with Fname; use Fname; with Namet; use Namet; with Opt; use Opt; @@ -359,82 +358,71 @@ package body Bcheck is -- Second, all units are verified against the specified restrictions. procedure Check_Partition_Restrictions is + No_Restriction_List : array (All_Restrictions) of Boolean := + (No_Implicit_Conditionals => True, + -- This could modify and pessimize generated code - R : array (Partition_Restrictions) of ALI_Id := (others => No_ALI_Id); - -- Record the first unit specifying each partition restriction + No_Implicit_Dynamic_Code => True, + -- This could modify and pessimize generated code - V : array (Partition_Restrictions) of ALI_Id := (others => No_ALI_Id); - -- Record the last unit violating each partition restriction + No_Implicit_Loops => True, + -- This could modify and pessimize generated code - procedure List_Applicable_Restrictions; - -- Output a list of restrictions that may be applied to the partition, - -- without causing bind errors. + No_Recursion => True, + -- Not checkable at compile time - ---------------------------------- - -- List_Applicable_Restrictions -- - ---------------------------------- + No_Reentrancy => True, + -- Not checkable at compile time - procedure List_Applicable_Restrictions is - Additional_Restrictions_Listed : Boolean := False; + others => False); + -- Define those restrictions that should be output if the gnatbind -r + -- switch is used. Not all restrictions are output for the reasons given + -- above in the list, and this array is used to test whether the + -- corresponding pragma should be listed. True means that it should not + -- be listed. - begin - -- List any restrictions which were not violated and not specified - - for J in Partition_Restrictions loop - if V (J) = No_ALI_Id and R (J) = No_ALI_Id then - if not Additional_Restrictions_Listed then - Write_Str ("The following additional restrictions may be" & - " applied to this partition:"); - Write_Eol; - Additional_Restrictions_Listed := True; - end if; - - Write_Str ("pragma Restrictions ("); - - declare - S : constant String := Restriction_Id'Image (J); - - begin - Name_Len := S'Length; - Name_Buffer (1 .. Name_Len) := S; - end; + R : array (All_Restrictions) of ALI_Id := (others => No_ALI_Id); + -- Record the first unit specifying each compilation unit restriction - Set_Casing (Mixed_Case); - Write_Str (Name_Buffer (1 .. Name_Len)); - Write_Str (");"); - Write_Eol; - end if; - end loop; - end List_Applicable_Restrictions; + V : array (All_Restrictions) of ALI_Id := (others => No_ALI_Id); + -- Record the last unit violating each partition restriction. Note + -- that entries in this array that do not correspond to partition + -- restrictions can never be modified. - -- Start of processing for Check_Partition_Restrictions + Additional_Restrictions_Listed : Boolean := False; + -- Set True if we have listed header for restrictions begin - Find_Restrictions : + -- Loop to find restrictions + for A in ALIs.First .. ALIs.Last loop - for J in Partition_Restrictions loop + for J in All_Restrictions loop if R (J) = No_ALI_Id and ALIs.Table (A).Restrictions (J) = 'r' then R (J) := A; end if; end loop; - end loop Find_Restrictions; + end loop; + + -- Loop to find violations - Find_Violations : for A in ALIs.First .. ALIs.Last loop - for J in Partition_Restrictions loop + for J in All_Restrictions loop if ALIs.Table (A).Restrictions (J) = 'v' and then not Is_Internal_File_Name (ALIs.Table (A).Sfile) then - -- A violation of a restriction was found, so check whether - -- that restriction was actually in effect. If so, give an - -- error message. - - -- Note that all such violations found are reported. + -- A violation of a restriction was found V (J) := A; - if R (J) /= No_ALI_Id then - Report_Violated_Restriction : declare + -- If this is a paritition restriction, and the restriction + -- was specified in some unit in the partition, then this + -- is a violation of the consistency requirement, so we + -- generate an appropriate error message. + + if R (J) /= No_ALI_Id + and then J in Partition_Restrictions + then + declare M1 : constant String := "% has Restriction ("; S : constant String := Restriction_Id'Image (J); M2 : String (1 .. M1'Length + S'Length + 1); @@ -455,14 +443,47 @@ package body Bcheck is Error_Msg_Name_1 := ALIs.Table (A).Sfile; Consistency_Error_Msg ("but file % violates this restriction"); - end Report_Violated_Restriction; + end; end if; end if; end loop; - end loop Find_Violations; + end loop; + + -- List applicable restrictions if option set + + if List_Restrictions then + + -- List any restrictions which were not violated and not specified + + for J in All_Restrictions loop + if V (J) = No_ALI_Id + and then R (J) = No_ALI_Id + and then not No_Restriction_List (J) + then + if not Additional_Restrictions_Listed then + Write_Eol; + Write_Line + ("The following additional restrictions may be" & + " applied to this partition:"); + Additional_Restrictions_Listed := True; + end if; + + Write_Str ("pragma Restrictions ("); - if Debug_Flag_R then - List_Applicable_Restrictions; + declare + S : constant String := Restriction_Id'Image (J); + + begin + Name_Len := S'Length; + Name_Buffer (1 .. Name_Len) := S; + end; + + Set_Casing (Mixed_Case); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Str (");"); + Write_Eol; + end if; + end loop; end if; end Check_Partition_Restrictions; diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 55ec4324ab8..015ed90b160 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -37,10 +37,10 @@ with Hostparm; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; +with Osint.B; use Osint.B; with Output; use Output; with Types; use Types; with Sdefault; use Sdefault; -with System; use System; with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; @@ -63,21 +63,13 @@ package body Bindgen is Num_Elab_Calls : Nat := 0; -- Number of generated calls to elaboration routines - subtype chars_ptr is Address; - ----------------------- -- Local Subprograms -- ----------------------- - procedure WBI (Info : String) renames Osint.Write_Binder_Info; + procedure WBI (Info : String) renames Osint.B.Write_Binder_Info; -- Convenient shorthand used throughout - function ABE_Boolean_Required (U : Unit_Id) return Boolean; - -- Given a unit id value U, determines if the corresponding unit requires - -- an access-before-elaboration check variable, i.e. it is a non-predefined - -- body for which no pragma Elaborate, Elaborate_All or Elaborate_Body is - -- present, and thus could require ABE checks. - procedure Resolve_Binder_Options; -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS -- since it tests for a package named "dec" which might cause a conflict @@ -162,9 +154,8 @@ package body Bindgen is function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean; -- Compare linker options, when sorting, first according to - -- Is_Internal_File (internal files come later) and then by elaboration - -- order position (latest to earliest) except its not possible to - -- distinguish between a linker option in the spec and one in the body. + -- Is_Internal_File (internal files come later) and then by + -- elaboration order position (latest to earliest). procedure Move_Linker_Option (From : Natural; To : Natural); -- Move routine for sorting linker options @@ -208,9 +199,6 @@ package body Bindgen is -- If Last is greater than or equal to N, no effect, otherwise store -- blanks in Statement_Buffer bumping Last, until Last = N. - function Value (chars : chars_ptr) return String; - -- Return C NUL-terminated string at chars as an Ada string - procedure Write_Info_Ada_C (Ada : String; C : String; Common : String); -- For C code case, write C & Common, for Ada case write Ada & Common -- to current binder output file using Write_Binder_Info. @@ -222,31 +210,6 @@ package body Bindgen is -- First writes its argument (using Set_String (S)), then writes out the -- contents of statement buffer up to Last, and reset Last to 0 - -------------------------- - -- ABE_Boolean_Required -- - -------------------------- - - function ABE_Boolean_Required (U : Unit_Id) return Boolean is - Typ : constant Unit_Type := Units.Table (U).Utype; - Unit : Unit_Id; - - begin - if Typ /= Is_Body then - return False; - - else - Unit := U + 1; - - return (not Units.Table (Unit).Pure) - and then - (not Units.Table (Unit).Preelab) - and then - (not Units.Table (Unit).Elaborate_Body) - and then - (not Units.Table (Unit).Predefined); - end if; - end ABE_Boolean_Required; - ---------------------- -- Gen_Adafinal_Ada -- ---------------------- @@ -287,6 +250,7 @@ package body Bindgen is procedure Gen_Adainit_Ada is Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority; + begin WBI (" procedure " & Ada_Init_Name.all & " is"); @@ -343,17 +307,11 @@ package body Bindgen is Write_Statement_Buffer; - -- Normal case (not No_Run_Time mode). The global values are - -- assigned using the runtime routine Set_Globals (we have to use - -- the routine call, rather than define the globals in the binder - -- file to deal with cross-library calls in some systems. + -- Case of No_Run_Time mode. The only global variable that might + -- be needed (by the Ravenscar profile) is the priority of the + -- environment. Also no exception tables are needed. if No_Run_Time_Specified then - - -- Case of No_Run_Time mode. The only global variable that might - -- be needed (by the Ravenscar profile) is the priority of the - -- environment. Also no exception tables are needed. - if Main_Priority /= No_Main_Priority then WBI (" Main_Priority : Integer;"); WBI (" pragma Import (C, Main_Priority," & @@ -373,8 +331,26 @@ package body Bindgen is WBI (" null;"); end if; + -- Normal case (not No_Run_Time mode). The global values are + -- assigned using the runtime routine Set_Globals (we have to use + -- the routine call, rather than define the globals in the binder + -- file to deal with cross-library calls in some systems. + else + -- Generate restrictions string + + Set_String (" Restrictions : constant String :="); + Write_Statement_Buffer; + Set_String (" """); + + for J in Restrictions'Range loop + Set_Char (Restrictions (J)); + end loop; + + Set_String (""";"); + Write_Statement_Buffer; WBI (""); + WBI (" procedure Set_Globals"); WBI (" (Main_Priority : Integer;"); WBI (" Time_Slice_Value : Integer;"); @@ -382,15 +358,16 @@ package body Bindgen is WBI (" Locking_Policy : Character;"); WBI (" Queuing_Policy : Character;"); WBI (" Task_Dispatching_Policy : Character;"); - WBI (" Adafinal : System.Address;"); + WBI (" Restrictions : System.Address;"); WBI (" Unreserve_All_Interrupts : Integer;"); - WBI (" Exception_Tracebacks : Integer);"); + WBI (" Exception_Tracebacks : Integer;"); + WBI (" Zero_Cost_Exceptions : Integer);"); WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");"); - WBI (""); -- Import entry point for elaboration time signal handler -- installation, and indication of whether it's been called -- previously + WBI (""); WBI (" procedure Install_Handler;"); WBI (" pragma Import (C, Install_Handler, " & @@ -446,7 +423,7 @@ package body Bindgen is Set_String ("',"); Write_Statement_Buffer; - WBI (" Adafinal => System.Null_Address,"); + WBI (" Restrictions => Restrictions'Address,"); Set_String (" Unreserve_All_Interrupts => "); @@ -467,6 +444,17 @@ package body Bindgen is Set_String ("0"); end if; + Set_String (","); + Write_Statement_Buffer; + + Set_String (" Zero_Cost_Exceptions => "); + + if Zero_Cost_Exceptions_Specified then + Set_String ("1"); + else + Set_String ("0"); + end if; + Set_String (");"); Write_Statement_Buffer; @@ -488,6 +476,7 @@ package body Bindgen is procedure Gen_Adainit_C is Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority; + begin WBI ("void " & Ada_Init_Name.all & " ()"); WBI ("{"); @@ -512,6 +501,8 @@ package body Bindgen is Write_Statement_Buffer; + -- No run-time case + if No_Run_Time_Specified then -- Case of No_Run_Time mode. Set __gl_main_priority if needed @@ -524,7 +515,20 @@ package body Bindgen is Write_Statement_Buffer; end if; + -- Normal case (run time present) + else + -- Generate definition for restrictions string + + Set_String (" const char *restrictions = """); + + for J in Restrictions'Range loop + Set_Char (Restrictions (J)); + end loop; + + Set_String (""";"); + Write_Statement_Buffer; + -- Code for normal case (not in No_Run_Time mode) Gen_Exception_Table_C; @@ -557,59 +561,68 @@ package body Bindgen is end if; Set_Char (','); - Tab_To (15); + Tab_To (20); Set_String ("/* Time_Slice_Value */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (ALIs.Table (ALIs.First).WC_Encoding); Set_String ("',"); - Tab_To (15); + Tab_To (20); Set_String ("/* WC_Encoding */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (Locking_Policy_Specified); Set_String ("',"); - Tab_To (15); + Tab_To (20); Set_String ("/* Locking_Policy */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (Queuing_Policy_Specified); Set_String ("',"); - Tab_To (15); + Tab_To (20); Set_String ("/* Queuing_Policy */"); Write_Statement_Buffer; Set_String (" '"); Set_Char (Task_Dispatching_Policy_Specified); Set_String ("',"); - Tab_To (15); + Tab_To (20); Set_String ("/* Tasking_Dispatching_Policy */"); Write_Statement_Buffer; Set_String (" "); - Set_String ("0,"); - Tab_To (15); - Set_String ("/* Finalization routine address, not used anymore */"); + Set_String ("restrictions"); + Set_String (","); + Tab_To (20); + Set_String ("/* Restrictions */"); Write_Statement_Buffer; Set_String (" "); Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified)); Set_String (","); - Tab_To (15); + Tab_To (20); Set_String ("/* Unreserve_All_Interrupts */"); Write_Statement_Buffer; Set_String (" "); Set_Int (Boolean'Pos (Exception_Tracebacks)); - Set_String (");"); - Tab_To (15); + Set_String (","); + Tab_To (20); Set_String ("/* Exception_Tracebacks */"); Write_Statement_Buffer; + Set_String (" "); + Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified)); + Set_String (");"); + Tab_To (20); + Set_String ("/* Zero_Cost_Exceptions */"); + Write_Statement_Buffer; + -- Install elaboration time signal handler + WBI (" if (__gnat_handler_installed == 0)"); WBI (" {"); WBI (" __gnat_install_handler ();"); @@ -639,17 +652,6 @@ package body Bindgen is -- and spec are different and we are currently processing -- the body, in which case it is the spec (Unum + 1). - procedure Set_Elab_Entity; - -- Set name of elaboration entity flag - - procedure Set_Elab_Entity is - begin - Get_Decoded_Name_String_With_Brackets (U.Uname); - Name_Len := Name_Len - 2; - Set_Casing (U.Icasing); - Set_Name_Buffer; - end Set_Elab_Entity; - begin if U.Utype = Is_Body then Unum_Spec := Unum + 1; @@ -1173,7 +1175,8 @@ package body Bindgen is procedure Gen_Main_Ada is Target : constant String_Ptr := Target_Name; VxWorks_Target : constant Boolean := - Target (Target'Last - 7 .. Target'Last) = "vxworks/"; + Target (Target'Last - 7 .. Target'Last) = "vxworks/" + or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/"; begin WBI (""); @@ -1241,6 +1244,19 @@ package body Bindgen is WBI (""); end if; + -- Generate a reference to Ada_Main_Program_Name. This symbol is + -- not referenced elsewhere in the generated program, but is needed + -- by the debugger (that's why it is generated in the first place). + -- The reference stops Ada_Main_Program_Name from being optimized + -- away by smart linkers, such as the AiX linker. + + if Bind_Main_Program then + WBI + (" Ensure_Reference : System.Address := " & + "Ada_Main_Program_Name'Address;"); + WBI (""); + end if; + WBI (" begin"); -- On VxWorks, there are no command line arguments @@ -1315,7 +1331,8 @@ package body Bindgen is procedure Gen_Main_C is Target : constant String_Ptr := Target_Name; VxWorks_Target : constant Boolean := - Target (Target'Last - 7 .. Target'Last) = "vxworks/"; + Target (Target'Last - 7 .. Target'Last) = "vxworks/" + or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/"; begin Set_String ("int "); @@ -1351,6 +1368,17 @@ package body Bindgen is WBI (" char **envp;"); WBI ("{"); + -- Generate a reference to __gnat_ada_main_program_name. This symbol + -- is not referenced elsewhere in the generated program, but is + -- needed by the debugger (that's why it is generated in the first + -- place). The reference stops Ada_Main_Program_Name from being + -- optimized away by smart linkers, such as the AiX linker. + + if Bind_Main_Program then + WBI (" char *ensure_reference = __gnat_ada_main_program_name;"); + WBI (""); + end if; + if ALIs.Table (ALIs.First).Main_Program = Func then WBI (" int result;"); end if; @@ -1443,7 +1471,10 @@ package body Bindgen is ------------------------------ procedure Gen_Object_Files_Options is - Lgnat : Integer; + Lgnat : Natural; + -- This keeps track of the position in the sorted set of entries + -- in the Linker_Options table of where the first entry from an + -- internal file appears. procedure Write_Linker_Option; -- Write binder info linker option. @@ -1550,10 +1581,40 @@ package body Bindgen is -- Sort linker options - Sort (Linker_Options.Last, Move_Linker_Option'Access, - Lt_Linker_Option'Access); - - -- Write user linker options + -- This sort accomplishes two important purposes: + + -- a) All application files are sorted to the front, and all + -- GNAT internal files are sorted to the end. This results + -- in a well defined dividing line between the two sets of + -- files, for the purpose of inserting certain standard + -- library references into the linker arguments list. + + -- b) Given two different units, we sort the linker options so + -- that those from a unit earlier in the elaboration order + -- comes later in the list. This is a heuristic designed + -- to create a more friendly order of linker options when + -- the operations appear in separate units. The idea is that + -- if unit A must be elaborated before unit B, then it is + -- more likely that B references libraries included by A, + -- than vice versa, so we want the libraries included by + -- A to come after the libraries included by B. + + -- These two criteria are implemented by function Lt_Linker_Option. + -- Note that a special case of b) is that specs are elaborated before + -- bodies, so linker options from specs come after linker options + -- for bodies, and again, the assumption is that libraries used by + -- the body are more likely to reference libraries used by the spec, + -- than vice versa. + + Sort + (Linker_Options.Last, + Move_Linker_Option'Access, + Lt_Linker_Option'Access); + + -- Write user linker options, i.e. the set of linker options that + -- come from all files other than GNAT internal files, Lgnat is + -- left set to point to the first entry from a GNAT internal file, + -- or past the end of the entriers if there are no internal files. Lgnat := Linker_Options.Last + 1; @@ -1567,8 +1628,12 @@ package body Bindgen is end if; end loop; - if not (No_Run_Time_Specified or else Opt.No_Stdlib) then + -- Now we insert standard linker options that must appear after the + -- entries from user files, and before the entries from GNAT run-time + -- files. The reason for this decision is that libraries referenced + -- by internal routines may reference these standard library entries. + if not (No_Run_Time_Specified or else Opt.No_Stdlib) then Name_Len := 0; if Opt.Shared_Libgnat then @@ -1577,7 +1642,7 @@ package body Bindgen is Add_Str_To_Name_Buffer ("-static"); end if; - -- Write directly to avoid -K output. + -- Write directly to avoid -K output (why???) Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len)); @@ -1596,10 +1661,9 @@ package body Bindgen is Name_Len := 0; Add_Str_To_Name_Buffer ("-lgnat"); Write_Linker_Option; - end if; - -- Write internal linker options + -- Write linker options from all internal files for J in Lgnat .. Linker_Options.Last loop Get_Name_String (Linker_Options.Table (J).Name); @@ -1619,22 +1683,8 @@ package body Bindgen is --------------------- procedure Gen_Output_File (Filename : String) is - - function Public_Version return Boolean; - -- Return true if the version number contains a 'p' - - function Public_Version return Boolean is - begin - for J in Gnat_Version_String'Range loop - if Gnat_Version_String (J) = 'p' then - return True; - end if; - end loop; - - return False; - end Public_Version; - - -- Start of processing for Gen_Output_File + Public_Version : constant Boolean := Gnat_Version_Type = "PUBLIC "; + -- Set true if this is the public version of GNAT begin -- Override Ada_Bind_File and Bind_Main_Program for Java since @@ -1702,7 +1752,8 @@ package body Bindgen is Target : constant String_Ptr := Target_Name; VxWorks_Target : constant Boolean := - Target (Target'Last - 7 .. Target'Last) = "vxworks/"; + Target (Target'Last - 7 .. Target'Last) = "vxworks/" + or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/"; begin -- Create spec first @@ -1776,7 +1827,7 @@ package body Bindgen is end if; end if; - -- Generate the GNAT_Version and Ada_Main_Program_name info only for + -- Generate the GNAT_Version and Ada_Main_Program_Name info only for -- the main program. Otherwise, it can lead under some circumstances -- to a symbol duplication during the link (for instance when a -- C program uses 2 Ada libraries) @@ -1961,8 +2012,8 @@ package body Bindgen is WBI (""); WBI ("extern void __gnat_set_globals "); - WBI (" PARAMS ((int, int, int, int, int, int, "); - WBI (" void (*) PARAMS ((void)), int, int));"); + WBI (" PARAMS ((int, int, int, int, int, int, const char *,"); + WBI (" int, int, int));"); WBI ("extern void " & Ada_Final_Name.all & " PARAMS ((void));"); WBI ("extern void " & Ada_Init_Name.all & " PARAMS ((void));"); @@ -2602,7 +2653,8 @@ package body Bindgen is function Get_Main_Name return String is Target : constant String_Ptr := Target_Name; VxWorks_Target : constant Boolean := - Target (Target'Last - 7 .. Target'Last) = "vxworks/"; + Target (Target'Last - 7 .. Target'Last) = "vxworks/" + or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/"; begin -- Explicit name given with -M switch @@ -2622,7 +2674,7 @@ package body Bindgen is -- since we can't have dots in a nested program name. Note that -- we do not include the %b at the end of the unit name. - for J in reverse 1 .. Name_Len - 3 loop + for J in reverse 1 .. Name_Len - 2 loop if J = 1 or else Name_Buffer (J - 1) = '.' then return Name_Buffer (J .. Name_Len - 2); end if; @@ -2643,27 +2695,27 @@ package body Bindgen is function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is begin + -- Sort internal files last + if Linker_Options.Table (Op1).Internal_File /= Linker_Options.Table (Op2).Internal_File then + -- Note: following test uses False < True + return Linker_Options.Table (Op1).Internal_File < - Linker_Options.Table (Op2).Internal_File; + Linker_Options.Table (Op2).Internal_File; + + -- If both internal or both non-internal, sort according to the + -- elaboration position. A unit that is elaborated later should + -- come earlier in the linker options list. + else - if Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position - /= - Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position - then - return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position - > - Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position; + return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position + > + Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position; - else - return Linker_Options.Table (Op1).Original_Pos - < - Linker_Options.Table (Op2).Original_Pos; - end if; end if; end Lt_Linker_Option; @@ -2889,31 +2941,6 @@ package body Bindgen is end loop; end Tab_To; - ----------- - -- Value -- - ----------- - - function Value (chars : chars_ptr) return String is - function Strlen (chars : chars_ptr) return Natural; - pragma Import (C, Strlen); - - begin - if chars = Null_Address then - return ""; - - else - declare - subtype Result_Type is String (1 .. Strlen (chars)); - - Result : Result_Type; - for Result'Address use chars; - - begin - return Result; - end; - end if; - end Value; - ---------------------- -- Write_Info_Ada_C -- ---------------------- diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb index cc7fdb93039..24772ed5daa 100644 --- a/gcc/ada/bindusg.adb +++ b/gcc/ada/bindusg.adb @@ -31,15 +31,6 @@ with Output; use Output; procedure Bindusg is - procedure Write_Switch_Char; - -- Write two spaces followed by appropriate switch character - - procedure Write_Switch_Char is - begin - Write_Str (" "); - Write_Char (Switch_Character); - end Write_Switch_Char; - -- Start of processing for Bindusg begin @@ -54,207 +45,186 @@ begin -- Line for -aO switch - Write_Switch_Char; - Write_Str ("aOdir Specify library files search path"); + Write_Str (" -aOdir Specify library files search path"); Write_Eol; -- Line for -aI switch - Write_Switch_Char; - Write_Str ("aIdir Specify source files search path"); + Write_Str (" -aIdir Specify source files search path"); Write_Eol; -- Line for A switch - Write_Switch_Char; - Write_Str ("A Generate binder program in Ada (default)"); + Write_Str (" -A Generate binder program in Ada (default)"); Write_Eol; -- Line for -b switch - Write_Switch_Char; - Write_Str ("b Generate brief messages to std"); + Write_Str (" -b Generate brief messages to std"); Write_Str ("err even if verbose mode set"); Write_Eol; -- Line for -c switch - Write_Switch_Char; - Write_Str ("c Check only, no generation of b"); + Write_Str (" -c Check only, no generation of b"); Write_Str ("inder output file"); Write_Eol; -- Line for C switch - Write_Switch_Char; - Write_Str ("C Generate binder program in C"); + Write_Str (" -C Generate binder program in C"); Write_Eol; -- Line for -e switch - Write_Switch_Char; - Write_Str ("e Output complete list of elabor"); + Write_Str (" -e Output complete list of elabor"); Write_Str ("ation order dependencies"); Write_Eol; -- Line for -E switch - Write_Switch_Char; - Write_Str ("E Store tracebacks in Exception occurrences"); + Write_Str (" -E Store tracebacks in Exception occurrences"); Write_Eol; -- Line for -h switch - Write_Switch_Char; - Write_Str ("h Output this usage (help) infor"); + Write_Str (" -h Output this usage (help) infor"); Write_Str ("mation"); Write_Eol; -- Lines for -I switch - Write_Switch_Char; - Write_Str ("Idir Specify library and source files search path"); + Write_Str (" -Idir Specify library and source files search path"); Write_Eol; - Write_Switch_Char; - Write_Str ("I- Don't look for sources & library files"); + Write_Str (" -I- Don't look for sources & library files"); Write_Str (" in default directory"); Write_Eol; -- Line for -K switch - Write_Switch_Char; - Write_Str ("K Give list of linker options specified for link"); + Write_Str (" -K Give list of linker options specified for link"); Write_Eol; -- Line for -l switch - Write_Switch_Char; - Write_Str ("l Output chosen elaboration order"); + Write_Str (" -l Output chosen elaboration order"); Write_Eol; -- Line of -L switch - Write_Switch_Char; - Write_Str ("Lxyz Library build: adainit/final "); + Write_Str (" -Lxyz Library build: adainit/final "); Write_Str ("renamed to xyzinit/final, implies -n"); Write_Eol; -- Line for -M switch - Write_Switch_Char; - Write_Str ("Mxyz Rename generated main program from main to xyz"); + Write_Str (" -Mxyz Rename generated main program from main to xyz"); Write_Eol; -- Line for -m switch - Write_Switch_Char; - Write_Str ("mnnn Limit number of detected error"); + Write_Str (" -mnnn Limit number of detected error"); Write_Str ("s to nnn (1-999)"); Write_Eol; -- Line for -n switch - Write_Switch_Char; - Write_Str ("n No Ada main program (foreign main routine)"); + Write_Str (" -n No Ada main program (foreign main routine)"); Write_Eol; -- Line for -nostdinc - Write_Switch_Char; - Write_Str ("nostdinc Don't look for source files"); + Write_Str (" -nostdinc Don't look for source files"); Write_Str (" in the system default directory"); Write_Eol; -- Line for -nostdlib - Write_Switch_Char; - Write_Str ("nostdlib Don't look for library files"); + Write_Str (" -nostdlib Don't look for library files"); Write_Str (" in the system default directory"); Write_Eol; -- Line for -o switch - Write_Switch_Char; - Write_Str ("o file Give the output file name (default is b~xxx.adb) "); + Write_Str (" -o file Give the output file name (default is b~xxx.adb) "); Write_Eol; -- Line for -O switch - Write_Switch_Char; - Write_Str ("O Give list of objects required for link"); + Write_Str (" -O Give list of objects required for link"); Write_Eol; -- Line for -p switch - Write_Switch_Char; - Write_Str ("p Pessimistic (worst-case) elaborat"); + Write_Str (" -p Pessimistic (worst-case) elaborat"); Write_Str ("ion order"); Write_Eol; + -- Line for -r switch + + Write_Str (" -r List restrictions that could be a"); + Write_Str ("pplied to this partition"); + Write_Eol; + -- Line for -s switch - Write_Switch_Char; - Write_Str ("s Require all source files to be"); + Write_Str (" -s Require all source files to be"); Write_Str (" present"); Write_Eol; -- Line for -Sxx switch - Write_Switch_Char; - Write_Str ("S?? Sin/lo/hi/xx for Initialize_Scalars"); + Write_Str (" -S?? Sin/lo/hi/xx for Initialize_Scalars"); Write_Str (" invalid/low/high/hex"); Write_Eol; -- Line for -static - Write_Switch_Char; - Write_Str ("static Link against a static GNAT run time"); + Write_Str (" -static Link against a static GNAT run time"); Write_Eol; -- Line for -shared - Write_Switch_Char; - Write_Str ("shared Link against a shared GNAT run time"); + Write_Str (" -shared Link against a shared GNAT run time"); Write_Eol; -- Line for -t switch - Write_Switch_Char; - Write_Str ("t Tolerate time stamp and other consistency errors"); + Write_Str (" -t Tolerate time stamp and other consistency errors"); Write_Eol; -- Line for -T switch - Write_Switch_Char; - Write_Str ("Tn Set time slice value to n microseconds (n >= 0)"); + Write_Str (" -Tn Set time slice value to n microseconds (n >= 0)"); Write_Eol; -- Line for -v switch - Write_Switch_Char; - Write_Str ("v Verbose mode. Error messages, "); + Write_Str (" -v Verbose mode. Error messages, "); Write_Str ("header, summary output to stdout"); Write_Eol; -- Lines for -w switch - Write_Switch_Char; - Write_Str ("wx Warning mode. (x=s/e for supp"); + Write_Str (" -wx Warning mode. (x=s/e for supp"); Write_Str ("ress/treat as error)"); Write_Eol; -- Line for -x switch - Write_Switch_Char; - Write_Str ("x Exclude source files (check ob"); + Write_Str (" -x Exclude source files (check ob"); Write_Str ("ject consistency only)"); Write_Eol; -- Line for -z switch - Write_Switch_Char; - Write_Str ("z No main subprogram (zero main)"); + Write_Str (" -z No main subprogram (zero main)"); + Write_Eol; + + -- Line for --RTS + + Write_Str (" --RTS=dir specify the default source and object search path"); Write_Eol; -- Line for sfile diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 6f0c87974bf..1bd28ad8df3 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -47,6 +47,7 @@ with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Urealp; use Urealp; @@ -197,7 +198,9 @@ package body Checks is else Append_To - (Stmts, Make_Raise_Constraint_Error (Internal_Static_Sloc)); + (Stmts, + Make_Raise_Constraint_Error (Internal_Static_Sloc, + Reason => CE_Range_Check_Failed)); end if; end loop; end Append_Range_Checks; @@ -272,7 +275,8 @@ package body Checks is Condition => Make_Op_Gt (Loc, Left_Opnd => Param_Level, - Right_Opnd => Type_Level))); + Right_Opnd => Type_Level), + Reason => PE_Accessibility_Check_Failed)); Analyze_And_Resolve (N); end if; @@ -315,11 +319,12 @@ package body Checks is and then Known_Alignment (E) then if Expr_Value (Expr) mod Alignment (E) /= 0 then - Insert_Action (N, - Make_Raise_Program_Error (Loc)); - Error_Msg_NE - ("?specified address for& not " & - "consistent with alignment", Expr, E); + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Misaligned_Address_Value)); + Error_Msg_NE + ("?specified address for& not " & + "consistent with alignment", Expr, E); end if; -- Here we do not know if the value is acceptable, generate @@ -343,7 +348,8 @@ package body Checks is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Alignment)), - Right_Opnd => Make_Integer_Literal (Loc, Uint_0))), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), + Reason => PE_Misaligned_Address_Value), Suppress => All_Checks); end if; end if; @@ -377,9 +383,9 @@ package body Checks is OK : Boolean; begin - if not Software_Overflow_Checking - or else not Do_Overflow_Check (N) - or else not Expander_Active + if Backend_Overflow_Checks_On_Target + or not Do_Overflow_Check (N) + or not Expander_Active then return; end if; @@ -682,7 +688,8 @@ package body Checks is if Static and then Siz >= Check_Siz then Insert_Action (N, - Make_Raise_Storage_Error (Loc)); + Make_Raise_Storage_Error (Loc, + Reason => SE_Object_Too_Large)); Warn_On_Instance := True; Error_Msg_N ("?Storage_Error will be raised at run-time", N); Warn_On_Instance := False; @@ -739,11 +746,11 @@ package body Checks is Make_Op_Ge (Loc, Left_Opnd => Sizx, Right_Opnd => - Make_Integer_Literal (Loc, Check_Siz))); + Make_Integer_Literal (Loc, Check_Siz)), + Reason => SE_Object_Too_Large); Set_Size_Check_Code (Defining_Identifier (N), Code); Insert_Action (N, Code); - end Apply_Array_Size_Check; ---------------------------- @@ -1026,7 +1033,8 @@ package body Checks is exit; else Apply_Compile_Time_Constraint_Error - (N, "incorrect value for discriminant&?", Ent => Discr); + (N, "incorrect value for discriminant&?", + CE_Discriminant_Check_Failed, Ent => Discr); return; end if; end if; @@ -1070,7 +1078,9 @@ package body Checks is end if; Insert_Action (N, - Make_Raise_Constraint_Error (Loc, Condition => Cond)); + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Discriminant_Check_Failed)); end Apply_Discriminant_Check; @@ -1094,7 +1104,7 @@ package body Checks is begin if Expander_Active - and then Software_Overflow_Checking + and not Backend_Divide_Checks_On_Target then Determine_Range (Right, ROK, Rlo, Rhi); @@ -1109,7 +1119,8 @@ package body Checks is Condition => Make_Op_Eq (Loc, Left_Opnd => Duplicate_Subexpr (Right), - Right_Opnd => Make_Integer_Literal (Loc, 0)))); + Right_Opnd => Make_Integer_Literal (Loc, 0)), + Reason => CE_Divide_By_Zero)); end if; end if; @@ -1139,7 +1150,8 @@ package body Checks is Make_Op_Eq (Loc, Left_Opnd => Duplicate_Subexpr (Right), Right_Opnd => - Make_Integer_Literal (Loc, -1))))); + Make_Integer_Literal (Loc, -1))), + Reason => CE_Overflow_Check_Failed)); end if; end if; end if; @@ -1211,7 +1223,7 @@ package body Checks is procedure Bad_Value is begin Apply_Compile_Time_Constraint_Error - (Expr, "value not in range of}?", + (Expr, "value not in range of}?", CE_Range_Check_Failed, Ent => Target_Typ, Typ => Target_Typ); end Bad_Value; @@ -1439,7 +1451,7 @@ package body Checks is (not Length_Checks_Suppressed (Target_Typ)); begin - if not Expander_Active or else not Checks_On then + if not Expander_Active then return; end if; @@ -1478,13 +1490,14 @@ package body Checks is then Cond := Condition (R_Cno); - if not Has_Dynamic_Length_Check (Ck_Node) then + if not Has_Dynamic_Length_Check (Ck_Node) + and then Checks_On + then Insert_Action (Ck_Node, R_Cno); if not Do_Static then Set_Has_Dynamic_Length_Check (Ck_Node); end if; - end if; -- Output a warning if the condition is known to be True @@ -1494,6 +1507,7 @@ package body Checks is then Apply_Compile_Time_Constraint_Error (Ck_Node, "wrong length for array of}?", + CE_Length_Check_Failed, Ent => Target_Typ, Typ => Target_Typ); @@ -1576,6 +1590,7 @@ package body Checks is if Nkind (Ck_Node) = N_Range then Apply_Compile_Time_Constraint_Error (Low_Bound (Ck_Node), "static range out of bounds of}?", + CE_Range_Check_Failed, Ent => Target_Typ, Typ => Target_Typ); @@ -1584,6 +1599,7 @@ package body Checks is else Apply_Compile_Time_Constraint_Error (Ck_Node, "static value out of range of}?", + CE_Range_Check_Failed, Ent => Target_Typ, Typ => Target_Typ); end if; @@ -1661,10 +1677,10 @@ package body Checks is if Inside_A_Generic then return; - -- Skip these checks if errors detected, there are some nasty + -- Skip these checks if serious errors detected, there are some nasty -- situations of incomplete trees that blow things up. - elsif Errors_Detected > 0 then + elsif Serious_Errors_Detected > 0 then return; -- Scalar type conversions of the form Target_Type (Expr) require @@ -1778,7 +1794,9 @@ package body Checks is Set_Discriminant_Constraint (Expr_Type, Old_Constraints); Insert_Action (N, - Make_Raise_Constraint_Error (Loc, Condition => Cond)); + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Discriminant_Check_Failed)); end; -- should there be other checks here for array types ??? @@ -2774,7 +2792,8 @@ package body Checks is else Check_Node := - Make_Raise_Constraint_Error (Internal_Static_Sloc); + Make_Raise_Constraint_Error (Internal_Static_Sloc, + Reason => CE_Range_Check_Failed); Mark_Rewrite_Insertion (Check_Node); if Do_Before then @@ -2812,7 +2831,7 @@ package body Checks is Exp := Expression (Exp); end loop; - -- insert the validity check. Note that we do this with validity + -- Insert the validity check. Note that we do this with validity -- checks turned off, to avoid recursion, we do not want validity -- checks on the validity checking code itself! @@ -2826,7 +2845,8 @@ package body Checks is Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr (Exp, Name_Req => True), - Attribute_Name => Name_Valid))), + Attribute_Name => Name_Valid)), + Reason => CE_Invalid_Data), Suppress => All_Checks); Validity_Checks_On := True; end Insert_Valid_Check; @@ -2840,7 +2860,9 @@ package body Checks is Typ : constant Entity_Id := Etype (R_Cno); begin - Rewrite (R_Cno, Make_Raise_Constraint_Error (Loc)); + Rewrite (R_Cno, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Range_Check_Failed)); Set_Analyzed (R_Cno); Set_Etype (R_Cno, Typ); Set_Raises_Constraint_Error (R_Cno); @@ -3274,7 +3296,8 @@ package body Checks is for Indx in 1 .. Ndims loop if not (Nkind (L_Index) = N_Raise_Constraint_Error - or else Nkind (R_Index) = N_Raise_Constraint_Error) + or else + Nkind (R_Index) = N_Raise_Constraint_Error) then Get_Index_Bounds (L_Index, L_Low, L_High); Get_Index_Bounds (R_Index, R_Low, R_High); @@ -3351,7 +3374,7 @@ package body Checks is else declare - Ndims : Nat := Number_Dimensions (T_Typ); + Ndims : Nat := Number_Dimensions (T_Typ); begin -- Build the condition for the explicit dereference case @@ -3372,11 +3395,13 @@ package body Checks is Cond := Guard_Access (Cond, Loc, Ck_Node); end if; - Add_Check (Make_Raise_Constraint_Error (Loc, Condition => Cond)); + Add_Check + (Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Length_Check_Failed)); end if; return Ret_Result; - end Selected_Length_Checks; --------------------------- @@ -4074,7 +4099,8 @@ package body Checks is for Indx in 1 .. Ndims loop if not (Nkind (L_Index) = N_Raise_Constraint_Error - or else Nkind (R_Index) = N_Raise_Constraint_Error) + or else + Nkind (R_Index) = N_Raise_Constraint_Error) then Get_Index_Bounds (L_Index, L_Low, L_High); Get_Index_Bounds (R_Index, R_Low, R_High); @@ -4193,11 +4219,13 @@ package body Checks is Cond := Guard_Access (Cond, Loc, Ck_Node); end if; - Add_Check (Make_Raise_Constraint_Error (Loc, Condition => Cond)); + Add_Check + (Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Range_Check_Failed)); end if; return Ret_Result; - end Selected_Range_Checks; ------------------------------- diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index 55d8c89841a..a3ffd6d74bd 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -76,17 +76,31 @@ package body Comperr is (X : String; Code : Integer := 0) is + -- The procedures below output a "bug box" with information about + -- the cause of the compiler abort and about the preferred method + -- of reporting bugs. The default is a bug box appropriate for + -- the FSF version of GNAT, but there are specializations for + -- the GNATPRO and Public releases by Ada Core Technologies. + + Public_Version : constant Boolean := Gnat_Version_Type = "PUBLIC "; + -- Set True for the public version of GNAT + + GNATPRO_Version : constant Boolean := Gnat_Version_Type = "GNATPRO"; + -- Set True for the GNATPRO version of GNAT + procedure End_Line; -- Add blanks up to column 76, and then a final vertical bar + -------------- + -- End_Line -- + -------------- + procedure End_Line is begin Repeat_Char (' ', 76, '|'); Write_Eol; end End_Line; - Public_Version : constant Boolean := (Gnat_Version_String (5) = 'p'); - -- Start of processing for Compiler_Abort begin @@ -98,13 +112,13 @@ package body Comperr is Abort_In_Progress := True; - -- If errors have already occurred, then we guess that the abort may - -- well be caused by previous errors, and we don't make too much fuss - -- about it, since we want to let the programmer fix the errors first. + -- If any errors have already occurred, then we guess that the abort + -- may well be caused by previous errors, and we don't make too much + -- fuss about it, since we want to let programmer fix the errors first. -- Debug flag K disables this behavior (useful for debugging) - if Errors_Detected /= 0 and then not Debug_Flag_K then + if Total_Errors_Detected /= 0 and then not Debug_Flag_K then Errout.Finalize; Set_Standard_Error; @@ -252,16 +266,25 @@ package body Comperr is -- Otherwise we use the standard fixed text else - Write_Str - ("| Please submit bug report by email to report@gnat.com."); - End_Line; + if Public_Version or GNATPRO_Version then + Write_Str + ("| Please submit bug report by email " & + "to report@gnat.com."); + End_Line; - if not Public_Version then + else Write_Str - ("| Use a subject line meaningful to you" & - " and us to track the bug."); + ("| Please submit bug report by email " & + "to gcc-bugs@gcc.gnu.org."); End_Line; + end if; + + Write_Str + ("| Use a subject line meaningful to you" & + " and us to track the bug."); + End_Line; + if GNATPRO_Version then Write_Str ("| (include your customer number #nnn " & "in the subject line)."); @@ -286,7 +309,7 @@ package body Comperr is ("| (concatenated together with no headers between files)."); End_Line; - if Public_Version then + if not GNATPRO_Version then Write_Str ("| (use plain ASCII or MIME attachment)."); End_Line; diff --git a/gcc/ada/config-lang.in b/gcc/ada/config-lang.in index d3812176f2b..d9029c14b8d 100644 --- a/gcc/ada/config-lang.in +++ b/gcc/ada/config-lang.in @@ -25,6 +25,7 @@ # boot_language - "yes" if we need to build this language in stage1 # compilers - value to add to $(COMPILERS) # stagestuff - files to add to $(STAGESTUFF) +# diff_excludes - files to ignore when building diffs between two versions. language="ada" boot_language=yes @@ -34,4 +35,6 @@ compilers="gnat1\$(exeext)" stagestuff="gnatbind\$(exeext) gnat1\$(exeext)" +diff_excludes="-x ada/a-einfo.h -x ada/a-sinfo.h -x ada/nmake.adb -x ada/nmake.ads -x ada/treeprs.ads -x ada/sysid.ads" + outputs=ada/Makefile diff --git a/gcc/ada/csets.adb b/gcc/ada/csets.adb index 9bf755acf61..8e4f9935978 100644 --- a/gcc/ada/csets.adb +++ b/gcc/ada/csets.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -168,9 +168,9 @@ package body Csets is X_FE : constant Character := Character'Val (16#FE#); X_FF : constant Character := Character'Val (16#FF#); - ----------------------------- - -- Definitions for Latin-1 -- - ----------------------------- + ------------------------------------------ + -- Definitions for Latin-1 (ISO 8859-1) -- + ------------------------------------------ Fold_Latin_1 : Translate_Table := Translate_Table'( @@ -243,9 +243,9 @@ package body Csets is others => ' '); - ----------------------------- - -- Definitions for Latin-2 -- - ----------------------------- + ------------------------------------------ + -- Definitions for Latin-2 (ISO 8859-2) -- + ------------------------------------------ Fold_Latin_2 : Translate_Table := Translate_Table'( @@ -318,9 +318,9 @@ package body Csets is others => ' '); - ----------------------------- - -- Definitions for Latin-3 -- - ----------------------------- + ------------------------------------------ + -- Definitions for Latin-3 (ISO 8859-3) -- + ------------------------------------------ Fold_Latin_3 : Translate_Table := Translate_Table'( @@ -393,9 +393,9 @@ package body Csets is others => ' '); - ----------------------------- - -- Definitions for Latin-4 -- - ----------------------------- + ------------------------------------------ + -- Definitions for Latin-4 (ISO 8859-4) -- + ------------------------------------------ Fold_Latin_4 : Translate_Table := Translate_Table'( @@ -543,6 +543,81 @@ package body Csets is others => ' '); + ------------------------------------------ + -- Definitions for Latin-9 (ISO 8859-9) -- + ------------------------------------------ + + Fold_Latin_9 : Translate_Table := Translate_Table'( + + 'a' => 'A', X_E0 => X_C0, X_F0 => X_D0, + 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, + 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, + 'd' => 'D', X_E3 => X_C3, X_F3 => X_D3, + 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, + 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, + 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, + 'h' => 'H', X_E7 => X_C7, + 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, + 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, + 'k' => 'K', X_EA => X_CA, X_FA => X_DA, + 'l' => 'L', X_EB => X_CB, X_FB => X_DB, + 'm' => 'M', X_EC => X_CC, X_FC => X_DC, + 'n' => 'N', X_ED => X_CD, X_FD => X_DD, + 'o' => 'O', X_EE => X_CE, X_FE => X_DE, + 'p' => 'P', X_EF => X_CF, + 'q' => 'Q', X_A8 => X_A6, + 'r' => 'R', X_B8 => X_B4, + 's' => 'S', X_BD => X_BC, + 't' => 'T', X_BE => X_FF, + 'u' => 'U', + 'v' => 'V', + 'w' => 'W', + 'x' => 'X', + 'y' => 'Y', + 'z' => 'Z', + + 'A' => 'A', X_C0 => X_C0, X_D0 => X_D0, + 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, + 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, + 'D' => 'D', X_C3 => X_C3, X_D3 => X_D3, + 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, + 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, + 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, + 'H' => 'H', X_C7 => X_C7, + 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, + 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, + 'K' => 'K', X_CA => X_CA, X_DA => X_DA, + 'L' => 'L', X_CB => X_CB, X_DB => X_DB, + 'M' => 'M', X_CC => X_CC, X_DC => X_DC, + 'N' => 'N', X_CD => X_CD, X_DD => X_DD, + 'O' => 'O', X_CE => X_CE, X_DE => X_DE, + 'P' => 'P', X_CF => X_CF, X_DF => X_DF, X_FF => X_FF, + 'Q' => 'Q', X_A6 => X_A6, + 'R' => 'R', X_B4 => X_B4, + 'S' => 'S', X_BC => X_BC, + 'T' => 'T', + 'U' => 'U', + 'V' => 'V', + 'W' => 'W', + 'X' => 'X', + 'Y' => 'Y', + 'Z' => 'Z', + + '0' => '0', + '1' => '1', + '2' => '2', + '3' => '3', + '4' => '4', + '5' => '5', + '6' => '6', + '7' => '7', + '8' => '8', + '9' => '9', + + '_' => '_', + + others => ' '); + -------------------------------------------- -- Definitions for IBM PC (Code Page 437) -- -------------------------------------------- @@ -1024,7 +1099,6 @@ package body Csets is procedure Initialize is begin - -- Set Fold_Upper table from source code indication if Identifier_Character_Set = '1' @@ -1050,6 +1124,9 @@ package body Csets is elsif Identifier_Character_Set = '8' then Fold_Upper := Fold_IBM_PC_850; + elsif Identifier_Character_Set = '9' then + Fold_Upper := Fold_Latin_9; + elsif Identifier_Character_Set = 'f' then Fold_Upper := Fold_Full_Upper_Half; diff --git a/gcc/ada/csets.ads b/gcc/ada/csets.ads index c69fc9da986..09952d2dd30 100644 --- a/gcc/ada/csets.ads +++ b/gcc/ada/csets.ads @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -64,13 +64,14 @@ pragma Elaborate_Body (Csets); -- The character set in use is specified by the value stored in -- Opt.Identifier_Character_Set, which has the following settings: - -- '1' Latin-1 - -- '2' Latin-2 - -- '3' Latin-3 - -- '4' Latin-4 - -- '5' Latin-5 (Cyrillic ISO-8859-5) - -- 'p' IBM PC (code page 437) - -- '8' IBM PC (code page 850) + -- '1' Latin-1 (ISO-8859-1) + -- '2' Latin-2 (ISO-8859-2) + -- '3' Latin-3 (ISO-8859-3) + -- '4' Latin-4 (ISO-8859-4) + -- '5' Latin-5 (ISO-8859-5, Cyrillic) + -- 'p' IBM PC (code page 437) + -- '8' IBM PC (code page 850) + -- '9' Latin-9 (ISO-9959-9) -- 'f' Full upper set (all distinct) -- 'n' No upper characters (Ada/83 rules) -- 'w' Latin-1 plus wide characters also allowed diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 75378b579f7..e0e8a655ebf 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -353,7 +353,7 @@ package body CStand is Set_Ekind (Standard_Boolean, E_Enumeration_Type); Set_First_Literal (Standard_Boolean, Standard_False); Set_Etype (Standard_Boolean, Standard_Boolean); - Init_Esize (Standard_Boolean, 8); + Init_Esize (Standard_Boolean, Standard_Character_Size); Init_RM_Size (Standard_Boolean, 1); Set_Prim_Alignment (Standard_Boolean); @@ -471,7 +471,8 @@ package body CStand is Set_Ekind (Standard_Character, E_Enumeration_Type); Set_Etype (Standard_Character, Standard_Character); - Init_Size (Standard_Character, Standard_Character_Size); + Init_Esize (Standard_Character, Standard_Character_Size); + Init_RM_Size (Standard_Character, 8); Set_Prim_Alignment (Standard_Character); Set_Is_Unsigned_Type (Standard_Character); @@ -800,7 +801,7 @@ package body CStand is Set_Ekind (Any_Boolean, E_Enumeration_Type); Set_Scope (Any_Boolean, Standard_Standard); Set_Etype (Any_Boolean, Standard_Boolean); - Init_Esize (Any_Boolean, 8); + Init_Esize (Any_Boolean, Standard_Character_Size); Init_RM_Size (Any_Boolean, 1); Set_Prim_Alignment (Any_Boolean); Set_Is_Unsigned_Type (Any_Boolean); @@ -813,7 +814,8 @@ package body CStand is Set_Etype (Any_Character, Any_Character); Set_Is_Unsigned_Type (Any_Character); Set_Is_Character_Type (Any_Character); - Init_Size (Any_Character, Standard_Character_Size); + Init_Esize (Any_Character, Standard_Character_Size); + Init_RM_Size (Any_Character, 8); Set_Prim_Alignment (Any_Character); Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character)); Make_Name (Any_Character, "a character type"); diff --git a/gcc/ada/cstreams.c b/gcc/ada/cstreams.c index 6411fdc6558..dbff6afe20d 100644 --- a/gcc/ada/cstreams.c +++ b/gcc/ada/cstreams.c @@ -53,7 +53,7 @@ int max_path_len = _MAX_PATH; #elif defined (VMS) #include <unixlib.h> -int max_path_len = 255; /* PATH_MAX */ +int max_path_len = 4096; /* PATH_MAX */ #elif defined (__vxworks) || defined (__OPENNT) @@ -182,7 +182,7 @@ __gnat_full_name (nam, buffer) #if defined(__EMX__) || defined (__MINGW32__) /* If this is a device file return it as is; under Windows NT and OS/2 a device file end with ":". */ - if (nam [strlen (nam) - 1] == ':') + if (nam[strlen (nam) - 1] == ':') strcpy (buffer, nam); else { @@ -211,7 +211,7 @@ __gnat_full_name (nam, buffer) strcpy (buffer, __gnat_to_host_file_spec (buffer)); else { - char nambuffer [MAXPATHLEN]; + char *nambuffer = alloca (max_path_len); strcpy (nambuffer, buffer); strcpy (buffer, getcwd (buffer, max_path_len, 0)); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index d80c8e6aa71..7887e804502 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -57,7 +57,7 @@ package body Debug is -- dn Generate messages for node/list allocation -- do Print source from tree (original code only) -- dp Generate messages for parser scope stack push/pops - -- dq + -- dq No auto-alignment of small records -- dr Generate parser resynchronization messages -- ds Print source from tree (including original and generated stuff) -- dt Print full tree @@ -74,13 +74,13 @@ package body Debug is -- dD Delete elaboration checks in inner level routines -- dE Apply elaboration checks to predefined units -- dF Front end data layout enabled. - -- dG Generate input showing file creating info for debug file + -- dG -- dH Hold (kill) call to gigi -- dI Inhibit internal name numbering in gnatG listing -- dJ Output debugging trace info for JGNAT (Java VM version of GNAT) -- dK Kill all error messages -- dL Output trace information on elaboration checking - -- dM Modified ali file output + -- dM -- dN Do not generate file/line exception messages -- dO Output immediate error messages -- dP Do not check for controlled objects in preelaborable packages @@ -124,7 +124,7 @@ package body Debug is -- do -- dp -- dq - -- dr List additional restrictions that may be specified + -- dr -- ds -- dt -- du List units as they are acquired @@ -166,7 +166,7 @@ package body Debug is -- dr -- ds -- dt - -- du + -- du List units as their ali files are acquired -- dv -- dw Prints the list of units withed by the unit currently explored -- dx @@ -192,6 +192,10 @@ package body Debug is -- resolved, or evaluated. This option is useful for finding out -- exactly where a bomb during semantic analysis is occurring. + -- dA Normally the output from -gnatR excludes private types and all + -- internal entities. This debug flag causes representation info + -- for these entities to be output as well. + -- db In Exp_Dbug, certain type names are encoded to include debugging -- information. This debug switch causes lines to be output showing -- the encodings used. @@ -238,9 +242,6 @@ package body Debug is -- non-source generated null statements, and freeze nodes, which -- are normally omitted in -gnatG mode. - -- dG Print trace information showing calls to Create_Debug_Source and - -- Write_Debug_Line. Used for debugging -gnatD operation problems. - -- dh Generates a table at the end of a compilation showing how the hash -- table chains built by the Namet package are loaded. This is useful -- in ensuring that the hashing algorithm (in Namet.Hash) is working @@ -284,11 +285,6 @@ package body Debug is -- attempting to generate code with this flag set may blow up. -- The flag also forces the use of 64-bits for Long_Integer. - -- dM Generate modified ALI output. Several ALI extensions are being - -- developed for version 3.15w, and this switch is used to enable - -- these extensions. This switch will disappear when this work is - -- completed. - -- dn Generate messages for node/list allocation. Each time a node or -- list header is allocated, a line of output is generated. Certain -- other basic tree operations also cause a line of output to be @@ -308,6 +304,12 @@ package body Debug is -- pushed or popped. Useful in debugging situations where the -- parser scope stack ends up incorrectly synchronized + -- dq In layout version 1.38, 2002/01/12, a circuit was implemented + -- to give decent default alignment to short records that had no + -- specific alignment set. This debug option restores the previous + -- behavior of giving such records poor alignments, typically 1. + -- This may be useful in dealing with transition. + -- dr Generate parser resynchronization messages. Normally the parser -- resynchronizes quietly. With this debug option, two messages -- are generated, one when the parser starts a resynchronization @@ -463,9 +465,6 @@ package body Debug is -- the algorithm used to determine a correct order of elaboration. This -- is useful in diagnosing any problems in its behavior. - -- dr List restrictions which have not been specified, but could have - -- been without causing bind errors. - -- du List unit name and file name for each unit as it is read in ------------------------------------------------------------ diff --git a/gcc/ada/debug.ads b/gcc/ada/debug.ads index dcc849bafbf..e1735274bcd 100644 --- a/gcc/ada/debug.ads +++ b/gcc/ada/debug.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.31 $ +-- $Revision$ -- -- --- Copyright (C) 1992-1999 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- -- @@ -37,16 +37,17 @@ package Debug is pragma Preelaborate (Debug); -- This package contains global flags used to control the inclusion --- of debugging code in various phases of the compiler. +-- of debugging code in various phases of the compiler. Some of these +-- flags are also used by the binder and gnatmake. ------------------------- -- Dynamic Debug Flags -- ------------------------- - -- Thirty six flags that can be used to active various specialized + -- Sixty two flags that can be used to active various specialized -- debugging output information. The flags are preset to False, which -- corresponds to the given output being suppressed. The individual - -- flags can be turned on using the undocumented switch /dxxx where + -- flags can be turned on using the undocumented switch dxxx where -- xxx is a string of letters for flags to be turned on. Documentation -- on the current usage of these flags is contained in the body of Debug -- rather than the spec, so that we don't have to recompile the world diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index 9cf7815b7c0..4b3b3a3ad4c 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -8,7 +8,7 @@ * * * $Revision$ * * - * Copyright (C) 1992-2001, 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- * @@ -100,7 +100,8 @@ static void components_to_record PARAMS ((tree, Node_Id, tree, int, static int compare_field_bitpos PARAMS ((const PTR, const PTR)); static Uint annotate_value PARAMS ((tree)); static void annotate_rep PARAMS ((Entity_Id, tree)); -static tree compute_field_positions PARAMS ((tree, tree, tree, tree)); +static tree compute_field_positions PARAMS ((tree, tree, tree, tree, + unsigned int)); static tree validate_size PARAMS ((Uint, tree, Entity_Id, enum tree_code, int, int)); static void set_rm_size PARAMS ((Uint, tree, Entity_Id)); @@ -579,18 +580,11 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) if (TREE_CODE (gnu_size) != INTEGER_CST && contains_placeholder_p (gnu_size)) { - tree gnu_temp = gnu_expr; - - /* Strip off any conversions in GNU_EXPR since - they can't be changing the size to allocate. */ - while (TREE_CODE (gnu_temp) == UNCHECKED_CONVERT_EXPR) - gnu_temp = TREE_OPERAND (gnu_temp, 0); - - gnu_size = TYPE_SIZE (TREE_TYPE (gnu_temp)); + gnu_size = TYPE_SIZE (TREE_TYPE (gnu_expr)); if (TREE_CODE (gnu_size) != INTEGER_CST && contains_placeholder_p (gnu_size)) gnu_size = build (WITH_RECORD_EXPR, bitsizetype, - gnu_size, gnu_temp); + gnu_size, gnu_expr); } } @@ -687,6 +681,15 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) check_ok_for_atomic (gnu_inner, gnat_entity, 1); } + /* Now check if the type of the object allows atomic access. Note + that we must test the type, even if this object has size and + alignment to allow such access, because we will be going + inside the padded record to assign to the object. We could fix + this by always copying via an intermediate value, but it's not + clear it's worth the effort. */ + if (Is_Atomic (gnat_entity)) + check_ok_for_atomic (gnu_type, gnat_entity, 0); + /* Make a new type with the desired size and alignment, if needed. */ gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity, "PAD", 0, definition, 1); @@ -1047,13 +1050,11 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) gnu_expr, 0, Is_Public (gnat_entity), 0, static_p, 0); - if (Is_Atomic (gnat_entity)) - check_ok_for_atomic (gnu_decl, gnat_entity, 0); - /* If this is declared in a block that contains an block with an exception handler, we must force this variable in memory to suppress an invalid optimization. */ - if (Has_Nested_Block_With_Handler (Scope (gnat_entity))) + if (Has_Nested_Block_With_Handler (Scope (gnat_entity)) + && Exception_Mechanism != GCC_ZCX) { mark_addressable (gnu_decl); flush_addressof (gnu_decl); @@ -1624,13 +1625,13 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) /* If the maximum size doesn't overflow, use it. */ if (TREE_CODE (gnu_max_size) == INTEGER_CST && ! TREE_OVERFLOW (gnu_max_size)) - { - TYPE_SIZE (tem) - = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem)); - TYPE_SIZE_UNIT (tem) - = size_binop (MIN_EXPR, gnu_max_size_unit, - TYPE_SIZE_UNIT (tem)); - } + TYPE_SIZE (tem) + = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem)); + if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST + && ! TREE_OVERFLOW (gnu_max_size_unit)) + TYPE_SIZE_UNIT (tem) + = size_binop (MIN_EXPR, gnu_max_size_unit, + TYPE_SIZE_UNIT (tem)); create_type_decl (create_concat_name (gnat_entity, "XUA"), tem, 0, ! Comes_From_Source (gnat_entity), @@ -1977,6 +1978,8 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) && contains_placeholder_p (TYPE_SIZE (gnu_type)) && ! (TREE_CODE (gnu_max_size) == INTEGER_CST && TREE_OVERFLOW (gnu_max_size)) + && ! (TREE_CODE (gnu_max_size_unit) == INTEGER_CST + && TREE_OVERFLOW (gnu_max_size_unit)) && ! max_overflow) { TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size, @@ -2023,9 +2026,9 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) gnu_inner_type = gnu_type = TREE_TYPE (gnu_decl); save_gnu_tree (gnat_entity, NULL_TREE, 0); - if (TREE_CODE (gnu_inner_type) == RECORD_TYPE - && (TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_inner_type) - || TYPE_IS_PADDING_P (gnu_inner_type))) + while (TREE_CODE (gnu_inner_type) == RECORD_TYPE + && (TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_inner_type) + || TYPE_IS_PADDING_P (gnu_inner_type))) gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type)); /* We need to point the type we just made to our index type so @@ -2152,7 +2155,6 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) the tree. */ case E_Record_Type: -#if 0 if (Has_Complex_Representation (gnat_entity)) { gnu_type @@ -2164,13 +2166,9 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) (Type_Definition (Declaration_Node (gnat_entity))))))))); - /* ??? For now, don't use Complex if the real type is shorter than - a word. */ - if (GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (gnu_type))) - >= BITS_PER_WORD) - break; + + break; } -#endif { Node_Id full_definition = Declaration_Node (gnat_entity); @@ -2469,7 +2467,8 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) tree gnu_field_list = 0; tree gnu_pos_list = compute_field_positions (gnu_orig_type, NULL_TREE, - size_zero_node, bitsize_zero_node); + size_zero_node, bitsize_zero_node, + BIGGEST_ALIGNMENT); tree gnu_subst_list = substitution_list (gnat_entity, gnat_base_type, NULL_TREE, definition); @@ -2485,7 +2484,8 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) gnu_pos_list = compute_field_positions (gnat_to_gnu_type (Etype (gnat_root_type)), - gnu_pos_list, size_zero_node, bitsize_zero_node); + gnu_pos_list, size_zero_node, bitsize_zero_node, + BIGGEST_ALIGNMENT); if (Present (Parent_Subtype (gnat_root_type))) gnu_subst_list @@ -2511,11 +2511,14 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) = TREE_VALUE (purpose_member (gnu_old_field, gnu_pos_list)); tree gnu_pos = TREE_PURPOSE (gnu_offset); - tree gnu_bitpos = TREE_VALUE (gnu_offset); + tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset)); tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field)); tree gnu_size = TYPE_SIZE (gnu_field_type); tree gnu_new_pos = 0; + unsigned int offset_align + = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)), + 1); tree gnu_field; /* If there was a component clause, the field types must be @@ -2561,12 +2564,10 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) if (! TREE_CONSTANT (gnu_pos)) { - normalize_offset (&gnu_pos, &gnu_bitpos, - DECL_OFFSET_ALIGN (gnu_old_field)); + normalize_offset (&gnu_pos, &gnu_bitpos, offset_align); DECL_FIELD_OFFSET (gnu_field) = gnu_pos; DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos; - SET_DECL_OFFSET_ALIGN - (gnu_field, DECL_OFFSET_ALIGN (gnu_old_field)); + SET_DECL_OFFSET_ALIGN (gnu_field, offset_align); DECL_SIZE (gnu_field) = gnu_size; DECL_SIZE_UNIT (gnu_field) = convert (sizetype, @@ -2763,6 +2764,14 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) && ! Is_Constrained (gnat_desig_full)) gnat_desig_full = Etype (gnat_desig_full); + /* If the designated type is a subtype of an incomplete record type, + use the parent type to avoid order of elaboration issues. This + can lose some code efficiency, but there is no alternative. */ + if (Present (gnat_desig_full) + && Ekind (gnat_desig_full) == E_Record_Subtype + && Ekind (Etype (gnat_desig_full)) == E_Record_Type) + gnat_desig_full = Etype (gnat_desig_full); + /* If we are pointing to an incomplete type whose completion is an unconstrained array, make a fat pointer type instead of a pointer to VOID. The two types in our fields will be pointers to VOID and @@ -3416,7 +3425,19 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) if (Present (Interface_Name (gnat_entity)) || ! (Is_Imported (gnat_entity) || Is_Exported (gnat_entity))) - gnu_ext_name = create_concat_name (gnat_entity, 0); + { + gnu_ext_name = create_concat_name (gnat_entity, 0); + + /* If there wasn't a specified Interface_Name, use this for the + main name of the entity. This will cause GCC to allow + qualification of a nested subprogram with a unique ID. We + need this in case there is an overloaded subprogram somewhere + up the scope chain. + + ??? This may be a kludge. */ + if (No (Interface_Name (gnat_entity))) + gnu_entity_id = gnu_ext_name; + } set_lineno (gnat_entity, 0); @@ -3579,7 +3600,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) if ((gnu_decl == 0 || this_made_decl) && IN (kind, Type_Kind)) { if (Is_Tagged_Type (gnat_entity)) - TYPE_ALIGN_OK_P (gnu_type) = 1; + TYPE_ALIGN_OK (gnu_type) = 1; if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity)) TYPE_BY_REFERENCE_P (gnu_type) = 1; @@ -3655,24 +3676,6 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) TYPE_SIZE (gnu_type), get_identifier ("SIZE"), definition, 0); - else if (TREE_CODE (gnu_type) == RECORD_TYPE) - { - TYPE_ADA_SIZE (gnu_type) - = elaborate_expression_1 (gnat_entity, gnat_entity, - TYPE_ADA_SIZE (gnu_type), - get_identifier ("RM_SIZE"), - definition, 0); - TYPE_SIZE (gnu_type) - = elaborate_expression_1 (gnat_entity, gnat_entity, - TYPE_SIZE (gnu_type), - get_identifier ("SIZE"), - definition, 0); - TYPE_SIZE_UNIT (gnu_type) - = elaborate_expression_1 (gnat_entity, gnat_entity, - TYPE_SIZE_UNIT (gnu_type), - get_identifier ("SIZE_UNIT"), - definition, 0); - } else { TYPE_SIZE (gnu_type) @@ -3680,11 +3683,28 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) TYPE_SIZE (gnu_type), get_identifier ("SIZE"), definition, 0); + + /* ??? For now, store the size as a multiple of the alignment + in bytes so that we can see the alignment from the tree. */ TYPE_SIZE_UNIT (gnu_type) - = elaborate_expression_1 (gnat_entity, gnat_entity, - TYPE_SIZE_UNIT (gnu_type), - get_identifier ("SIZE_UNIT"), - definition, 0); + = build_binary_op + (MULT_EXPR, sizetype, + elaborate_expression_1 + (gnat_entity, gnat_entity, + build_binary_op (EXACT_DIV_EXPR, sizetype, + TYPE_SIZE_UNIT (gnu_type), + size_int (TYPE_ALIGN (gnu_type) + / BITS_PER_UNIT)), + get_identifier ("SIZE_A_UNIT"), + definition, 0), + size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); + + if (TREE_CODE (gnu_type) == RECORD_TYPE) + TYPE_ADA_SIZE (gnu_type) + = elaborate_expression_1 (gnat_entity, gnat_entity, + TYPE_ADA_SIZE (gnu_type), + get_identifier ("RM_SIZE"), + definition, 0); } } @@ -3699,13 +3719,25 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) { tree gnu_field = get_gnu_tree (gnat_temp); + /* ??? Unfortunately, GCC needs to be able to prove the + alignment of this offset and if it's a variable, it can't. + In GCC 3.2, we'll use DECL_OFFSET_ALIGN in some way, but + right now, we have to put in an explicit multiply and + divide by that value. */ if (TREE_CODE (DECL_FIELD_OFFSET (gnu_field)) != INTEGER_CST && ! contains_placeholder_p (DECL_FIELD_OFFSET (gnu_field))) DECL_FIELD_OFFSET (gnu_field) - = elaborate_expression_1 (gnat_temp, gnat_temp, - DECL_FIELD_OFFSET (gnu_field), - get_identifier ("OFFSET"), - definition, 0); + = build_binary_op + (MULT_EXPR, sizetype, + elaborate_expression_1 + (gnat_temp, gnat_temp, + build_binary_op (EXACT_DIV_EXPR, sizetype, + DECL_FIELD_OFFSET (gnu_field), + size_int (DECL_OFFSET_ALIGN (gnu_field) + / BITS_PER_UNIT)), + get_identifier ("OFFSET"), + definition, 0), + size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT)); } gnu_type = build_qualified_type (gnu_type, @@ -4267,16 +4299,12 @@ elaborate_expression_1 (gnat_expr, gnat_entity, gnu_expr, gnu_name, definition, int need_debug; { tree gnu_decl = 0; - tree gnu_inner_expr = gnu_expr; - int expr_variable; - int expr_global = Is_Public (gnat_entity) || global_bindings_p (); - /* Strip any conversions to see if the expression is a readonly variable. ??? This really should remain readonly, but we have to think about the typing of the tree here. */ - while (TREE_CODE (gnu_inner_expr) == NOP_EXPR - && TREE_CODE (gnu_inner_expr) == CONVERT_EXPR) - gnu_inner_expr = TREE_OPERAND (gnu_inner_expr, 0); + tree gnu_inner_expr = remove_conversions (gnu_expr, 1); + int expr_global = Is_Public (gnat_entity) || global_bindings_p (); + int expr_variable; /* In most cases, we won't see a naked FIELD_DECL here because a discriminant reference will have been replaced with a COMPONENT_REF @@ -4326,6 +4354,8 @@ elaborate_expression_1 (gnat_expr, gnat_entity, gnu_expr, gnu_name, definition, can do the right thing in the local case. */ if (expr_global && expr_variable) return gnu_decl; + else if (! expr_variable) + return gnu_expr; else return maybe_variable (gnu_expr, gnat_expr); } @@ -4757,15 +4787,26 @@ gnat_to_gnu_field (gnat_field, gnu_record_type, packed, definition) gnu_size = validate_size (Esize (gnat_field), gnu_field_type, gnat_field, FIELD_DECL, 0, 1); - /* If we are packing this record and the field type is also a record + /* If the field's type is a left-justified modular type, make the field + the type of the inner object unless it is aliases. We don't need + the the wrapper here and it can prevent packing. */ + if (! Is_Aliased (gnat_field) && TREE_CODE (gnu_field_type) == RECORD_TYPE + && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type)) + gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type)); + + /* If we are packing this record or we have a specified size that's + smaller than that of the field type and the field type is also a record that's BLKmode and with a small constant size, see if we can get a better form of the type that allows more packing. If we can, show a size was specified for it if there wasn't one so we know to make this a bitfield and avoid making things wider. */ - if (packed && TREE_CODE (gnu_field_type) == RECORD_TYPE + if (TREE_CODE (gnu_field_type) == RECORD_TYPE && TYPE_MODE (gnu_field_type) == BLKmode && host_integerp (TYPE_SIZE (gnu_field_type), 1) - && compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0) + && compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0 + && (packed + || (gnu_size != 0 && tree_int_cst_lt (gnu_size, + TYPE_SIZE (gnu_field_type))))) { gnu_field_type = make_packable_type (gnu_field_type); @@ -4839,7 +4880,7 @@ gnat_to_gnu_field (gnat_field, gnu_record_type, packed, definition) if (Is_Aliased (gnat_field)) post_error_ne_num ("position of aliased field& must be multiple of ^ bits", - Component_Clause (gnat_field), gnat_field, + First_Bit (Component_Clause (gnat_field)), gnat_field, TYPE_ALIGN (gnu_field_type)); else if (Is_Volatile (gnat_field)) @@ -4897,13 +4938,17 @@ gnat_to_gnu_field (gnat_field, gnu_record_type, packed, definition) } /* We need to make the size the maximum for the type if it is - self-referential and an unconstrained type. */ + self-referential and an unconstrained type. In that case, we can't + pack the field since we can't make a copy to align it. */ if (TREE_CODE (gnu_field_type) == RECORD_TYPE && gnu_size == 0 && ! TREE_CONSTANT (TYPE_SIZE (gnu_field_type)) && contains_placeholder_p (TYPE_SIZE (gnu_field_type)) && ! Is_Constrained (Underlying_Type (Etype (gnat_field)))) - gnu_size = max_size (TYPE_SIZE (gnu_field_type), 1); + { + gnu_size = max_size (TYPE_SIZE (gnu_field_type), 1); + packed = 0; + } /* If no size is specified (or if there was an error), don't specify a position. */ @@ -5383,7 +5428,8 @@ annotate_rep (gnat_entity, gnu_type) (we can get the sizes easily at any time) by a recursive call and then update all the sizes into the tree. */ gnu_list = compute_field_positions (gnu_type, NULL_TREE, - size_zero_node, bitsize_zero_node); + size_zero_node, bitsize_zero_node, + BIGGEST_ALIGNMENT); for (gnat_field = First_Entity (gnat_entity); Present (gnat_field); gnat_field = Next_Entity (gnat_field)) @@ -5398,25 +5444,29 @@ annotate_rep (gnat_entity, gnu_type) (gnat_field, annotate_value (bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)), - TREE_VALUE (TREE_VALUE (gnu_entry))))); + TREE_VALUE (TREE_VALUE + (TREE_VALUE (gnu_entry)))))); Set_Esize (gnat_field, annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry)))); } } -/* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is - the FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the - byte position and TREE_VALUE being the bit position. GNU_POS is to - be added to the position, GNU_BITPOS to the bit position, and GNU_LIST - is the entries so far. */ +/* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the + FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte + position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be + placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is + to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is + the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries + so far. */ static tree -compute_field_positions (gnu_type, gnu_list, gnu_pos, gnu_bitpos) +compute_field_positions (gnu_type, gnu_list, gnu_pos, gnu_bitpos, offset_align) tree gnu_type; tree gnu_list; tree gnu_pos; tree gnu_bitpos; + unsigned int offset_align; { tree gnu_field; tree gnu_result = gnu_list; @@ -5426,18 +5476,24 @@ compute_field_positions (gnu_type, gnu_list, gnu_pos, gnu_bitpos) { tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos, DECL_FIELD_BIT_OFFSET (gnu_field)); - tree gnu_our_pos = size_binop (PLUS_EXPR, gnu_pos, - DECL_FIELD_OFFSET (gnu_field)); + tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos, + DECL_FIELD_OFFSET (gnu_field)); + unsigned int our_offset_align + = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field)); gnu_result = tree_cons (gnu_field, - tree_cons (gnu_our_pos, gnu_our_bitpos, NULL_TREE), + tree_cons (gnu_our_offset, + tree_cons (size_int (our_offset_align), + gnu_our_bitpos, NULL_TREE), + NULL_TREE), gnu_result); if (DECL_INTERNAL_P (gnu_field)) gnu_result - = compute_field_positions (TREE_TYPE (gnu_field), - gnu_result, gnu_our_pos, gnu_our_bitpos); + = compute_field_positions (TREE_TYPE (gnu_field), gnu_result, + gnu_our_offset, gnu_our_bitpos, + our_offset_align); } return gnu_result; @@ -5743,6 +5799,12 @@ validate_alignment (alignment, gnat_entity, align) if (Present (Alignment_Clause (gnat_entity))) gnat_error_node = Expression (Alignment_Clause (gnat_entity)); + /* Don't worry about checking alignment if alignment was not specified + by the source program and we already posted an error for this entity. */ + + if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity)) + return align; + /* Within GCC, an alignment is an integer, so we must make sure a value is specified that fits in that range. Also, alignments of more than MAX_OFILE_ALIGNMENT can't be supported. */ diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index eaa362ef339..c84e10e71ce 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision$ +-- $Revision: 1.642 $ -- -- --- Copyright (C) 1992-2001 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- -- @@ -40,7 +40,6 @@ with Atree; use Atree; with Namet; use Namet; with Nlists; use Nlists; with Sinfo; use Sinfo; -with Snames; use Snames; with Stand; use Stand; with Output; use Output; @@ -181,8 +180,9 @@ package body Einfo is -- Accept_Address Elist21 -- Default_Expr_Function Node21 -- Discriminant_Constraint Elist21 - -- Small_Value Ureal21 -- Interface_Name Node21 + -- Original_Array_Type Node21 + -- Small_Value Ureal21 -- Associated_Storage_Pool Node22 -- Component_Size Uint22 @@ -395,8 +395,8 @@ package body Einfo is -- Size_Depends_On_Discriminant Flag177 -- Is_Null_Init_Proc Flag178 -- Has_Pragma_Pure_Function Flag179 + -- Has_Pragma_Unreferenced Flag180 - -- (unused) Flag180 -- (unused) Flag181 -- (unused) Flag182 -- (unused) Flag183 @@ -413,7 +413,7 @@ package body Einfo is function Access_Disp_Table (Id : E) return E is begin pragma Assert (Is_Tagged_Type (Id)); - return Node16 (Base_Type (Underlying_Type (Base_Type (Id)))); + return Node16 (Implementation_Base_Type (Id)); end Access_Disp_Table; function Actual_Subtype (Id : E) return E is @@ -463,7 +463,7 @@ package body Einfo is function Associated_Storage_Pool (Id : E) return E is begin pragma Assert (Is_Access_Type (Id)); - return Node22 (Id); + return Node22 (Root_Type (Id)); end Associated_Storage_Pool; function Barrier_Function (Id : E) return N is @@ -1090,6 +1090,11 @@ package body Einfo is return Flag179 (Id); end Has_Pragma_Pure_Function; + function Has_Pragma_Unreferenced (Id : E) return B is + begin + return Flag180 (Id); + end Has_Pragma_Unreferenced; + function Has_Primitive_Operations (Id : E) return B is begin pragma Assert (Is_Type (Id)); @@ -1109,7 +1114,7 @@ package body Einfo is function Has_Record_Rep_Clause (Id : E) return B is begin pragma Assert (Is_Record_Type (Id)); - return Flag65 (Id); + return Flag65 (Implementation_Base_Type (Id)); end Has_Record_Rep_Clause; function Has_Recursive_Call (Id : E) return B is @@ -1131,7 +1136,7 @@ package body Einfo is function Has_Specified_Layout (Id : E) return B is begin pragma Assert (Is_Type (Id)); - return Flag100 (Id); + return Flag100 (Implementation_Base_Type (Id)); end Has_Specified_Layout; function Has_Storage_Size_Clause (Id : E) return B is @@ -1721,6 +1726,12 @@ package body Einfo is return Node17 (Id); end Object_Ref; + function Original_Array_Type (Id : E) return E is + begin + pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id)); + return Node21 (Id); + end Original_Array_Type; + function Original_Record_Component (Id : E) return E is begin return Node22 (Id); @@ -2241,8 +2252,8 @@ package body Einfo is procedure Set_Access_Disp_Table (Id : E; V : E) is begin - pragma Assert (Is_Tagged_Type (Id)); - Set_Node16 (Base_Type (Id), V); + pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id)); + Set_Node16 (Id, V); end Set_Access_Disp_Table; procedure Set_Associated_Final_Chain (Id : E; V : E) is @@ -2263,7 +2274,7 @@ package body Einfo is procedure Set_Associated_Storage_Pool (Id : E; V : E) is begin - pragma Assert (Is_Access_Type (Id)); + pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id)); Set_Node22 (Id, V); end Set_Associated_Storage_Pool; @@ -2349,12 +2360,13 @@ package body Einfo is procedure Set_Component_Size (Id : E; V : U) is begin - pragma Assert (Is_Array_Type (Id)); - Set_Uint22 (Base_Type (Id), V); + pragma Assert (Is_Array_Type (Id) and then Id = Base_Type (Id)); + Set_Uint22 (Id, V); end Set_Component_Size; procedure Set_Component_Type (Id : E; V : E) is begin + pragma Assert (Is_Array_Type (Id) and then Id = Base_Type (Id)); Set_Node20 (Id, V); end Set_Component_Type; @@ -2669,8 +2681,8 @@ package body Einfo is procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is begin - pragma Assert (Is_Type (Id)); - Set_Flag158 (Base_Type (Id), V); + pragma Assert (Is_Type (Id) and then Id = Base_Type (Id)); + Set_Flag158 (Id, V); end Set_Finalize_Storage_Only; procedure Set_First_Entity (Id : E; V : E) is @@ -2790,14 +2802,14 @@ package body Einfo is procedure Set_Has_Complex_Representation (Id : E; V : B := True) is begin - pragma Assert (Is_Record_Type (Id)); - Set_Flag140 (Implementation_Base_Type (Id), V); + pragma Assert (Ekind (Id) = E_Record_Type); + Set_Flag140 (Id, V); end Set_Has_Complex_Representation; procedure Set_Has_Component_Size_Clause (Id : E; V : B := True) is begin - pragma Assert (Is_Array_Type (Id)); - Set_Flag68 (Implementation_Base_Type (Id), V); + pragma Assert (Ekind (Id) = E_Array_Type); + Set_Flag68 (Id, V); end Set_Has_Component_Size_Clause; procedure Set_Has_Controlled_Component (Id : E; V : B := True) is @@ -2924,7 +2936,8 @@ package body Einfo is procedure Set_Has_Pragma_Pack (Id : E; V : B := True) is begin pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id)); - Set_Flag121 (Implementation_Base_Type (Id), V); + pragma Assert (Id = Base_Type (Id)); + Set_Flag121 (Id, V); end Set_Has_Pragma_Pack; procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True) is @@ -2933,10 +2946,15 @@ package body Einfo is Set_Flag179 (Id, V); end Set_Has_Pragma_Pure_Function; + procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True) is + begin + Set_Flag180 (Id, V); + end Set_Has_Pragma_Unreferenced; + procedure Set_Has_Primitive_Operations (Id : E; V : B := True) is begin - pragma Assert (Is_Type (Id)); - Set_Flag120 (Base_Type (Id), V); + pragma Assert (Id = Base_Type (Id)); + Set_Flag120 (Id, V); end Set_Has_Primitive_Operations; procedure Set_Has_Private_Declaration (Id : E; V : B := True) is @@ -2951,7 +2969,7 @@ package body Einfo is procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True) is begin - pragma Assert (Is_Record_Type (Id)); + pragma Assert (Id = Base_Type (Id)); Set_Flag65 (Id, V); end Set_Has_Record_Rep_Clause; @@ -2973,7 +2991,7 @@ package body Einfo is procedure Set_Has_Specified_Layout (Id : E; V : B := True) is begin - pragma Assert (Is_Type (Id)); + pragma Assert (Id = Base_Type (Id)); Set_Flag100 (Id, V); end Set_Has_Specified_Layout; @@ -3087,7 +3105,10 @@ package body Einfo is procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True) is begin - Set_Flag122 (Implementation_Base_Type (Id), V); + pragma Assert ((not V) + or else (Is_Array_Type (Id) and then Id = Base_Type (Id))); + + Set_Flag122 (Id, V); end Set_Is_Bit_Packed_Array; procedure Set_Is_Called (Id : E; V : B := True) is @@ -3536,7 +3557,7 @@ package body Einfo is procedure Set_No_Pool_Assigned (Id : E; V : B := True) is begin - pragma Assert (Is_Access_Type (Id) and then Root_Type (Id) = Id); + pragma Assert (Is_Access_Type (Id) and then Base_Type (Id) = Id); Set_Flag131 (Id, V); end Set_No_Pool_Assigned; @@ -3593,6 +3614,12 @@ package body Einfo is Set_Node17 (Id, V); end Set_Object_Ref; + procedure Set_Original_Array_Type (Id : E; V : E) is + begin + pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id)); + Set_Node21 (Id, V); + end Set_Original_Array_Type; + procedure Set_Original_Record_Component (Id : E; V : E) is begin Set_Node22 (Id, V); @@ -3861,6 +3888,7 @@ package body Einfo is procedure Set_Suppress_Init_Proc (Id : E; V : B := True) is begin + pragma Assert (Id = Base_Type (Id)); Set_Flag105 (Id, V); end Set_Suppress_Init_Proc; @@ -4055,7 +4083,8 @@ package body Einfo is function Known_Alignment (E : Entity_Id) return B is begin - return Uint14 (E) /= Uint_0; + return Uint14 (E) /= Uint_0 + and then Uint14 (E) /= No_Uint; end Known_Alignment; function Known_Component_Bit_Offset (E : Entity_Id) return B is @@ -4065,12 +4094,14 @@ package body Einfo is function Known_Component_Size (E : Entity_Id) return B is begin - return Uint22 (Base_Type (E)) /= Uint_0; + return Uint22 (Base_Type (E)) /= Uint_0 + and then Uint22 (Base_Type (E)) /= No_Uint; end Known_Component_Size; function Known_Esize (E : Entity_Id) return B is begin - return Uint12 (E) /= Uint_0; + return Uint12 (E) /= Uint_0 + and then Uint12 (E) /= No_Uint; end Known_Esize; function Known_Normalized_First_Bit (E : Entity_Id) return B is @@ -4090,8 +4121,9 @@ package body Einfo is function Known_RM_Size (E : Entity_Id) return B is begin - return Uint13 (E) /= Uint_0 - or else Is_Discrete_Type (E); + return Uint13 (E) /= No_Uint + and then (Uint13 (E) /= Uint_0 + or else Is_Discrete_Type (E)); end Known_RM_Size; function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is @@ -4110,6 +4142,12 @@ package body Einfo is return Uint12 (E) > Uint_0; end Known_Static_Esize; + function Known_Static_Normalized_First_Bit (E : Entity_Id) return B is + begin + return Uint8 (E) /= No_Uint + and then Uint8 (E) >= Uint_0; + end Known_Static_Normalized_First_Bit; + function Known_Static_Normalized_Position (E : Entity_Id) return B is begin return Uint9 (E) /= No_Uint @@ -4130,7 +4168,8 @@ package body Einfo is function Unknown_Alignment (E : Entity_Id) return B is begin - return Uint14 (E) = Uint_0; + return Uint14 (E) = Uint_0 + or else Uint14 (E) = No_Uint; end Unknown_Alignment; function Unknown_Component_Bit_Offset (E : Entity_Id) return B is @@ -4140,12 +4179,16 @@ package body Einfo is function Unknown_Component_Size (E : Entity_Id) return B is begin - return Uint22 (Base_Type (E)) = Uint_0; + return Uint22 (Base_Type (E)) = Uint_0 + or else + Uint22 (Base_Type (E)) = No_Uint; end Unknown_Component_Size; function Unknown_Esize (E : Entity_Id) return B is begin - return Uint12 (E) = Uint_0; + return Uint12 (E) = No_Uint + or else + Uint12 (E) = Uint_0; end Unknown_Esize; function Unknown_Normalized_First_Bit (E : Entity_Id) return B is @@ -4165,8 +4208,9 @@ package body Einfo is function Unknown_RM_Size (E : Entity_Id) return B is begin - return Uint13 (E) = Uint_0 - and then not Is_Discrete_Type (E); + return (Uint13 (E) = Uint_0 + and then not Is_Discrete_Type (E)) + or else Uint13 (E) = No_Uint; end Unknown_RM_Size; -------------------- @@ -4686,6 +4730,76 @@ package body Einfo is end if; end First_Subtype; + ------------------------------------- + -- Get_Attribute_Definition_Clause -- + ------------------------------------- + + function Get_Attribute_Definition_Clause + (E : Entity_Id; + Id : Attribute_Id) + return Node_Id + is + N : Node_Id; + + begin + N := First_Rep_Item (E); + while Present (N) loop + if Nkind (N) = N_Attribute_Definition_Clause + and then Get_Attribute_Id (Chars (N)) = Id + then + return N; + else + Next_Rep_Item (N); + end if; + end loop; + + return Empty; + end Get_Attribute_Definition_Clause; + + -------------------- + -- Get_Rep_Pragma -- + -------------------- + + function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id is + N : Node_Id; + Typ : Entity_Id; + + begin + N := First_Rep_Item (E); + + while Present (N) loop + if Nkind (N) = N_Pragma and then Chars (N) = Nam then + + if Nam = Name_Stream_Convert then + + -- For tagged types this pragma is not inherited, so we + -- must verify that it is defined for the given type and + -- not an ancestor. + + Typ := Entity (Expression + (First (Pragma_Argument_Associations (N)))); + + if not Is_Tagged_Type (E) + or else E = Typ + or else (Is_Private_Type (Typ) + and then E = Full_View (Typ)) + then + return N; + else + Next_Rep_Item (N); + end if; + + else + return N; + end if; + else + Next_Rep_Item (N); + end if; + end loop; + + return Empty; + end Get_Rep_Pragma; + ------------------------ -- Has_Attach_Handler -- ------------------------ @@ -4808,7 +4922,7 @@ package body Einfo is -- happen in error situations and should avoid some error bombs. if Present (Imptyp) then - return Imptyp; + return Base_Type (Imptyp); else return Bastyp; end if; @@ -5845,6 +5959,7 @@ package body Einfo is W ("Has_Pragma_Inline", Flag157 (Id)); W ("Has_Pragma_Pack", Flag121 (Id)); W ("Has_Pragma_Pure_Function", Flag179 (Id)); + W ("Has_Pragma_Unreferenced", Flag180 (Id)); W ("Has_Primitive_Operations", Flag120 (Id)); W ("Has_Private_Declaration", Flag155 (Id)); W ("Has_Qualified_Name", Flag161 (Id)); @@ -6099,6 +6214,8 @@ package body Einfo is ----------------------- procedure Write_Field6_Name (Id : Entity_Id) is + pragma Warnings (Off, Id); + begin Write_Str ("First_Rep_Item"); end Write_Field6_Name; @@ -6108,6 +6225,8 @@ package body Einfo is ----------------------- procedure Write_Field7_Name (Id : Entity_Id) is + pragma Warnings (Off, Id); + begin Write_Str ("Freeze_Node"); end Write_Field7_Name; @@ -6124,7 +6243,8 @@ package body Einfo is Write_Str ("Normalized_First_Bit"); when Formal_Kind | - E_Function => + E_Function | + E_Subprogram_Body => Write_Str ("Mechanism"); when Type_Kind => @@ -6686,6 +6806,10 @@ package body Einfo is when E_In_Parameter => Write_Str ("Default_Expr_Function"); + when Array_Kind | + Modular_Integer_Kind => + Write_Str ("Original_Array_Type"); + when others => Write_Str ("Field21??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 804900b2ca2..f9dda49eb66 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.6 $ +-- $Revision: 1.654 $ -- -- --- Copyright (C) 1992-2001 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- -- @@ -33,6 +33,7 @@ -- -- ------------------------------------------------------------------------------ +with Snames; use Snames; with Types; use Types; with Uintp; use Uintp; with Urealp; use Urealp; @@ -270,17 +271,18 @@ package Einfo is -- are so noted by the notation [base type only]. These are cases where the -- attribute of any subtype is the same as the attribute of the base type. -- The attribute can be referenced on a subtype (and automatically retrieves --- the value from the base type), and if an attempt is made to set them on --- other than a subtype, they will instead be set on the corresponding base --- type. +-- the value from the base type). However, it is an error to try to set the +-- attribute on other than the base type, and if assertions are enabled, +-- an attempt to set the attribute on a subtype will raise an assert error. -- Other attributes are noted as applying the implementation base type only. -- These are representation attributes which must always apply to a full -- non-private type, and where the attributes are always on the full type. -- The attribute can be referenced on a subtype (and automatically retries --- the value from the implementation base type), and if an attempt is made --- to set them on other than a subtype, they will instead be set on the --- corresponding implementation base type. +-- the value from the implementation base type). However, it is an error +-- to try to set the attribute on other than the implementation base type, +-- and if assertions are enabled, an attempt to set the attribute on a +-- subtype will raise an assert error. -- Accept_Address (Elist21) -- Present in entries. If an accept has a statement sequence, then an @@ -309,7 +311,7 @@ package Einfo is -- rather irregular, and the semantic checks that depend on the nominal -- subtype being unconstrained use flag Is_Constr_Subt_For_U_Nominal(qv). --- Access_Disp_Table (Node16) [base type only] +-- Access_Disp_Table (Node16) [implementation base type only] -- Present in record type entities. For a tagged type, points to the -- dispatch table associated with the tagged type. For a non-tagged -- record, contains Empty. @@ -367,10 +369,12 @@ package Einfo is -- the node whose elaboration generated the Itype. This is used for -- copying trees, to determine whether or not to copy an Itype. --- Associated_Storage_Pool (Node22) +-- Associated_Storage_Pool (Node22) [root type only] -- Present in simple and general access type entities. References the -- storage pool to be used for the corresponding collection. A value of --- Empty means that the default pool is to be used. +-- Empty means that the default pool is to be used. This is present +-- only in the root type, since derived types must have the same pool +-- as the parent type. -- Associated_Final_Chain (Node23) -- Present in simple and general access type entities. References the @@ -400,7 +404,7 @@ package Einfo is -- for finalization purposes, The block entity has an implicit label -- declaration in the enclosing declarative part, and has otherwise -- no direct connection in the tree with the block statement. The --- link is to the identifier (which is an occurrence of the entity) +-- link is to the identifier (which is an occurence of the entity) -- and not to the block_statement itself, because the statement may -- be rewritten, e.g. in the process of removing dead code. @@ -511,9 +515,7 @@ package Einfo is -- for details of these values. -- Component_Type (Node20) [implementation base type only] --- Present in array types and subtypes, and also in the special --- enumeration table type created for enumeration type. References --- the entity for the component type. +-- Present in array types and string types. References component type. -- Constant_Value (synthesized) -- Applies to constants, named integers, and named reals. Obtains @@ -1360,9 +1362,15 @@ package Einfo is -- Pure_Function was given for the entity. In some cases, we need to -- know that Is_Pure was explicitly set using this pragma. +-- Has_Pragma_Unreferenced (Flag180) +-- Present in all entities. Set if a valid pragma Unreferenced applies +-- to the pragma, indicating that no warning should be given if the +-- entity has no references, but a warning should be given if it is +-- in fact referenced. + -- Has_Primitive_Operations (Flag120) [base type only] -- Present in all type entities. Set if at least one primitive operation --- is defined on the type. This flag is not yet properly set ??? +-- is defined for the type. -- Has_Private_Ancestor (synthesized) -- Applies to all type and subtype entities. Returns True if at least @@ -1386,7 +1394,7 @@ package Einfo is -- the flag Has_Fully_Qualified_Name, which is set if the name does -- indeed include the fully qualified name. --- Has_Record_Rep_Clause (Flag65) +-- Has_Record_Rep_Clause (Flag65) [implementation base type only] -- Present in record types. Set if a record representation clause has -- been given for this record type. Used to prevent more than one such -- clause for a given record type. Note that this is initially cleared @@ -1412,7 +1420,7 @@ package Einfo is -- initially cleared for a derived type, even though the Small for such -- a type is inherited from a Small clause given for the parent type. --- Has_Specified_Layout (Flag100) +-- Has_Specified_Layout (Flag100) [implementation base type only] -- Present in all type entities. Set for a record type or subtype if -- the record layout has been specified by a record representation -- clause. Note that this differs from the flag Has_Record_Rep_Clause @@ -1575,7 +1583,7 @@ package Einfo is -- Present in all type entities and in procedure entities. Set -- if a pragma Asynchronous applies to the entity. --- Is_Bit_Packed_Array (Flag122) +-- Is_Bit_Packed_Array (Flag122) [implementation base type only] -- Present in all entities. This flag is set for a packed array -- type that is bit packed (i.e. the component size is known by the -- front end and is in the range 1-7, 9-15, or 17-31). Is_Packed is @@ -1718,7 +1726,8 @@ package Einfo is -- Is_Eliminated (Flag124) -- Present in type entities, subprogram entities, and object entities. -- Indicates that the corresponding entity has been eliminated by use --- of pragma Eliminate. +-- of pragma Eliminate. Also used to mark subprogram entities whose +-- declaration and body are within unreachable code that is removed. -- Is_Enumeration_Type (synthesized) -- Present in all entities, true for enumeration types and subtypes @@ -2012,7 +2021,9 @@ package Einfo is -- if the type appears in the Packed_Array_Type field of some other type -- entity. It is used by Gigi to activate the special processing for such -- types (unchecked conversions that would not otherwise be allowed are --- allowed for such types). +-- allowed for such types). If the Is_Packed_Array_Type flag is set in +-- an entity, then the Original_Array_Type field of this entity points +-- to the original array type for which this is the packed array type. -- Is_Potentially_Use_Visible (Flag9) -- Present in all entities. Set if entity is potentially use visible, @@ -2251,7 +2262,9 @@ package Einfo is -- Mechanism (Uint8) (returned as Mechanism_Type) -- Present in functions and non-generic formal parameters. Indicates -- the mechanism to be used for the function return or for the formal --- parameter. See separate section on passing mechanisms. +-- parameter. See separate section on passing mechanisms. This field +-- is also set (to the default value of zero) in a subprogram body +-- entity but not used in this context. -- Modulus (Uint17) [base type only] -- Present in modular types. Contains the modulus. For the binary @@ -2382,7 +2395,8 @@ package Einfo is -- Present in access types. Set if a storage size clause applies to -- the variable with a compile time known value of zero. This flag is -- used to generate warnings if any attempt is made to allocate an --- instance of such an access type. +-- instance of such an access type. This is set only in the root +-- type, since derived types must have the same pool. -- No_Return (Flag113) -- Present in procedure and generic procedure entries. Indicates that @@ -2426,6 +2440,13 @@ package Einfo is -- Applies to subprograms and subprogram types. Yields the number of -- formals as a value of type Pos. +-- Original_Array_Type (Node21) +-- Present in modular types and array types and subtypes. Set only +-- if the Is_Packed_Array_Type flag is set, indicating that the type +-- is the implementation type for a packed array, and in this case it +-- points to the original array type for which this is the packed +-- array implementation type. + -- Object_Ref (Node17) -- Present in protected bodies. This is an implicit prival for the -- Protection object associated with a protected object. See Prival @@ -2466,7 +2487,7 @@ package Einfo is -- Parameter_Mode (synthesized) -- Applies to formal parameter entities. This is a synonym for Ekind, -- used when obtaining the formal kind of a formal parameter (the result --- is one of E_[In/Out/In_Out]_Parameter) +-- is one of E_[In/Out/In_Out]_Paramter) -- Parent_Subtype (Node19) -- Present in E_Record_Type. Points to the subtype to use for a @@ -2616,7 +2637,7 @@ package Einfo is -- returns the result by reference, either because its return typ is a -- by-reference-type or because it uses explicitly the secondary stack. --- Reverse_Bit_Order (Flag164) +-- Reverse_Bit_Order (Flag164) [base type only] -- Present in all record type entities. Set if a valid pragma an -- attribute represention clause for Bit_Order has reversed the order -- of bits from the default value. When this flag is set, a component @@ -3668,10 +3689,11 @@ package Einfo is -- Has_Homonym (Flag56) -- Has_Pragma_Elaborate_Body (Flag150) -- Has_Pragma_Inline (Flag157) + -- Has_Pragma_Unreferenced (Flag180) -- Has_Private_Declaration (Flag155) -- Has_Qualified_Name (Flag161) -- Has_Unknown_Discriminants (Flag72) - -- Is_Bit_Packed_Array (Flag122) + -- Is_Bit_Packed_Array (Flag122) (base type only) -- Is_Child_Unit (Flag73) -- Is_Compilation_Unit (Flag149) -- Is_Completely_Hidden (Flag103) @@ -3745,12 +3767,12 @@ package Einfo is -- Discard_Names (Flag88) -- Finalize_Storage_Only (Flag158) (base type only) -- From_With_Type (Flag159) - -- Has_Aliased_Components (Flag135) + -- Has_Aliased_Components (Flag135) (base type only) -- Has_Alignment_Clause (Flag46) -- Has_Atomic_Components (Flag86) (base type only) -- Has_Complex_Representation (Flag140) (base type only) -- Has_Discriminants (Flag5) - -- Has_Non_Standard_Rep (Flag75) + -- Has_Non_Standard_Rep (Flag75) (base type only) -- Has_Object_Size_Clause (Flag172) -- Has_Primitive_Operations (Flag120) (base type only) -- Has_Size_Clause (Flag29) @@ -3778,7 +3800,7 @@ package Einfo is -- Is_Volatile (Flag16) -- Size_Depends_On_Discriminant (Flag177) -- Size_Known_At_Compile_Time (Flag92) - -- Strict_Alignment (Flag145) + -- Strict_Alignment (Flag145) (base type only) -- Suppress_Init_Proc (Flag105) (base type only) -- Alignment_Clause (synth) @@ -3811,15 +3833,15 @@ package Einfo is -- E_Access_Type -- E_Access_Subtype - -- Storage_Size_Variable (Node15) (root type only) + -- Storage_Size_Variable (Node15) (base type only) -- Master_Id (Node17) -- Directly_Designated_Type (Node20) - -- Associated_Storage_Pool (Node22) + -- Associated_Storage_Pool (Node22) (base type only) -- Associated_Final_Chain (Node23) -- Has_Pragma_Controlled (Flag27) (base type only) - -- Has_Storage_Size_Clause (Flag23) (root type only) + -- Has_Storage_Size_Clause (Flag23) (base type only) -- Is_Access_Constant (Flag69) - -- No_Pool_Assigned (Flag131) (root type only) + -- No_Pool_Assigned (Flag131) (base type only) -- (plus type attributes) -- E_Access_Attribute_Type @@ -3840,6 +3862,7 @@ package Einfo is -- First_Index (Node17) -- Related_Array_Object (Node19) -- Component_Type (Node20) (base type only) + -- Original_Array_Type (Node21) -- Component_Size (Uint22) (base type only) -- Packed_Array_Type (Node23) -- Component_Alignment (special) (base type only) @@ -4089,7 +4112,7 @@ package Einfo is -- Storage_Size_Variable (Node15) (base type only) -- Master_Id (Node17) -- Directly_Designated_Type (Node20) - -- Associated_Storage_Pool (Node22) + -- Associated_Storage_Pool (Node22) (base type only) -- Associated_Final_Chain (Node23) -- (plus type attributes) @@ -4163,6 +4186,7 @@ package Einfo is -- E_Modular_Integer_Type -- E_Modular_Integer_Subtype -- Modulus (Uint17) (base type only) + -- Original_Array_Type (Node21) -- Scalar_Range (Node20) -- Non_Binary_Modulus (Flag58) (base type only) -- Has_Biased_Representation (Flag139) @@ -4352,13 +4376,13 @@ package Einfo is -- Parent_Subtype (Node19) -- Last_Entity (Node20) -- Discriminant_Constraint (Elist21) - -- Corresponding_Remote_Type (Node22) (base type only) + -- Corresponding_Remote_Type (Node22) -- Girder_Constraint (Elist23) -- Component_Alignment (special) (base type only) -- C_Pass_By_Copy (Flag125) (base type only) -- Has_Controlled_Component (Flag43) (base type only) -- Has_External_Tag_Rep_Clause (Flag110) - -- Has_Record_Rep_Clause (Flag65) + -- Has_Record_Rep_Clause (Flag65) (base type only) -- Is_Concurrent_Record_Type (Flag20) -- Is_Constrained (Flag12) -- Is_Controlled (Flag42) (base type only) @@ -4383,7 +4407,7 @@ package Einfo is -- Has_Completion (Flag26) -- Has_Completion_In_Body (Flag71) -- Has_Controlled_Component (Flag43) (base type only) - -- Has_Record_Rep_Clause (Flag65) + -- Has_Record_Rep_Clause (Flag65) (base type only) -- Has_External_Tag_Rep_Clause (Flag110) -- Is_Concurrent_Record_Type (Flag20) -- Is_Constrained (Flag12) @@ -4416,11 +4440,11 @@ package Einfo is -- String_Literal_Low_Bound (Node15) -- String_Literal_Length (Uint16) -- First_Index (Node17) (always Empty) - -- Component_Type (Node20) (base type only) -- Packed_Array_Type (Node23) -- (plus type attributes) -- E_Subprogram_Body + -- Mechanism (Uint8) -- First_Entity (Node17) -- Last_Entity (Node20) -- Scope_Depth_Value (Uint22) @@ -4845,6 +4869,7 @@ package Einfo is function Has_Pragma_Inline (Id : E) return B; function Has_Pragma_Pack (Id : E) return B; function Has_Pragma_Pure_Function (Id : E) return B; + function Has_Pragma_Unreferenced (Id : E) return B; function Has_Primitive_Operations (Id : E) return B; function Has_Qualified_Name (Id : E) return B; function Has_Record_Rep_Clause (Id : E) return B; @@ -4955,6 +4980,7 @@ package Einfo is function Normalized_Position_Max (Id : E) return U; function Not_Source_Assigned (Id : E) return B; function Object_Ref (Id : E) return E; + function Original_Array_Type (Id : E) return E; function Original_Record_Component (Id : E) return E; function Packed_Array_Type (Id : E) return E; function Parent_Subtype (Id : E) return E; @@ -5137,15 +5163,15 @@ package Einfo is -- possible, so we do not need a separate Known_Static calls in -- these cases. The not set (unknown values are as follows: - -- Alignment Uint_0 - -- Component_Size Uint_0 + -- Alignment Uint_0 or No_Uint + -- Component_Size Uint_0 or No_Uint -- Component_Bit_Offset No_Uint - -- Digits_Value Uint_0 - -- Esize Uint_0 + -- Digits_Value Uint_0 or No_Uint + -- Esize Uint_0 or No_Uint -- Normalized_First_Bit No_Uint -- Normalized_Position No_Uint -- Normalized_Position_Max No_Uint - -- RM_Size Uint_0 + -- RM_Size Uint_0 or No_Uint -- It would be cleaner to use No_Uint in all these cases, but historically -- we chose to use Uint_0 at first, and the change over will take time ??? @@ -5166,6 +5192,7 @@ package Einfo is function Known_Static_Component_Bit_Offset (E : Entity_Id) return B; function Known_Static_Component_Size (E : Entity_Id) return B; function Known_Static_Esize (E : Entity_Id) return B; + function Known_Static_Normalized_First_Bit (E : Entity_Id) return B; function Known_Static_Normalized_Position (E : Entity_Id) return B; function Known_Static_Normalized_Position_Max (E : Entity_Id) return B; function Known_Static_RM_Size (E : Entity_Id) return B; @@ -5301,6 +5328,7 @@ package Einfo is procedure Set_Has_Pragma_Inline (Id : E; V : B := True); procedure Set_Has_Pragma_Pack (Id : E; V : B := True); procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True); + procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True); procedure Set_Has_Primitive_Operations (Id : E; V : B := True); procedure Set_Has_Private_Declaration (Id : E; V : B := True); procedure Set_Has_Qualified_Name (Id : E; V : B := True); @@ -5416,6 +5444,7 @@ package Einfo is procedure Set_Normalized_Position_Max (Id : E; V : U); procedure Set_Not_Source_Assigned (Id : E; V : B := True); procedure Set_Object_Ref (Id : E; V : E); + procedure Set_Original_Array_Type (Id : E; V : E); procedure Set_Original_Record_Component (Id : E; V : E); procedure Set_Packed_Array_Type (Id : E; V : E); procedure Set_Parent_Subtype (Id : E; V : E); @@ -5590,6 +5619,20 @@ package Einfo is procedure Append_Entity (Id : Entity_Id; V : Entity_Id); -- Add an entity to the list of entities declared in the scope V + function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id; + -- Searches the Rep_Item chain for the given entity E, for an instance + -- of a representation pragma with the given name Nam. If found then + -- the value returned is the N_Pragma node, otherwise Empty is returned. + + function Get_Attribute_Definition_Clause + (E : Entity_Id; + Id : Attribute_Id) + return Node_Id; + -- Searches the Rep_Item chain for a given entity E, for an instance + -- of an attribute definition clause with the given attibute Id Id. If + -- found, the value returned is the N_Attribute_Definition_Clause node, + -- otherwise Empty is returned. + function Is_Entity_Name (N : Node_Id) return Boolean; -- Test if the node N is the name of an entity (i.e. is an identifier, -- expanded name, or an attribute reference that returns an entity). @@ -5769,6 +5812,7 @@ package Einfo is pragma Inline (Has_Pragma_Inline); pragma Inline (Has_Pragma_Pack); pragma Inline (Has_Pragma_Pure_Function); + pragma Inline (Has_Pragma_Unreferenced); pragma Inline (Has_Primitive_Operations); pragma Inline (Has_Private_Declaration); pragma Inline (Has_Qualified_Name); @@ -5920,6 +5964,7 @@ package Einfo is pragma Inline (Normalized_Position_Max); pragma Inline (Not_Source_Assigned); pragma Inline (Object_Ref); + pragma Inline (Original_Array_Type); pragma Inline (Original_Record_Component); pragma Inline (Packed_Array_Type); pragma Inline (Parameter_Mode); @@ -5988,19 +6033,6 @@ package Einfo is pragma Inline (Init_Esize); pragma Inline (Init_RM_Size); - pragma Inline (Known_Alignment); - pragma Inline (Known_Component_Bit_Offset); - pragma Inline (Known_Component_Size); - pragma Inline (Known_Esize); - - pragma Inline (Known_Static_Component_Size); - pragma Inline (Known_Static_Esize); - - pragma Inline (Unknown_Alignment); - pragma Inline (Unknown_Component_Bit_Offset); - pragma Inline (Unknown_Component_Size); - pragma Inline (Unknown_Esize); - pragma Inline (Set_Accept_Address); pragma Inline (Set_Access_Disp_Table); pragma Inline (Set_Actual_Subtype); @@ -6115,6 +6147,7 @@ package Einfo is pragma Inline (Set_Has_Pragma_Inline); pragma Inline (Set_Has_Pragma_Pack); pragma Inline (Set_Has_Pragma_Pure_Function); + pragma Inline (Set_Has_Pragma_Unreferenced); pragma Inline (Set_Has_Primitive_Operations); pragma Inline (Set_Has_Private_Declaration); pragma Inline (Set_Has_Qualified_Name); @@ -6230,6 +6263,7 @@ package Einfo is pragma Inline (Set_Normalized_Position_Max); pragma Inline (Set_Not_Source_Assigned); pragma Inline (Set_Object_Ref); + pragma Inline (Set_Original_Array_Type); pragma Inline (Set_Original_Record_Component); pragma Inline (Set_Packed_Array_Type); pragma Inline (Set_Parent_Subtype); diff --git a/gcc/ada/einfo.h b/gcc/ada/einfo.h index d7589a53eeb..6507e2f70bf 100644 --- a/gcc/ada/einfo.h +++ b/gcc/ada/einfo.h @@ -6,11 +6,11 @@ /* */ /* C Header File */ /* */ -/* Generated by xeinfo revision 1.2 using */ -/* einfo.ads revision 1.7 */ -/* einfo.adb revision 1.4 */ +/* Generated by xeinfo revision 1.3 using */ +/* einfo.ads revision 1.654 */ +/* einfo.adb revision 1.642 */ /* */ -/* Copyright (C) 1992-2001 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- */ @@ -361,6 +361,7 @@ INLINE B Has_Pragma_Inline (E Id); INLINE B Has_Pragma_Pack (E Id); INLINE B Has_Pragma_Pure_Function (E Id); + INLINE B Has_Pragma_Unreferenced (E Id); INLINE B Has_Primitive_Operations (E Id); INLINE B Has_Qualified_Name (E Id); INLINE B Has_Record_Rep_Clause (E Id); @@ -474,6 +475,7 @@ INLINE U Normalized_Position_Max (E Id); INLINE B Not_Source_Assigned (E Id); INLINE E Object_Ref (E Id); + INLINE E Original_Array_Type (E Id); INLINE E Original_Record_Component (E Id); INLINE E Packed_Array_Type (E Id); INLINE E Parent_Subtype (E Id); @@ -723,10 +725,17 @@ #define Underlying_Type einfo__underlying_type E Underlying_Type (E Id); - INLINE B Known_Alignment (Entity_Id E); - INLINE B Known_Component_Bit_Offset (Entity_Id E); - INLINE B Known_Component_Size (Entity_Id E); - INLINE B Known_Esize (Entity_Id E); + #define Known_Alignment einfo__known_alignment + B Known_Alignment (Entity_Id E); + + #define Known_Component_Bit_Offset einfo__known_component_bit_offset + B Known_Component_Bit_Offset (Entity_Id E); + + #define Known_Component_Size einfo__known_component_size + B Known_Component_Size (Entity_Id E); + + #define Known_Esize einfo__known_esize + B Known_Esize (Entity_Id E); #define Known_Normalized_First_Bit einfo__known_normalized_first_bit B Known_Normalized_First_Bit (Entity_Id E); @@ -743,8 +752,14 @@ #define Known_Static_Component_Bit_Offset einfo__known_static_component_bit_offset B Known_Static_Component_Bit_Offset (Entity_Id E); - INLINE B Known_Static_Component_Size (Entity_Id E); - INLINE B Known_Static_Esize (Entity_Id E); + #define Known_Static_Component_Size einfo__known_static_component_size + B Known_Static_Component_Size (Entity_Id E); + + #define Known_Static_Esize einfo__known_static_esize + B Known_Static_Esize (Entity_Id E); + + #define Known_Static_Normalized_First_Bit einfo__known_static_normalized_first_bit + B Known_Static_Normalized_First_Bit (Entity_Id E); #define Known_Static_Normalized_Position einfo__known_static_normalized_position B Known_Static_Normalized_Position (Entity_Id E); @@ -755,10 +770,17 @@ #define Known_Static_RM_Size einfo__known_static_rm_size B Known_Static_RM_Size (Entity_Id E); - INLINE B Unknown_Alignment (Entity_Id E); - INLINE B Unknown_Component_Bit_Offset (Entity_Id E); - INLINE B Unknown_Component_Size (Entity_Id E); - INLINE B Unknown_Esize (Entity_Id E); + #define Unknown_Alignment einfo__unknown_alignment + B Unknown_Alignment (Entity_Id E); + + #define Unknown_Component_Bit_Offset einfo__unknown_component_bit_offset + B Unknown_Component_Bit_Offset (Entity_Id E); + + #define Unknown_Component_Size einfo__unknown_component_size + B Unknown_Component_Size (Entity_Id E); + + #define Unknown_Esize einfo__unknown_esize + B Unknown_Esize (Entity_Id E); #define Unknown_Normalized_First_Bit einfo__unknown_normalized_first_bit B Unknown_Normalized_First_Bit (Entity_Id E); @@ -777,7 +799,7 @@ { return Elist21 (Id); } INLINE E Access_Disp_Table (E Id) - { return Node16 (Base_Type (Underlying_Type (Base_Type (Id)))); } + { return Node16 (Implementation_Base_Type (Id)); } INLINE E Actual_Subtype (E Id) { return Node17 (Id); } @@ -801,7 +823,7 @@ { return Node8 (Id); } INLINE E Associated_Storage_Pool (E Id) - { return Node22 (Id); } + { return Node22 (Root_Type (Id)); } INLINE N Barrier_Function (E Id) { return Node12 (Id); } @@ -1121,6 +1143,9 @@ INLINE B Has_Pragma_Pure_Function (E Id) { return Flag179 (Id); } + INLINE B Has_Pragma_Unreferenced (E Id) + { return Flag180 (Id); } + INLINE B Has_Primitive_Operations (E Id) { return Flag120 (Base_Type (Id)); } @@ -1131,7 +1156,7 @@ { return Flag161 (Id); } INLINE B Has_Record_Rep_Clause (E Id) - { return Flag65 (Id); } + { return Flag65 (Implementation_Base_Type (Id)); } INLINE B Has_Recursive_Call (E Id) { return Flag143 (Id); } @@ -1143,7 +1168,7 @@ { return Flag67 (Id); } INLINE B Has_Specified_Layout (E Id) - { return Flag100 (Id); } + { return Flag100 (Implementation_Base_Type (Id)); } INLINE B Has_Storage_Size_Clause (E Id) { return Flag23 (Implementation_Base_Type (Id)); } @@ -1463,6 +1488,9 @@ INLINE E Object_Ref (E Id) { return Node17 (Id); } + INLINE E Original_Array_Type (E Id) + { return Node21 (Id); } + INLINE E Original_Record_Component (E Id) { return Node22 (Id); } @@ -1745,36 +1773,6 @@ INLINE B Is_Type (E Id) { return IN (Ekind (Id), Type_Kind); } - INLINE B Known_Alignment (Entity_Id E) - { return Uint14 (E) != Uint_0; } - - INLINE B Known_Component_Bit_Offset (Entity_Id E) - { return Uint11 (E) != No_Uint; } - - INLINE B Known_Component_Size (Entity_Id E) - { return Uint22 (Base_Type (E)) != Uint_0; } - - INLINE B Known_Esize (Entity_Id E) - { return Uint12 (E) != Uint_0; } - - INLINE B Known_Static_Component_Size (Entity_Id E) - { return Uint22 (Base_Type (E)) > Uint_0; } - - INLINE B Known_Static_Esize (Entity_Id E) - { return Uint12 (E) > Uint_0; } - - INLINE B Unknown_Alignment (Entity_Id E) - { return Uint14 (E) == Uint_0; } - - INLINE B Unknown_Component_Bit_Offset (Entity_Id E) - { return Uint11 (E) == No_Uint; } - - INLINE B Unknown_Component_Size (Entity_Id E) - { return Uint22 (Base_Type (E)) == Uint_0; } - - INLINE B Unknown_Esize (Entity_Id E) - { return Uint12 (E) == Uint_0; } - INLINE N Entry_Index_Type (E Id) { return Etype (Discrete_Subtype_Definition (Parent (Id))); } diff --git a/gcc/ada/elists.h b/gcc/ada/elists.h index f9eaea7cabe..1113a6a43c6 100644 --- a/gcc/ada/elists.h +++ b/gcc/ada/elists.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * $Revision: 1.1 $ + * $Revision$ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * @@ -51,9 +51,7 @@ struct Elmt_Item /* The element list headers and element descriptors themselves are stored in two arrays. The pointers to these arrays are passed as a parameter to the tree transformer procedure and stored in the global variables Elists_Ptr - and Elmts_Ptr after adjusting them by subtracting Elist_First_Entry and - Elmt_First_Entry, so that Elist_Id and Elmt_Id values can be used as - subscripts into these arrays */ + and Elmts_Ptr. */ extern struct Elist_Header *Elists_Ptr; extern struct Elmt_Item *Elmts_Ptr; @@ -70,28 +68,28 @@ INLINE Node_Id Node (Elmt) Elmt_Id Elmt; { - return Elmts_Ptr [Elmt].node; + return Elmts_Ptr[Elmt - First_Elmt_Id].node; } INLINE Elmt_Id First_Elmt (List) Elist_Id List; { - return Elists_Ptr [List].first; + return Elists_Ptr[List - First_Elist_Id].first; } INLINE Elmt_Id Last_Elmt (List) Elist_Id List; { - return Elists_Ptr [List].last; + return Elists_Ptr[List - First_Elist_Id].last; } INLINE Elmt_Id Next_Elmt (Node) Elmt_Id Node; { - Int N = Elmts_Ptr [Node].next; + Int N = Elmts_Ptr[Node - First_Elmt_Id].next; if (IN (N, Elist_Range)) return No_Elmt; @@ -103,5 +101,5 @@ INLINE Boolean Is_Empty_Elmt_List (Id) Elist_Id Id; { - return Elists_Ptr [Id].first == No_Elmt; + return Elists_Ptr[Id - First_Elist_Id].first == No_Elmt; } diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index e4576e64d50..8e208d7974c 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.4 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -42,6 +42,7 @@ with Hostparm; with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; +with Nlists; use Nlists; with Output; use Output; with Scans; use Scans; with Sinput; use Sinput; @@ -72,6 +73,9 @@ package body Errout is Is_Warning_Msg : Boolean; -- Set by Set_Msg_Text to indicate if current message is warning message + Is_Serious_Error : Boolean; + -- Set by Set_Msg_Text to indicate if current message is serious error + Is_Unconditional_Msg : Boolean; -- Set by Set_Msg_Text to indicate if current message is unconditional @@ -161,6 +165,9 @@ package body Errout is Warn : Boolean; -- True if warning message (i.e. insertion character ? appeared) + Serious : Boolean; + -- True if serious error message (not a warning and no | character) + Uncond : Boolean; -- True if unconditional message (i.e. insertion character ! appeared) @@ -399,6 +406,18 @@ package body Errout is -- Outputs up to N levels of qualification for the given entity. For -- example, the entity A.B.C.D will output B.C. if N = 2. + function Special_Msg_Delete + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id) + return Boolean; + -- This function is called from Error_Msg_NEL, passing the message Msg, + -- node N on which the error is to be posted, and the entity or node E + -- to be used for an & insertion in the message if any. The job of this + -- procedure is to test for certain cascaded messages that we would like + -- to suppress. If the message is to be suppressed then we return True. + -- If the message should be generated (the normal case) False is returned. + procedure Test_Warning_Msg (Msg : String); -- Sets Is_Warning_Msg true if Msg is a warning message (contains a -- question mark character), and False otherwise. @@ -506,6 +525,10 @@ package body Errout is -- always know that Keep has at least as many continuations as -- Delete (since we always delete the shorter sequence). + ---------------- + -- Delete_Msg -- + ---------------- + procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is D, K : Error_Msg_Id; @@ -521,7 +544,11 @@ package body Errout is if Errors.Table (D).Warn then Warnings_Detected := Warnings_Detected - 1; else - Errors_Detected := Errors_Detected - 1; + Total_Errors_Detected := Total_Errors_Detected - 1; + + if Errors.Table (D).Serious then + Serious_Errors_Detected := Serious_Errors_Detected - 1; + end if; end if; -- Substitute shorter of the two error messages @@ -602,7 +629,7 @@ package body Errout is function Compilation_Errors return Boolean is begin - return Errors_Detected /= 0 + return Total_Errors_Detected /= 0 or else (Warnings_Detected /= 0 and then Warning_Mode = Treat_As_Error); end Compilation_Errors; @@ -647,6 +674,7 @@ package body Errout is w (" Line = ", Int (E.Line)); w (" Col = ", Int (E.Col)); w (" Warn = ", E.Warn); + w (" Serious = ", E.Serious); w (" Uncond = ", E.Uncond); w (" Msg_Cont = ", E.Msg_Cont); w (" Deleted = ", E.Deleted); @@ -679,7 +707,7 @@ package body Errout is -- that this is safe in the sense that proceeding will surely bomb. if Flag_Location < First_Source_Ptr - and then Errors_Detected > 0 + and then Total_Errors_Detected > 0 then return; end if; @@ -976,11 +1004,16 @@ package body Errout is Orig_Loc : constant Source_Ptr := Original_Location (Flag_Location); - procedure Handle_Fatal_Error; - -- Internal procedure to do all error message handling other than - -- bumping the error count and arranging for the message to be output. + procedure Handle_Serious_Error; + -- Internal procedure to do all error message handling for a serious + -- error message, other than bumping the error counts and arranging + -- for the message to be output. - procedure Handle_Fatal_Error is + -------------------------- + -- Handle_Serious_Error -- + -------------------------- + + procedure Handle_Serious_Error is begin -- Turn off code generation if not done already @@ -991,7 +1024,7 @@ package body Errout is -- Set the fatal error flag in the unit table unless we are -- in Try_Semantics mode. This stops the semantics from being - -- performed if we find a parser error. This is skipped if we + -- performed if we find a serious error. This is skipped if we -- are currently dealing with the configuration pragma file. if not Try_Semantics @@ -999,7 +1032,7 @@ package body Errout is then Set_Fatal_Error (Get_Source_Unit (Orig_Loc)); end if; - end Handle_Fatal_Error; + end Handle_Serious_Error; -- Start of processing for Error_Msg_Internal @@ -1039,7 +1072,7 @@ package body Errout is if Kill_Message and then not All_Errors_Mode - and then Errors_Detected /= 0 + and then Total_Errors_Detected /= 0 then if not Continuation then Last_Killed := True; @@ -1059,7 +1092,10 @@ package body Errout is -- where we do this special processing, bypassing message output. if Ignore_Errors_Enable > 0 then - Handle_Fatal_Error; + if Is_Serious_Error then + Handle_Serious_Error; + end if; + return; end if; @@ -1075,6 +1111,7 @@ package body Errout is Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Orig_Loc); Errors.Table (Cur_Msg).Col := Get_Column_Number (Orig_Loc); Errors.Table (Cur_Msg).Warn := Is_Warning_Msg; + Errors.Table (Cur_Msg).Serious := Is_Serious_Error; Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg; Errors.Table (Cur_Msg).Msg_Cont := Continuation; Errors.Table (Cur_Msg).Deleted := False; @@ -1181,13 +1218,17 @@ package body Errout is if Errors.Table (Cur_Msg).Warn then Warnings_Detected := Warnings_Detected + 1; else - Errors_Detected := Errors_Detected + 1; - Handle_Fatal_Error; + Total_Errors_Detected := Total_Errors_Detected + 1; + + if Errors.Table (Cur_Msg).Serious then + Serious_Errors_Detected := Serious_Errors_Detected + 1; + Handle_Serious_Error; + end if; end if; -- Terminate if max errors reached - if Errors_Detected + Warnings_Detected = Maximum_Errors then + if Total_Errors_Detected + Warnings_Detected = Maximum_Errors then raise Unrecoverable_Error; end if; @@ -1199,30 +1240,7 @@ package body Errout is procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is begin - if No_Warnings (N) then - Test_Warning_Msg (Msg); - - if Is_Warning_Msg then - return; - end if; - end if; - - if All_Errors_Mode - or else Msg (Msg'Last) = '!' - or else OK_Node (N) - or else (Msg (1) = '\' and not Last_Killed) - then - Debug_Output (N); - Error_Msg_Node_1 := N; - Error_Msg (Msg, Sloc (N)); - - else - Last_Killed := True; - end if; - - if not Is_Warning_Msg then - Set_Posted (N); - end if; + Error_Msg_NEL (Msg, N, N, Sloc (N)); end Error_Msg_N; ------------------ @@ -1235,6 +1253,24 @@ package body Errout is E : Node_Or_Entity_Id) is begin + Error_Msg_NEL (Msg, N, E, Sloc (N)); + end Error_Msg_NE; + + ------------------- + -- Error_Msg_NEL -- + ------------------- + + procedure Error_Msg_NEL + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id; + Flag_Location : Source_Ptr) + is + begin + if Special_Msg_Delete (Msg, N, E) then + return; + end if; + if No_Warnings (N) or else No_Warnings (E) then Test_Warning_Msg (Msg); @@ -1250,7 +1286,7 @@ package body Errout is then Debug_Output (N); Error_Msg_Node_1 := E; - Error_Msg (Msg, Sloc (N)); + Error_Msg (Msg, Flag_Location); else Last_Killed := True; @@ -1259,7 +1295,7 @@ package body Errout is if not Is_Warning_Msg then Set_Posted (N); end if; - end Error_Msg_NE; + end Error_Msg_NEL; ----------------- -- Error_Msg_S -- @@ -1431,7 +1467,9 @@ package body Errout is -- Extra blank line if error messages or source listing were output - if Errors_Detected + Warnings_Detected > 0 or else Full_List then + if Total_Errors_Detected + Warnings_Detected > 0 + or else Full_List + then Write_Eol; end if; @@ -1447,7 +1485,7 @@ package body Errout is -- the stdout buffer was flushed, giving an extra line feed after -- the prefix. - if Errors_Detected + Warnings_Detected /= 0 + if Total_Errors_Detected + Warnings_Detected /= 0 and then not Brief_Output and then (Verbose_Mode or Full_List) then @@ -1465,14 +1503,14 @@ package body Errout is Write_Str (" lines: "); end if; - if Errors_Detected = 0 then + if Total_Errors_Detected = 0 then Write_Str ("No errors"); - elsif Errors_Detected = 1 then + elsif Total_Errors_Detected = 1 then Write_Str ("1 error"); else - Write_Int (Errors_Detected); + Write_Int (Total_Errors_Detected); Write_Str (" errors"); end if; @@ -1501,7 +1539,7 @@ package body Errout is end if; if Maximum_Errors /= 0 - and then Errors_Detected + Warnings_Detected = Maximum_Errors + and then Total_Errors_Detected + Warnings_Detected = Maximum_Errors then Set_Standard_Error; Write_Str ("fatal error: maximum errors reached"); @@ -1510,7 +1548,7 @@ package body Errout is end if; if Warning_Mode = Treat_As_Error then - Errors_Detected := Errors_Detected + Warnings_Detected; + Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected; Warnings_Detected := 0; end if; @@ -1542,7 +1580,8 @@ package body Errout is begin Errors.Init; Error_Msgs := No_Error_Msg; - Errors_Detected := 0; + Serious_Errors_Detected := 0; + Total_Errors_Detected := 0; Warnings_Detected := 0; Cur_Msg := No_Error_Msg; List_Pragmas.Init; @@ -1907,7 +1946,11 @@ package body Errout is if Errors.Table (E).Warn then Warnings_Detected := Warnings_Detected - 1; else - Errors_Detected := Errors_Detected - 1; + Total_Errors_Detected := Total_Errors_Detected - 1; + + if Errors.Table (E).Serious then + Serious_Errors_Detected := Serious_Errors_Detected - 1; + end if; end if; return True; @@ -1996,21 +2039,27 @@ package body Errout is if Nkind (N) = N_Raise_Constraint_Error and then Original_Node (N) /= N + and then No (Condition (N)) then -- Warnings may have been posted on subexpressions of - -- the original tree. We temporarily replace the raise - -- statement with the original expression to remove - -- those warnings, whose sloc do not match those of - -- any node in the current tree. + -- the original tree. We place the original node back + -- on the tree to remove those warnings, whose sloc + -- do not match those of any node in the current tree. + -- Given that we are in unreachable code, this modification + -- to the tree is harmless. declare - Old : Node_Id := N; Status : Traverse_Result; begin - Rewrite (N, Original_Node (N)); - Status := Check_For_Warning (N); - Rewrite (N, Old); + if Is_List_Member (N) then + Set_Condition (N, Original_Node (N)); + Status := Check_All_Warnings (Condition (N)); + else + Rewrite (N, Original_Node (N)); + Status := Check_All_Warnings (N); + end if; + return Status; end; @@ -2825,6 +2874,9 @@ package body Errout is elsif C = '?' then null; + elsif C = '|' then + null; + elsif C = ''' then Set_Msg_Char (Text (P)); P := P + 1; @@ -2887,6 +2939,17 @@ package body Errout is Set_Error_Posted (P); exit when Nkind (P) not in N_Subexpr; end loop; + + -- A special check, if we just posted an error on an attribute + -- definition clause, then also set the entity involved as posted. + -- For example, this stops complaining about the alignment after + -- complaining about the size, which is likely to be useless. + + if Nkind (P) = N_Attribute_Definition_Clause then + if Is_Entity_Name (Name (P)) then + Set_Error_Posted (Entity (Name (P))); + end if; + end if; end Set_Posted; ----------------------- @@ -2963,15 +3026,78 @@ package body Errout is end if; end Set_Warnings_Mode_On; - ---------------------- - -- Test_Warning_Msg -- - ---------------------- + ------------------------ + -- Special_Msg_Delete -- + ------------------------ + + function Special_Msg_Delete + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id) + return Boolean + is + begin + -- Never delete messages in -gnatdO mode + + if Debug_Flag_OO then + return False; + + -- When an atomic object refers to a non-atomic type in the same + -- scope, we implicitly make the type atomic. In the non-error + -- case this is surely safe (and in fact prevents an error from + -- occurring if the type is not atomic by default). But if the + -- object cannot be made atomic, then we introduce an extra junk + -- message by this manipulation, which we get rid of here. + + -- We identify this case by the fact that it references a type for + -- which Is_Atomic is set, but there is no Atomic pragma setting it. + + elsif Msg = "atomic access to & cannot be guaranteed" + and then Is_Type (E) + and then Is_Atomic (E) + and then No (Get_Rep_Pragma (E, Name_Atomic)) + then + return True; + + -- When a size is wrong for a frozen type there is no explicit + -- size clause, and other errors have occurred, suppress the + -- message, since it is likely that this size error is a cascaded + -- result of other errors. The reason we eliminate unfrozen types + -- is that messages issued before the freeze type are for sure OK. + + elsif Msg = "size for& too small, minimum allowed is ^" + and then Is_Frozen (E) + and then Serious_Errors_Detected > 0 + and then Nkind (N) /= N_Component_Clause + and then Nkind (Parent (N)) /= N_Component_Clause + and then + No (Get_Attribute_Definition_Clause (E, Attribute_Size)) + and then + No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size)) + and then + No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size)) + then + return True; + + -- All special tests complete, so go ahead with message + + else + return False; + end if; + end Special_Msg_Delete; + + ------------------------------ + -- Test_Warning_Serious_Msg -- + ------------------------------ procedure Test_Warning_Msg (Msg : String) is begin + Is_Serious_Error := True; + if Msg'Length > 7 and then Msg (1 .. 7) = "(style)" then Is_Warning_Msg := True; - return; + else + Is_Warning_Msg := False; end if; for J in Msg'Range loop @@ -2979,11 +3105,17 @@ package body Errout is and then (J = Msg'First or else Msg (J - 1) /= ''') then Is_Warning_Msg := True; - return; + + elsif Msg (J) = '|' + and then (J = Msg'First or else Msg (J - 1) /= ''') + then + Is_Serious_Error := False; end if; end loop; - Is_Warning_Msg := False; + if Is_Warning_Msg then + Is_Serious_Error := False; + end if; end Test_Warning_Msg; -------------------------- diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index ece8175434c..ffaa4c18483 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.70 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -37,8 +37,15 @@ with Uintp; use Uintp; package Errout is - Errors_Detected : Nat; - -- Number of errors detected so far + Serious_Errors_Detected : Nat; + -- This is a count of errors that are serious enough to stop expansion, + -- and hence to prevent generation of an object file even if the + -- switch -gnatQ is set. + + Total_Errors_Detected : Nat; + -- Number of errors detected so far. Includes count of serious errors + -- and non-serious errors, so this value is always greater than or + -- equal to the Serious_Errors_Detected value. Warnings_Detected : Nat; -- Number of warnings detected @@ -242,6 +249,14 @@ package Errout is -- of messages are treated as a unit. The \ character must be -- the first character of the message text. + -- Insertion character | (vertical bar, non-serious error) + -- By default, error messages (other than warning messages) are + -- considered to be fatal error messages which prevent expansion + -- or generation of code in the presence of the -gnatQ switch. + -- If the insertion character | appears, the message is considered + -- to be non-serious, and does not cause Serious_Errors_Detected + -- to be incremented (so expansion is not prevented by such a msg). + ----------------------------------------------------- -- Global Values Used for Error Message Insertions -- ----------------------------------------------------- @@ -462,17 +477,28 @@ package Errout is -- from the latter is much more common (and is the most usual way of -- generating error messages from the analyzer). The message text may -- contain a single & insertion, which will reference the given node. + -- The message is suppressed if the node N already has a message posted, + -- or if it is a warning and warnings and N is an entity node for which + -- warnings are suppressed. procedure Error_Msg_NE (Msg : String; N : Node_Or_Entity_Id; E : Node_Or_Entity_Id); - -- Output a message at the Sloc of the given node, with an insertion of - -- the name from the given entity node. This is used by the semantic + -- Output a message at the Sloc of the given node N, with an insertion of + -- the name from the given entity node E. This is used by the semantic -- routines, where this is a common error message situation. The Msg -- text will contain a & or } as usual to mark the insertion point. -- This routine can be called from the parser or the analyzer. + procedure Error_Msg_NEL + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id; + Flag_Location : Source_Ptr); + -- Exactly the same as Error_Msg_NE, except that the flag is placed at + -- the specified Flag_Location instead of at Sloc (N). + procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String); -- The error message text of the message identified by Id is replaced by -- the given text. This text may contain insertion characters in the diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb index 99f5a9f6a19..f7f328ff5e0 100644 --- a/gcc/ada/eval_fat.adb +++ b/gcc/ada/eval_fat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.33 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -145,6 +145,7 @@ package body Eval_Fat is --------------- function Copy_Sign (RT : R; Value, Sign : T) return T is + pragma Warnings (Off, RT); Result : T; begin @@ -838,6 +839,8 @@ package body Eval_Fat is ------------- function Scaling (RT : R; X : T; Adjustment : UI) return T is + pragma Warnings (Off, RT); + begin if Rbase (X) = Radix then return UR_From_Components @@ -894,6 +897,8 @@ package body Eval_Fat is ---------------- function Truncation (RT : R; X : T) return T is + pragma Warnings (Off, RT); + begin return UR_From_Uint (UR_Trunc (X)); end Truncation; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index e32fe91642e..36d8c64499f 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -28,6 +28,7 @@ with Atree; use Atree; with Checks; use Checks; +with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Expander; use Expander; @@ -37,10 +38,12 @@ with Exp_Ch7; use Exp_Ch7; with Freeze; use Freeze; with Hostparm; use Hostparm; with Itypes; use Itypes; +with Lib; use Lib; with Nmake; use Nmake; with Nlists; use Nlists; with Restrict; use Restrict; with Rtsfind; use Rtsfind; +with Ttypes; use Ttypes; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Eval; use Sem_Eval; @@ -113,10 +116,41 @@ package body Exp_Aggr is -- an entity that allows to know if the value being created needs to be -- attached to the final list in case of pragma finalize_Storage_Only. + procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id); + -- If the type of the aggregate is a type extension with renamed discrimi- + -- nants, we must initialize the hidden discriminants of the parent. + -- Otherwise, the target object must not be initialized. The discriminants + -- are initialized by calling the initialization procedure for the type. + -- This is incorrect if the initialization of other components has any + -- side effects. We restrict this call to the case where the parent type + -- has a variant part, because this is the only case where the hidden + -- discriminants are accessed, namely when calling discriminant checking + -- functions of the parent type, and when applying a stream attribute to + -- an object of the derived type. + ----------------------------------------------------- - -- Local subprograms for array aggregate expansion -- + -- Local Subprograms for Array Aggregate Expansion -- ----------------------------------------------------- + procedure Convert_To_Positional + (N : Node_Id; + Max_Others_Replicate : Nat := 5; + Handle_Bit_Packed : Boolean := False); + -- If possible, convert named notation to positional notation. This + -- conversion is possible only in some static cases. If the conversion + -- is possible, then N is rewritten with the analyzed converted + -- aggregate. The parameter Max_Others_Replicate controls the maximum + -- number of values corresponding to an others choice that will be + -- converted to positional notation (the default of 5 is the normal + -- limit, and reflects the fact that normally the loop is better than + -- a lot of separate assignments). Note that this limit gets overridden + -- in any case if either of the restrictions No_Elaboration_Code or + -- No_Implicit_Loops is set. The parameter Handle_Bit_Packed is usually + -- set False (since we do not expect the back end to handle bit packed + -- arrays, so the normal case of conversion is pointless), but in the + -- special case of a call from Packed_Array_Aggregate_Handled, we set + -- this parameter to True, since these are cases we handle in there. + procedure Expand_Array_Aggregate (N : Node_Id); -- This is the top-level routine to perform array aggregate expansion. -- N is the N_Aggregate node to be expanded. @@ -185,10 +219,16 @@ package body Exp_Aggr is -- use this routine. This is needed to deal with assignments to -- initialized constants that are done in place. - function Safe_Slice_Assignment - (N : Node_Id; - Typ : Entity_Id) - return Boolean; + function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean; + -- Given an array aggregate, this function handles the case of a packed + -- array aggregate with all constant values, where the aggregate can be + -- evaluated at compile time. If this is possible, then N is rewritten + -- to be its proper compile time value with all the components properly + -- assembled. The expression is analyzed and resolved and True is + -- returned. If this transformation is not possible, N is unchanged + -- and False is returned + + function Safe_Slice_Assignment (N : Node_Id) return Boolean; -- If a slice assignment has an aggregate with a single others_choice, -- the assignment can be done in place even if bounds are not static, -- by converting it into a loop over the discrete range of the slice. @@ -340,10 +380,10 @@ package body Exp_Aggr is -- we always generate something like: - -- I : Index_Type := Index_Of_Last_Positional_Element; - -- while I < H loop - -- I := Index_Base'Succ (I) - -- Tmp (I) := E; + -- J : Index_Type := Index_Of_Last_Positional_Element; + -- while J < H loop + -- J := Index_Base'Succ (J) + -- Tmp (J) := E; -- end loop; function Build_Array_Aggr_Code @@ -401,10 +441,10 @@ package body Exp_Aggr is -- If the input aggregate N to Build_Loop contains no sub-aggregates, -- This routine returns the while loop statement -- - -- I : Index_Base := L; - -- while I < H loop - -- I := Index_Base'Succ (I); - -- Into (Indices, I) := Expr; + -- J : Index_Base := L; + -- while J < H loop + -- J := Index_Base'Succ (J); + -- Into (Indices, J) := Expr; -- end loop; -- -- Otherwise we call Build_Code recursively. @@ -788,13 +828,13 @@ package body Exp_Aggr is -------------- function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is - L_I : Node_Id; + L_J : Node_Id; L_Range : Node_Id; -- Index_Base'(L) .. Index_Base'(H) L_Iteration_Scheme : Node_Id; - -- L_I in Index_Base'(L) .. Index_Base'(H) + -- L_J in Index_Base'(L) .. Index_Base'(H) L_Body : List_Id; -- The statements to execute in the loop @@ -855,9 +895,9 @@ package body Exp_Aggr is return S; end if; - -- Otherwise construct the loop, starting with the loop index L_I + -- Otherwise construct the loop, starting with the loop index L_J - L_I := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); -- Construct "L .. H" @@ -873,7 +913,7 @@ package body Exp_Aggr is Subtype_Mark => Index_Base_Name, Expression => H)); - -- Construct "for L_I in Index_Base range L .. H" + -- Construct "for L_J in Index_Base range L .. H" L_Iteration_Scheme := Make_Iteration_Scheme @@ -881,12 +921,12 @@ package body Exp_Aggr is Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, - Defining_Identifier => L_I, + Defining_Identifier => L_J, Discrete_Subtype_Definition => L_Range)); -- Construct the statements to execute in the loop body - L_Body := Gen_Assign (New_Reference_To (L_I, Loc), Expr); + L_Body := Gen_Assign (New_Reference_To (L_J, Loc), Expr); -- Construct the final loop @@ -905,27 +945,27 @@ package body Exp_Aggr is -- The code built is - -- W_I : Index_Base := L; - -- while W_I < H loop - -- W_I := Index_Base'Succ (W); + -- W_J : Index_Base := L; + -- while W_J < H loop + -- W_J := Index_Base'Succ (W); -- L_Body; -- end loop; function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is - W_I : Node_Id; + W_J : Node_Id; W_Decl : Node_Id; - -- W_I : Base_Type := L; + -- W_J : Base_Type := L; W_Iteration_Scheme : Node_Id; - -- while W_I < H + -- while W_J < H W_Index_Succ : Node_Id; - -- Index_Base'Succ (I) + -- Index_Base'Succ (J) W_Increment : Node_Id; - -- W_I := Index_Base'Succ (W) + -- W_J := Index_Base'Succ (W) W_Body : List_Id := New_List; -- The statements to execute in the loop @@ -941,13 +981,13 @@ package body Exp_Aggr is return S; end if; - -- Build the decl of W_I + -- Build the decl of W_J - W_I := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + W_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); W_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => W_I, + Defining_Identifier => W_J, Object_Definition => Index_Base_Name, Expression => L); @@ -957,14 +997,14 @@ package body Exp_Aggr is Append_To (S, W_Decl); - -- construct " while W_I < H" + -- construct " while W_J < H" W_Iteration_Scheme := Make_Iteration_Scheme (Loc, Condition => Make_Op_Lt (Loc, - Left_Opnd => New_Reference_To (W_I, Loc), + Left_Opnd => New_Reference_To (W_J, Loc), Right_Opnd => New_Copy_Tree (H))); -- Construct the statements to execute in the loop body @@ -974,17 +1014,17 @@ package body Exp_Aggr is (Loc, Prefix => Index_Base_Name, Attribute_Name => Name_Succ, - Expressions => New_List (New_Reference_To (W_I, Loc))); + Expressions => New_List (New_Reference_To (W_J, Loc))); W_Increment := Make_OK_Assignment_Statement (Loc, - Name => New_Reference_To (W_I, Loc), + Name => New_Reference_To (W_J, Loc), Expression => W_Index_Succ); Append_To (W_Body, W_Increment); Append_List_To (W_Body, - Gen_Assign (New_Reference_To (W_I, Loc), Expr)); + Gen_Assign (New_Reference_To (W_J, Loc), Expr)); -- Construct the final loop @@ -1417,8 +1457,10 @@ package body Exp_Aggr is Selector_Name => New_Occurrence_Of (Discr, Loc)), Right_Opnd => Disc_Value); - Append_To (L, Make_Raise_Constraint_Error (Loc, - Condition => Cond)); + Append_To (L, + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Discriminant_Check_Failed)); end if; Next_Discriminant (Discr); @@ -1556,7 +1598,10 @@ package body Exp_Aggr is Subtype_Indication => New_Indic); -- Itypes must be analyzed with checks off + -- Declaration must have a parent for proper + -- handling of subsidiary actions. + Set_Parent (Subt_Decl, N); Analyze (Subt_Decl, Suppress => All_Checks); end; end if; @@ -2073,6 +2118,7 @@ package body Exp_Aggr is Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj)); Set_No_Initialization (N); + Initialize_Discriminants (N, Typ); end Convert_Aggr_In_Object_Decl; ---------------------------- @@ -2151,6 +2197,7 @@ package body Exp_Aggr is Set_No_Initialization (Instr); Insert_Action (N, Instr); + Initialize_Discriminants (Instr, Typ); Target_Expr := New_Occurrence_Of (Temp, Loc); Insert_Actions (N, Build_Record_Aggr_Code (N, Typ, Target_Expr)); @@ -2158,6 +2205,239 @@ package body Exp_Aggr is Analyze_And_Resolve (N, Typ); end Convert_To_Assignments; + --------------------------- + -- Convert_To_Positional -- + --------------------------- + + procedure Convert_To_Positional + (N : Node_Id; + Max_Others_Replicate : Nat := 5; + Handle_Bit_Packed : Boolean := False) + is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Ndim : constant Pos := Number_Dimensions (Typ); + Xtyp : constant Entity_Id := Etype (First_Index (Typ)); + Indx : constant Node_Id := First_Index (Base_Type (Typ)); + Blo : constant Node_Id := Type_Low_Bound (Etype (Indx)); + Lo : constant Node_Id := Type_Low_Bound (Xtyp); + Hi : constant Node_Id := Type_High_Bound (Xtyp); + Lov : Uint; + Hiv : Uint; + + -- The following constant determines the maximum size of an + -- aggregate produced by converting named to positional + -- notation (e.g. from others clauses). This avoids running + -- away with attempts to convert huge aggregates. + + -- The normal limit is 5000, but we increase this limit to + -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code) + -- or Restrictions (No_Implicit_Loops) is specified, since in + -- either case, we are at risk of declaring the program illegal + -- because of this limit. + + Max_Aggr_Size : constant Nat := + 5000 + (2 ** 24 - 5000) * Boolean'Pos + (Restrictions (No_Elaboration_Code) + or else + Restrictions (No_Implicit_Loops)); + + begin + -- For now, we only handle the one dimensional case and aggregates + -- that are not part of a component_association + + if Ndim > 1 or else Nkind (Parent (N)) = N_Aggregate + or else Nkind (Parent (N)) = N_Component_Association + then + return; + end if; + + -- If already positional, nothing to do! + + if No (Component_Associations (N)) then + return; + end if; + + -- Bounds need to be known at compile time + + if not Compile_Time_Known_Value (Lo) + or else not Compile_Time_Known_Value (Hi) + then + return; + end if; + + -- Normally we do not attempt to convert bit packed arrays. The + -- exception is when we are explicitly asked to do so (this call + -- is from the Packed_Array_Aggregate_Handled procedure). + + if Is_Bit_Packed_Array (Typ) + and then not Handle_Bit_Packed + then + return; + end if; + + -- Do not convert to positional if controlled components are + -- involved since these require special processing + + if Has_Controlled_Component (Typ) then + return; + end if; + + -- Get bounds and check reasonable size (positive, not too large) + -- Also only handle bounds starting at the base type low bound for now + -- since the compiler isn't able to handle different low bounds yet. + + Lov := Expr_Value (Lo); + Hiv := Expr_Value (Hi); + + if Hiv < Lov + or else (Hiv - Lov > Max_Aggr_Size) + or else not Compile_Time_Known_Value (Blo) + or else (Lov /= Expr_Value (Blo)) + then + return; + end if; + + -- Bounds must be in integer range (for array Vals below) + + if not UI_Is_In_Int_Range (Lov) + or else + not UI_Is_In_Int_Range (Hiv) + then + return; + end if; + + -- Determine if set of alternatives is suitable for conversion + -- and build an array containing the values in sequence. + + declare + Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv)) + of Node_Id := (others => Empty); + -- The values in the aggregate sorted appropriately + + Vlist : List_Id; + -- Same data as Vals in list form + + Rep_Count : Nat; + -- Used to validate Max_Others_Replicate limit + + Elmt : Node_Id; + Num : Int := UI_To_Int (Lov); + Choice : Node_Id; + Lo, Hi : Node_Id; + + begin + if Present (Expressions (N)) then + Elmt := First (Expressions (N)); + while Present (Elmt) loop + Vals (Num) := Relocate_Node (Elmt); + Num := Num + 1; + Next (Elmt); + end loop; + end if; + + Elmt := First (Component_Associations (N)); + Component_Loop : while Present (Elmt) loop + + Choice := First (Choices (Elmt)); + Choice_Loop : while Present (Choice) loop + + -- If we have an others choice, fill in the missing elements + -- subject to the limit established by Max_Others_Replicate. + + if Nkind (Choice) = N_Others_Choice then + Rep_Count := 0; + + for J in Vals'Range loop + if No (Vals (J)) then + Vals (J) := New_Copy_Tree (Expression (Elmt)); + Rep_Count := Rep_Count + 1; + + -- Check for maximum others replication. Note that + -- we skip this test if either of the restrictions + -- No_Elaboration_Code or No_Implicit_Loops is + -- active, or if this is a preelaborable unit. + + if Rep_Count > Max_Others_Replicate + and then not Restrictions (No_Elaboration_Code) + and then not Restrictions (No_Implicit_Loops) + and then not + Is_Preelaborated (Cunit_Entity (Current_Sem_Unit)) + then + return; + end if; + end if; + end loop; + + exit Component_Loop; + + -- Case of a subtype mark + + elsif (Nkind (Choice) = N_Identifier + and then Is_Type (Entity (Choice))) + then + Lo := Type_Low_Bound (Etype (Choice)); + Hi := Type_High_Bound (Etype (Choice)); + + -- Case of subtype indication + + elsif Nkind (Choice) = N_Subtype_Indication then + Lo := Low_Bound (Range_Expression (Constraint (Choice))); + Hi := High_Bound (Range_Expression (Constraint (Choice))); + + -- Case of a range + + elsif Nkind (Choice) = N_Range then + Lo := Low_Bound (Choice); + Hi := High_Bound (Choice); + + -- Normal subexpression case + + else pragma Assert (Nkind (Choice) in N_Subexpr); + if not Compile_Time_Known_Value (Choice) then + return; + + else + Vals (UI_To_Int (Expr_Value (Choice))) := + New_Copy_Tree (Expression (Elmt)); + goto Continue; + end if; + end if; + + -- Range cases merge with Lo,Hi said + + if not Compile_Time_Known_Value (Lo) + or else + not Compile_Time_Known_Value (Hi) + then + return; + else + for J in UI_To_Int (Expr_Value (Lo)) .. + UI_To_Int (Expr_Value (Hi)) + loop + Vals (J) := New_Copy_Tree (Expression (Elmt)); + end loop; + end if; + + <<Continue>> + Next (Choice); + end loop Choice_Loop; + + Next (Elmt); + end loop Component_Loop; + + -- If we get here the conversion is possible + + Vlist := New_List; + for J in Vals'Range loop + Append (Vals (J), Vlist); + end loop; + + Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist)); + Analyze_And_Resolve (N, Typ); + end; + end Convert_To_Positional; + ---------------------------- -- Expand_Array_Aggregate -- ---------------------------- @@ -2190,7 +2470,7 @@ package body Exp_Aggr is Typ : constant Entity_Id := Etype (N); Ctyp : constant Entity_Id := Component_Type (Typ); - -- Typ is the correct constrained array subtype of the aggregate and + -- Typ is the correct constrained array subtype of the aggregate -- Ctyp is the corresponding component type. Aggr_Dimension : constant Pos := Number_Dimensions (Typ); @@ -2208,10 +2488,10 @@ package body Exp_Aggr is -- is the expression in an assignment, assignment in place may be -- possible, provided other conditions are met on the LHS. - Others_Present : array (1 .. Aggr_Dimension) of Boolean - := (others => False); - -- If Others_Present (I) is True, then there is an others choice - -- in one of the sub-aggregates of N at dimension I. + Others_Present : array (1 .. Aggr_Dimension) of Boolean := + (others => False); + -- If Others_Present (J) is True, then there is an others choice + -- in one of the sub-aggregates of N at dimension J. procedure Build_Constrained_Type (Positional : Boolean); -- If the subtype is not static or unconstrained, build a constrained @@ -2233,12 +2513,6 @@ package body Exp_Aggr is -- array sub-aggregate we start the computation from. Dim is the -- dimension corresponding to the sub-aggregate. - procedure Convert_To_Positional (N : Node_Id); - -- If possible, convert named notation to positional notation. This - -- conversion is possible only in some static cases. If the conversion - -- is possible, then N is rewritten with the analyzed converted - -- aggregate. - function Has_Address_Clause (D : Node_Id) return Boolean; -- If the aggregate is the expression in an object declaration, it -- cannot be expanded in place. This function does a lookahead in the @@ -2401,7 +2675,9 @@ package body Exp_Aggr is Set_Analyzed (Left_Opnd (Left_Opnd (Cond)), False); Set_Analyzed (Right_Opnd (Left_Opnd (Cond)), False); Insert_Action (N, - Make_Raise_Constraint_Error (Loc, Condition => Cond)); + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Length_Check_Failed)); end if; end Check_Bounds; @@ -2473,7 +2749,9 @@ package body Exp_Aggr is if Present (Cond) then Insert_Action (N, - Make_Raise_Constraint_Error (Loc, Condition => Cond)); + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Length_Check_Failed)); end if; -- Now look inside the sub-aggregate to see if there is more work @@ -2514,6 +2792,7 @@ package body Exp_Aggr is begin if Present (Component_Associations (Sub_Aggr)) then Assoc := Last (Component_Associations (Sub_Aggr)); + if Nkind (First (Choices (Assoc))) = N_Others_Choice then Others_Present (Dim) := True; end if; @@ -2546,224 +2825,6 @@ package body Exp_Aggr is end if; end Compute_Others_Present; - --------------------------- - -- Convert_To_Positional -- - --------------------------- - - procedure Convert_To_Positional (N : Node_Id) is - Typ : constant Entity_Id := Etype (N); - Ndim : constant Pos := Number_Dimensions (Typ); - Xtyp : constant Entity_Id := Etype (First_Index (Typ)); - Blo : constant Node_Id := - Type_Low_Bound (Etype (First_Index (Base_Type (Typ)))); - Lo : constant Node_Id := Type_Low_Bound (Xtyp); - Hi : constant Node_Id := Type_High_Bound (Xtyp); - Lov : Uint; - Hiv : Uint; - - Max_Aggr_Size : constant := 500; - -- Maximum size of aggregate produced by converting positional to - -- named notation. This avoids running away with attempts to - -- convert huge aggregates. - - Max_Others_Replicate : constant := 5; - -- This constant defines the maximum expansion of an others clause - -- into a list of values. This applies when converting a named - -- aggregate to positional form for processing by the back end. - -- If a given others clause generates more than five values, the - -- aggregate is retained as named, since the loop is more compact. - -- However, this constant is completely overridden if restriction - -- No_Elaboration_Code is active, since in this case, the loop - -- would not be allowed anyway. Similarly No_Implicit_Loops causes - -- this parameter to be ignored. - - begin - -- For now, we only handle the one dimensional case and aggregates - -- that are not part of a component_association - - if Ndim > 1 or else Nkind (Parent (N)) = N_Aggregate - or else Nkind (Parent (N)) = N_Component_Association - then - return; - end if; - - -- If already positional, nothing to do! - - if No (Component_Associations (N)) then - return; - end if; - - -- Bounds need to be known at compile time - - if not Compile_Time_Known_Value (Lo) - or else not Compile_Time_Known_Value (Hi) - then - return; - end if; - - -- Do not attempt to convert bit packed arrays, since they cannot - -- be handled by the backend in any case. - - if Is_Bit_Packed_Array (Typ) then - return; - end if; - - -- Do not convert to positional if controlled components are - -- involved since these require special processing - - if Has_Controlled_Component (Typ) then - return; - end if; - - -- Get bounds and check reasonable size (positive, not too large) - -- Also only handle bounds starting at the base type low bound for - -- now since the compiler isn't able to handle different low bounds - -- yet - - Lov := Expr_Value (Lo); - Hiv := Expr_Value (Hi); - - if Hiv < Lov - or else (Hiv - Lov > Max_Aggr_Size) - or else not Compile_Time_Known_Value (Blo) - or else (Lov /= Expr_Value (Blo)) - then - return; - end if; - - -- Bounds must be in integer range (for array Vals below) - - if not UI_Is_In_Int_Range (Lov) - or else - not UI_Is_In_Int_Range (Hiv) - then - return; - end if; - - -- Determine if set of alternatives is suitable for conversion - -- and build an array containing the values in sequence. - - declare - Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv)) - of Node_Id := (others => Empty); - -- The values in the aggregate sorted appropriately - - Vlist : List_Id; - -- Same data as Vals in list form - - Rep_Count : Nat; - -- Used to validate Max_Others_Replicate limit - - Elmt : Node_Id; - Num : Int := UI_To_Int (Lov); - Choice : Node_Id; - Lo, Hi : Node_Id; - - begin - if Present (Expressions (N)) then - Elmt := First (Expressions (N)); - while Present (Elmt) loop - Vals (Num) := Relocate_Node (Elmt); - Num := Num + 1; - Next (Elmt); - end loop; - end if; - - Elmt := First (Component_Associations (N)); - Component_Loop : while Present (Elmt) loop - - Choice := First (Choices (Elmt)); - Choice_Loop : while Present (Choice) loop - - -- If we have an others choice, fill in the missing elements - -- subject to the limit established by Max_Others_Replicate. - - if Nkind (Choice) = N_Others_Choice then - Rep_Count := 0; - - for J in Vals'Range loop - if No (Vals (J)) then - Vals (J) := New_Copy_Tree (Expression (Elmt)); - Rep_Count := Rep_Count + 1; - - if Rep_Count > Max_Others_Replicate - and then not Restrictions (No_Elaboration_Code) - and then not Restrictions (No_Implicit_Loops) - then - return; - end if; - end if; - end loop; - - exit Component_Loop; - - -- Case of a subtype mark - - elsif (Nkind (Choice) = N_Identifier - and then Is_Type (Entity (Choice))) - then - Lo := Type_Low_Bound (Etype (Choice)); - Hi := Type_High_Bound (Etype (Choice)); - - -- Case of subtype indication - - elsif Nkind (Choice) = N_Subtype_Indication then - Lo := Low_Bound (Range_Expression (Constraint (Choice))); - Hi := High_Bound (Range_Expression (Constraint (Choice))); - - -- Case of a range - - elsif Nkind (Choice) = N_Range then - Lo := Low_Bound (Choice); - Hi := High_Bound (Choice); - - -- Normal subexpression case - - else pragma Assert (Nkind (Choice) in N_Subexpr); - if not Compile_Time_Known_Value (Choice) then - return; - - else - Vals (UI_To_Int (Expr_Value (Choice))) := - New_Copy_Tree (Expression (Elmt)); - goto Continue; - end if; - end if; - - -- Range cases merge with Lo,Hi said - - if not Compile_Time_Known_Value (Lo) - or else - not Compile_Time_Known_Value (Hi) - then - return; - else - for J in UI_To_Int (Expr_Value (Lo)) .. - UI_To_Int (Expr_Value (Hi)) - loop - Vals (J) := New_Copy_Tree (Expression (Elmt)); - end loop; - end if; - - <<Continue>> - Next (Choice); - end loop Choice_Loop; - - Next (Elmt); - end loop Component_Loop; - - -- If we get here the conversion is possible - - Vlist := New_List; - for J in Vals'Range loop - Append (Vals (J), Vlist); - end loop; - - Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist)); - Analyze_And_Resolve (N, Typ); - end; - end Convert_To_Positional; - ------------------------- -- Has_Address_Clause -- ------------------------- @@ -2805,6 +2866,10 @@ package body Exp_Aggr is Obj_Lo : Node_Id; Obj_Hi : Node_Id; + function Is_Others_Aggregate (Aggr : Node_Id) return Boolean; + -- Aggregates that consist of a single Others choice are safe + -- if the single expression is. + function Safe_Aggregate (Aggr : Node_Id) return Boolean; -- Check recursively that each component of a (sub)aggregate does -- not depend on the variable being assigned to. @@ -2813,6 +2878,18 @@ package body Exp_Aggr is -- Verify that an expression cannot depend on the variable being -- assigned to. Room for improvement here (but less than before). + ------------------------- + -- Is_Others_Aggregate -- + ------------------------- + + function Is_Others_Aggregate (Aggr : Node_Id) return Boolean is + begin + return No (Expressions (Aggr)) + and then Nkind + (First (Choices (First (Component_Associations (Aggr))))) + = N_Others_Choice; + end Is_Others_Aggregate; + -------------------- -- Safe_Aggregate -- -------------------- @@ -2907,13 +2984,28 @@ package body Exp_Aggr is if not Analyzed (Comp) then if Is_Overloaded (Expr) then return False; + + elsif Nkind (Expr) = N_Aggregate + and then not Is_Others_Aggregate (Expr) + then + return False; + + elsif Nkind (Expr) = N_Allocator then + -- For now, too complex to analyze. + + return False; end if; Comp := New_Copy_Tree (Expr); + Set_Parent (Comp, Parent (Expr)); Analyze (Comp); end if; - return Check_Component (Comp); + if Nkind (Comp) = N_Aggregate then + return Safe_Aggregate (Comp); + else + return Check_Component (Comp); + end if; end Safe_Component; -- Start of processing for In_Place_Assign_OK @@ -2929,11 +3021,7 @@ package body Exp_Aggr is -- are derived from the left-hand side, and the assignment is -- safe if the expression is. - if No (Expressions (N)) - and then Nkind - (First (Choices (First (Component_Associations (N))))) - = N_Others_Choice - then + if Is_Others_Aggregate (N) then return Safe_Component (Expression (First (Component_Associations (N)))); @@ -3041,7 +3129,7 @@ package body Exp_Aggr is end if; -- If we are dealing with a positional sub-aggregate with an - -- others choice, compute the number or positional elements. + -- others choice then compute the number or positional elements. if Need_To_Check and then Present (Expressions (Sub_Aggr)) then Expr := First (Expressions (Sub_Aggr)); @@ -3056,10 +3144,11 @@ package body Exp_Aggr is elsif Need_To_Check then Compute_Choices_Lo_And_Choices_Hi : declare + Table : Case_Table_Type (1 .. Nb_Choices); -- Used to sort all the different choice values - I : Pos := 1; + J : Pos := 1; Low : Node_Id; High : Node_Id; @@ -3073,10 +3162,10 @@ package body Exp_Aggr is end if; Get_Index_Bounds (Choice, Low, High); - Table (I).Choice_Lo := Low; - Table (I).Choice_Hi := High; + Table (J).Choice_Lo := Low; + Table (J).Choice_Hi := High; - I := I + 1; + J := J + 1; Next (Choice); end loop; @@ -3148,7 +3237,9 @@ package body Exp_Aggr is if Present (Cond) then Insert_Action (N, - Make_Raise_Constraint_Error (Loc, Condition => Cond)); + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Length_Check_Failed)); end if; -- Now look inside the sub-aggregate to see if there is more work @@ -3201,10 +3292,10 @@ package body Exp_Aggr is return; end if; - -- If during semantic analysis it has been determined that aggregate N - -- will raise Constraint_Error at run-time, then the aggregate node - -- has been replaced with an N_Raise_Constraint_Error node and we - -- should never get here. + -- If the semantic analyzer has determined that aggregate N will raise + -- Constraint_Error at run-time, then the aggregate node has been + -- replaced with an N_Raise_Constraint_Error node and we should + -- never get here. pragma Assert (not Raises_Constraint_Error (N)); @@ -3343,6 +3434,13 @@ package body Exp_Aggr is -- Look if in place aggregate expansion is possible + -- First case to test for is packed array aggregate that we can + -- handle at compile time. If so, return with transformation done. + + if Packed_Array_Aggregate_Handled (N) then + return; + end if; + -- For object declarations we build the aggregate in place, unless -- the array is bit-packed or the component is controlled. @@ -3370,7 +3468,6 @@ package body Exp_Aggr is and then not Has_Controlled_Component (Typ) and then not Has_Address_Clause (Parent (N)) then - Tmp := Defining_Identifier (Parent (N)); Set_No_Initialization (Parent (N)); Set_Expression (Parent (N), Empty); @@ -3402,14 +3499,25 @@ package body Exp_Aggr is end if; elsif Maybe_In_Place_OK + and then Nkind (Name (Parent (N))) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Name (Parent (N)))) + then + Tmp := Name (Parent (N)); + + if Etype (Tmp) /= Etype (N) then + Apply_Length_Check (N, Etype (Tmp)); + end if; + + elsif Maybe_In_Place_OK and then Nkind (Name (Parent (N))) = N_Slice - and then Safe_Slice_Assignment (N, Typ) + and then Safe_Slice_Assignment (N) then - -- Safe_Slice_Assignment rewrites assignment as a loop. + -- Safe_Slice_Assignment rewrites assignment as a loop return; else + Maybe_In_Place_OK := False; Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); Tmp_Decl := Make_Object_Declaration @@ -3437,11 +3545,25 @@ package body Exp_Aggr is -- index checks because this code is guaranteed not to raise CE -- on index checks. However we should *not* suppress all checks. - Aggr_Code := - Build_Array_Aggr_Code (N, - Index => First_Index (Typ), - Into => New_Reference_To (Tmp, Loc), - Scalar_Comp => Is_Scalar_Type (Ctyp)); + declare + Target : Node_Id; + + begin + if Nkind (Tmp) = N_Defining_Identifier then + Target := New_Reference_To (Tmp, Loc); + + else + -- Name in assignment is explicit dereference. + + Target := New_Copy (Tmp); + end if; + + Aggr_Code := + Build_Array_Aggr_Code (N, + Index => First_Index (Typ), + Into => Target, + Scalar_Comp => Is_Scalar_Type (Ctyp)); + end; if Comes_From_Source (Tmp) then Insert_Actions_After (Parent (N), Aggr_Code); @@ -3450,12 +3572,13 @@ package body Exp_Aggr is Insert_Actions (N, Aggr_Code); end if; + -- If the aggregate has been assigned in place, remove the original + -- assignment. + if Nkind (Parent (N)) = N_Assignment_Statement - and then Is_Entity_Name (Name (Parent (N))) - and then Tmp = Entity (Name (Parent (N))) + and then Maybe_In_Place_OK then Rewrite (Parent (N), Make_Null_Statement (Loc)); - Analyze (N); elsif Nkind (Parent (N)) /= N_Object_Declaration or else Tmp /= Defining_Identifier (Parent (N)) @@ -3634,22 +3757,68 @@ package body Exp_Aggr is -- can be handled by gigi. else - if not Has_Discriminants (Typ) then - - -- This bizarre if/elsif is to avoid a compiler crash ??? + -- If no discriminants, nothing special to do + if not Has_Discriminants (Typ) then null; + -- Case of discriminants present + elsif Is_Derived_Type (Typ) then - -- Non-girder discriminants are replaced with girder discriminants + -- For untagged types, non-girder discriminants are replaced + -- with girder discriminants, which are the ones that gigi uses + -- to describe the type and its components. - declare + Generate_Aggregate_For_Derived_Type : declare First_Comp : Node_Id; Discriminant : Entity_Id; + Constraints : List_Id := New_List; + Decl : Node_Id; + Num_Disc : Int := 0; + Num_Gird : Int := 0; + + procedure Prepend_Girder_Values (T : Entity_Id); + -- Scan the list of girder discriminants of the type, and + -- add their values to the aggregate being built. + + --------------------------- + -- Prepend_Girder_Values -- + --------------------------- + + procedure Prepend_Girder_Values (T : Entity_Id) is + begin + Discriminant := First_Girder_Discriminant (T); + + while Present (Discriminant) loop + New_Comp := + Make_Component_Association (Loc, + Choices => + New_List (New_Occurrence_Of (Discriminant, Loc)), + + Expression => + New_Copy_Tree ( + Get_Discriminant_Value ( + Discriminant, + Typ, + Discriminant_Constraint (Typ)))); + + if No (First_Comp) then + Prepend_To (Component_Associations (N), New_Comp); + else + Insert_After (First_Comp, New_Comp); + end if; + + First_Comp := New_Comp; + Next_Girder_Discriminant (Discriminant); + end loop; + end Prepend_Girder_Values; + + -- Start of processing for Generate_Aggregate_For_Derived_Type begin - -- Remove all the discriminants + -- Remove the associations for the discriminant of + -- the derived type. First_Comp := First (Component_Associations (N)); @@ -3661,37 +3830,79 @@ package body Exp_Aggr is E_Discriminant then Remove (Comp); + Num_Disc := Num_Disc + 1; end if; end loop; - -- Insert girder discriminant associations - -- in the correct order + -- Insert girder discriminant associations in the correct + -- order. If there are more girder discriminants than new + -- discriminants, there is at least one new discriminant + -- that constrains more than one of the girders. In this + -- case we need to construct a proper subtype of the parent + -- type, in order to supply values to all the components. + -- Otherwise there is one-one correspondence between the + -- constraints and the girder discriminants. First_Comp := Empty; - Discriminant := First_Girder_Discriminant (Typ); - while Present (Discriminant) loop - New_Comp := - Make_Component_Association (Loc, - Choices => - New_List (New_Occurrence_Of (Discriminant, Loc)), - Expression => - New_Copy_Tree ( - Get_Discriminant_Value ( - Discriminant, - Typ, - Discriminant_Constraint (Typ)))); - - if No (First_Comp) then - Prepend_To (Component_Associations (N), New_Comp); - else - Insert_After (First_Comp, New_Comp); - end if; + Discriminant := First_Girder_Discriminant (Base_Type (Typ)); - First_Comp := New_Comp; + while Present (Discriminant) loop + Num_Gird := Num_Gird + 1; Next_Girder_Discriminant (Discriminant); end loop; - end; + + -- Case of more girder discriminants than new discriminants + + if Num_Gird > Num_Disc then + + -- Create a proper subtype of the parent type, which is + -- the proper implementation type for the aggregate, and + -- convert it to the intended target type. + + Discriminant := First_Girder_Discriminant (Base_Type (Typ)); + + while Present (Discriminant) loop + New_Comp := + New_Copy_Tree ( + Get_Discriminant_Value ( + Discriminant, + Typ, + Discriminant_Constraint (Typ))); + Append (New_Comp, Constraints); + Next_Girder_Discriminant (Discriminant); + end loop; + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('T')), + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Base_Type (Typ)), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint + (Loc, Constraints))); + + Insert_Action (N, Decl); + Prepend_Girder_Values (Base_Type (Typ)); + + Set_Etype (N, Defining_Identifier (Decl)); + Set_Analyzed (N); + + Rewrite (N, Unchecked_Convert_To (Typ, N)); + Analyze (N); + + -- Case where we do not have fewer new discriminants than + -- girder discriminants, so in this case we can simply + -- use the girder discriminants of the subtype. + + else + Prepend_Girder_Values (Typ); + end if; + end Generate_Aggregate_For_Derived_Type; end if; if Is_Tagged_Type (Typ) then @@ -3936,26 +4147,264 @@ package body Exp_Aggr is return Nb_Choices; end Number_Of_Choices; + ------------------------------------ + -- Packed_Array_Aggregate_Handled -- + ------------------------------------ + + -- The current version of this procedure will handle at compile time + -- any array aggregate that meets these conditions: + + -- One dimensional, bit packed + -- Underlying packed type is modular type + -- Bounds are within 32-bit Int range + -- All bounds and values are static + + function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Ctyp : constant Entity_Id := Component_Type (Typ); + + Not_Handled : exception; + -- Exception raised if this aggregate cannot be handled + + begin + -- For now, handle only one dimensional bit packed arrays + + if not Is_Bit_Packed_Array (Typ) + or else Number_Dimensions (Typ) > 1 + or else not Is_Modular_Integer_Type (Packed_Array_Type (Typ)) + then + return False; + end if; + + declare + Csiz : constant Nat := UI_To_Int (Component_Size (Typ)); + + Lo : Node_Id; + Hi : Node_Id; + -- Bounds of index type + + Lob : Uint; + Hib : Uint; + -- Values of bounds if compile time known + + function Get_Component_Val (N : Node_Id) return Uint; + -- Given a expression value N of the component type Ctyp, returns + -- A value of Csiz (component size) bits representing this value. + -- If the value is non-static or any other reason exists why the + -- value cannot be returned, then Not_Handled is raised. + + ----------------------- + -- Get_Component_Val -- + ----------------------- + + function Get_Component_Val (N : Node_Id) return Uint is + Val : Uint; + + begin + -- We have to analyze the expression here before doing any further + -- processing here. The analysis of such expressions is deferred + -- till expansion to prevent some problems of premature analysis. + + Analyze_And_Resolve (N, Ctyp); + + -- Must have a compile time value + + if not Compile_Time_Known_Value (N) then + raise Not_Handled; + end if; + + Val := Expr_Rep_Value (N); + + -- Adjust for bias, and strip proper number of bits + + if Has_Biased_Representation (Ctyp) then + Val := Val - Expr_Value (Type_Low_Bound (Ctyp)); + end if; + + return Val mod Uint_2 ** Csiz; + end Get_Component_Val; + + -- Here we know we have a one dimensional bit packed array + + begin + Get_Index_Bounds (First_Index (Typ), Lo, Hi); + + -- Cannot do anything if bounds are dynamic + + if not Compile_Time_Known_Value (Lo) + or else + not Compile_Time_Known_Value (Hi) + then + return False; + end if; + + -- Or are silly out of range of int bounds + + Lob := Expr_Value (Lo); + Hib := Expr_Value (Hi); + + if not UI_Is_In_Int_Range (Lob) + or else + not UI_Is_In_Int_Range (Hib) + then + return False; + end if; + + -- At this stage we have a suitable aggregate for handling + -- at compile time (the only remaining checks, are that the + -- values of expressions in the aggregate are compile time + -- known (check performed by Get_Component_Val), and that + -- any subtypes or ranges are statically known. + + -- If the aggregate is not fully positional at this stage, + -- then convert it to positional form. Either this will fail, + -- in which case we can do nothing, or it will succeed, in + -- which case we have succeeded in handling the aggregate, + -- or it will stay an aggregate, in which case we have failed + -- to handle this case. + + if Present (Component_Associations (N)) then + Convert_To_Positional + (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True); + return Nkind (N) /= N_Aggregate; + end if; + + -- Otherwise we are all positional, so convert to proper value + + declare + Lov : constant Nat := UI_To_Int (Lob); + Hiv : constant Nat := UI_To_Int (Hib); + + Len : constant Nat := Int'Max (0, Hiv - Lov + 1); + -- The length of the array (number of elements) + + Aggregate_Val : Uint; + -- Value of aggregate. The value is set in the low order + -- bits of this value. For the little-endian case, the + -- values are stored from low-order to high-order and + -- for the big-endian case the values are stored from + -- high-order to low-order. Note that gigi will take care + -- of the conversions to left justify the value in the big + -- endian case (because of left justified modular type + -- processing), so we do not have to worry about that here. + + Lit : Node_Id; + -- Integer literal for resulting constructed value + + Shift : Nat; + -- Shift count from low order for next value + + Incr : Int; + -- Shift increment for loop + + Expr : Node_Id; + -- Next expression from positional parameters of aggregate + + begin + -- For little endian, we fill up the low order bits of the + -- target value. For big endian we fill up the high order + -- bits of the target value (which is a left justified + -- modular value). + + if Bytes_Big_Endian xor Debug_Flag_8 then + Shift := Csiz * (Len - 1); + Incr := -Csiz; + else + Shift := 0; + Incr := +Csiz; + end if; + + -- Loop to set the values + + Aggregate_Val := Uint_0; + Expr := First (Expressions (N)); + for J in 1 .. Len loop + Aggregate_Val := + Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift; + Shift := Shift + Incr; + Next (Expr); + end loop; + + -- Now we can rewrite with the proper value + + Lit := + Make_Integer_Literal (Loc, + Intval => Aggregate_Val); + Set_Print_In_Hex (Lit); + + -- Construct the expression using this literal. Note that it is + -- important to qualify the literal with its proper modular type + -- since universal integer does not have the required range and + -- also this is a left justified modular type, which is important + -- in the big-endian case. + + Rewrite (N, + Unchecked_Convert_To (Typ, + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Packed_Array_Type (Typ), Loc), + Expression => Lit))); + + Analyze_And_Resolve (N, Typ); + return True; + end; + end; + + exception + when Not_Handled => + return False; + end Packed_Array_Aggregate_Handled; + + ------------------------------ + -- Initialize_Discriminants -- + ------------------------------ + + procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Bas : constant Entity_Id := Base_Type (Typ); + Par : constant Entity_Id := Etype (Bas); + Decl : constant Node_Id := Parent (Par); + Ref : Node_Id; + + begin + if Is_Tagged_Type (Bas) + and then Is_Derived_Type (Bas) + and then Has_Discriminants (Par) + and then Has_Discriminants (Bas) + and then Number_Discriminants (Bas) /= Number_Discriminants (Par) + and then Nkind (Decl) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Decl)) = N_Record_Definition + and then Present + (Variant_Part (Component_List (Type_Definition (Decl)))) + and then Nkind (N) /= N_Extension_Aggregate + then + + -- Call init_proc to set discriminants. + -- There should eventually be a special procedure for this ??? + + Ref := New_Reference_To (Defining_Identifier (N), Loc); + Insert_Actions_After (N, + Build_Initialization_Call (Sloc (N), Ref, Typ)); + end if; + end Initialize_Discriminants; + --------------------------- -- Safe_Slice_Assignment -- --------------------------- - function Safe_Slice_Assignment - (N : Node_Id; - Typ : Entity_Id) - return Boolean - is + function Safe_Slice_Assignment (N : Node_Id) return Boolean is Loc : constant Source_Ptr := Sloc (Parent (N)); Pref : constant Node_Id := Prefix (Name (Parent (N))); Range_Node : constant Node_Id := Discrete_Range (Name (Parent (N))); Expr : Node_Id; - L_I : Entity_Id; + L_J : Entity_Id; L_Iter : Node_Id; L_Body : Node_Id; Stat : Node_Id; begin - -- Generate: For J in Range loop Pref (I) := Expr; end loop; + -- Generate: for J in Range loop Pref (J) := Expr; end loop; if Comes_From_Source (N) and then No (Expressions (N)) @@ -3964,14 +4413,14 @@ package body Exp_Aggr is then Expr := Expression (First (Component_Associations (N))); - L_I := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); L_Iter := Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, - Defining_Identifier => L_I, + Defining_Identifier => L_J, Discrete_Subtype_Definition => Relocate_Node (Range_Node))); L_Body := @@ -3979,7 +4428,7 @@ package body Exp_Aggr is Name => Make_Indexed_Component (Loc, Prefix => Relocate_Node (Pref), - Expressions => New_List (New_Occurrence_Of (L_I, Loc))), + Expressions => New_List (New_Occurrence_Of (L_J, Loc))), Expression => Relocate_Node (Expr)); -- Construct the final loop diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 90aec3afe8d..417c15988c9 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -48,7 +48,6 @@ with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; -with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; @@ -452,7 +451,7 @@ package body Exp_Attr is declare Agg : Node_Id; Sub : Entity_Id; - E_T : constant Entity_Id := Equivalent_Type (Typ); + E_T : constant Entity_Id := Equivalent_Type (Btyp); Acc : constant Entity_Id := Etype (Next_Component (First_Component (E_T))); Obj_Ref : Node_Id; @@ -511,7 +510,7 @@ package body Exp_Attr is Rewrite (N, Agg); - Analyze_And_Resolve (N, Equivalent_Type (Typ)); + Analyze_And_Resolve (N, E_T); -- For subsequent analysis, the node must retain its type. -- The backend will replace it with the equivalent type where @@ -3761,8 +3760,6 @@ package body Exp_Attr is Attribute_Machine_Overflows | Attribute_Machine_Radix | Attribute_Machine_Rounds | - Attribute_Max_Interrupt_Priority | - Attribute_Max_Priority | Attribute_Maximum_Alignment | Attribute_Model_Emin | Attribute_Model_Epsilon | @@ -3780,7 +3777,6 @@ package body Exp_Attr is Attribute_Signed_Zeros | Attribute_Small | Attribute_Storage_Unit | - Attribute_Tick | Attribute_Type_Class | Attribute_Universal_Literal_String | Attribute_Wchar_T_Size | @@ -3836,7 +3832,8 @@ package body Exp_Attr is Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Base_Type (Etype (Prefix (N))), Loc), - Attribute_Name => Cnam)))); + Attribute_Name => Cnam)), + Reason => CE_Overflow_Check_Failed)); end Expand_Pred_Succ; @@ -3862,18 +3859,23 @@ package body Exp_Attr is -- If Typ is a derived type, it may inherit attributes from some -- ancestor which is not the ultimate underlying one. + -- If Typ is a derived tagged type, the corresponding primitive + -- operation has been created explicitly. if Is_Derived_Type (P_Type) then + if Is_Tagged_Type (P_Type) then + return Find_Prim_Op (P_Type, Nam); + else + while Is_Derived_Type (P_Type) loop + Proc := TSS (Base_Type (Etype (Typ)), Nam); - while Is_Derived_Type (P_Type) loop - Proc := TSS (Base_Type (Etype (Typ)), Nam); - - if Present (Proc) then - return Proc; - else - P_Type := Base_Type (Etype (P_Type)); - end if; - end loop; + if Present (Proc) then + return Proc; + else + P_Type := Base_Type (Etype (P_Type)); + end if; + end loop; + end if; end if; -- If nothing else, use the TSS of the root type. diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 22b9ccd02a6..70da08b331d 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -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. -- -- -- -- 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- -- @@ -30,6 +30,7 @@ with Atree; use Atree; with Casing; use Casing; with Debug; use Debug; with Einfo; use Einfo; +with Errout; use Errout; with Exp_Ch7; use Exp_Ch7; with Exp_Util; use Exp_Util; with Hostparm; use Hostparm; @@ -657,18 +658,32 @@ package body Exp_Ch11 is -- Routine to prepend a call to the procedure referenced by Proc at -- the start of the handler code for the current Handler. + ----------------------------- + -- Prepend_Call_To_Handler -- + ----------------------------- + procedure Prepend_Call_To_Handler (Proc : RE_Id; Args : List_Id := No_List) is - Call : constant Node_Id := - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (Proc), Loc), - Parameter_Associations => Args); + Ent : constant Entity_Id := RTE (Proc); begin - Prepend_To (Statements (Handler), Call); - Analyze (Call, Suppress => All_Checks); + -- If we have no Entity, then we are probably in no run time mode + -- or some weird error has occured. In either case do do nothing! + + if Present (Ent) then + declare + Call : constant Node_Id := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (Proc), Loc), + Parameter_Associations => Args); + + begin + Prepend_To (Statements (Handler), Call); + Analyze (Call, Suppress => All_Checks); + end; + end if; end Prepend_Call_To_Handler; -- Start of processing for Expand_Exception_Handlers @@ -934,7 +949,9 @@ package body Exp_Ch11 is procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is begin - if Present (Exception_Handlers (N)) then + if Present (Exception_Handlers (N)) + and then not Restrictions (No_Exception_Handlers) + then Expand_Exception_Handlers (N); end if; @@ -1007,18 +1024,24 @@ package body Exp_Ch11 is -- but this is also faster in all modes). if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then - if Entity (Name (N)) = Standard_Program_Error then - Rewrite (N, Make_Raise_Program_Error (Loc)); + if Entity (Name (N)) = Standard_Constraint_Error then + Rewrite (N, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Explicit_Raise)); Analyze (N); return; - elsif Entity (Name (N)) = Standard_Constraint_Error then - Rewrite (N, Make_Raise_Constraint_Error (Loc)); + elsif Entity (Name (N)) = Standard_Program_Error then + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Explicit_Raise)); Analyze (N); return; elsif Entity (Name (N)) = Standard_Storage_Error then - Rewrite (N, Make_Raise_Storage_Error (Loc)); + Rewrite (N, + Make_Raise_Storage_Error (Loc, + Reason => SE_Explicit_Raise)); Analyze (N); return; end if; @@ -1037,6 +1060,13 @@ package body Exp_Ch11 is begin Build_Location_String (Loc); + -- If the exception is a renaming, use the exception that it + -- renames (which might be a predefined exception, e.g.). + + if Present (Renamed_Object (Id)) then + Id := Renamed_Object (Id); + end if; + -- Build a C compatible string in case of no exception handlers, -- since this is what the last chance handler is expecting. @@ -1234,6 +1264,10 @@ package body Exp_Ch11 is return; end if; + if Restrictions (No_Exception_Handlers) then + return; + end if; + -- Suppress descriptor if we are not generating code. This happens -- in the case of a -gnatc -gnatt compilation where we force generics -- to be generated, but we still don't want exception tables. @@ -1583,6 +1617,20 @@ package body Exp_Ch11 is Adecl : Node_Id; begin + -- If N is empty with prior errors, ignore + + if Total_Errors_Detected /= 0 and then No (N) then + return; + end if; + + -- Do not generate if no exceptions + + if Restrictions (No_Exception_Handlers) then + return; + end if; + + -- Otherwise generate descriptor + Adecl := Aux_Decls_Node (Parent (N)); if No (Actions (Adecl)) then @@ -1600,16 +1648,34 @@ package body Exp_Ch11 is (N : Node_Id; Spec : Entity_Id) is - HSS : constant Node_Id := Handled_Statement_Sequence (N); - begin - if No (Exception_Handlers (HSS)) then - Generate_Subprogram_Descriptor - (N, Sloc (N), Spec, Statements (HSS)); - else - Generate_Subprogram_Descriptor - (N, Sloc (N), Spec, Statements (Last (Exception_Handlers (HSS)))); + -- If we have no subprogram body and prior errors, ignore + + if Total_Errors_Detected /= 0 and then No (N) then + return; + end if; + + -- Do not generate if no exceptions + + if Restrictions (No_Exception_Handlers) then + return; end if; + + -- Else generate descriptor + + declare + HSS : constant Node_Id := Handled_Statement_Sequence (N); + + begin + if No (Exception_Handlers (HSS)) then + Generate_Subprogram_Descriptor + (N, Sloc (N), Spec, Statements (HSS)); + else + Generate_Subprogram_Descriptor + (N, Sloc (N), + Spec, Statements (Last (Exception_Handlers (HSS)))); + end if; + end; end Generate_Subprogram_Descriptor_For_Subprogram; ----------------------------------- @@ -1635,6 +1701,12 @@ package body Exp_Ch11 is return; end if; + -- Nothing to do if no exceptions + + if Restrictions (No_Exception_Handlers) then + return; + end if; + -- Remove any entries from SD_List that correspond to eliminated -- subprograms. diff --git a/gcc/ada/exp_ch12.adb b/gcc/ada/exp_ch12.adb index fe1416f6761..6ecead18a47 100644 --- a/gcc/ada/exp_ch12.adb +++ b/gcc/ada/exp_ch12.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.7 $ +-- $Revision$ -- -- --- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2002 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -62,7 +62,8 @@ package body Exp_Ch12 is Condition => Make_Op_Not (Loc, Right_Opnd => - New_Occurrence_Of (Elaboration_Entity (Ent), Loc)))); + New_Occurrence_Of (Elaboration_Entity (Ent), Loc)), + Reason => PE_Access_Before_Elaboration)); end if; end Expand_N_Generic_Instantiation; diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index bbc8458eff5..b1e24128c0b 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -50,6 +50,11 @@ with Uintp; use Uintp; package body Exp_Ch13 is + procedure Expand_External_Tag_Definition (N : Node_Id); + -- The code to assign and register an external tag must be elaborated + -- after the dispatch table has been created, so the expansion of the + -- attribute definition node is delayed until after the type is frozen. + ------------------------------------------ -- Expand_N_Attribute_Definition_Clause -- ------------------------------------------ @@ -115,70 +120,6 @@ package body Exp_Ch13 is end if; ------------------ - -- External_Tag -- - ------------------ - - -- For the rep clause "for x'external_tag use y" generate: - - -- xV : constant string := y; - -- Set_External_Tag (x'tag, xV'Address); - -- Register_Tag (x'tag); - - -- note that register_tag has been delayed up to now because - -- the external_tag must be set before resistering. - - when Attribute_External_Tag => External_Tag : declare - E : Entity_Id; - Old_Val : String_Id := Strval (Expr_Value_S (Exp)); - New_Val : String_Id; - - begin - -- Create a new nul terminated string if it is not already - - if String_Length (Old_Val) > 0 - and then Get_String_Char (Old_Val, String_Length (Old_Val)) = 0 - then - New_Val := Old_Val; - else - Start_String (Old_Val); - Store_String_Char (Get_Char_Code (ASCII.NUL)); - New_Val := End_String; - end if; - - E := - Make_Defining_Identifier (Loc, - New_External_Name (Chars (Ent), 'A')); - - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => E, - Constant_Present => True, - Object_Definition => - New_Reference_To (Standard_String, Loc), - Expression => - Make_String_Literal (Loc, Strval => New_Val))); - - Insert_Actions (N, New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Tag, - Prefix => New_Occurrence_Of (Ent, Loc)), - - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Address, - Prefix => New_Occurrence_Of (E, Loc)))), - - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Register_Tag), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Tag, - Prefix => New_Occurrence_Of (Ent, Loc)))))); - end External_Tag; - - ------------------ -- Storage_Size -- ------------------ @@ -224,6 +165,76 @@ package body Exp_Ch13 is end Expand_N_Attribute_Definition_Clause; + ------------------------------------- + -- Expand_External_Tag_Definition -- + ------------------------------------- + + procedure Expand_External_Tag_Definition (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent : constant Entity_Id := Entity (Name (N)); + E : Entity_Id; + Old_Val : String_Id := Strval (Expr_Value_S (Expression (N))); + New_Val : String_Id; + + begin + + -- For the rep clause "for x'external_tag use y" generate: + + -- xV : constant string := y; + -- Set_External_Tag (x'tag, xV'Address); + -- Register_Tag (x'tag); + + -- note that register_tag has been delayed up to now because + -- the external_tag must be set before registering. + + -- Create a new nul terminated string if it is not already + + if String_Length (Old_Val) > 0 + and then Get_String_Char (Old_Val, String_Length (Old_Val)) = 0 + then + New_Val := Old_Val; + else + Start_String (Old_Val); + Store_String_Char (Get_Char_Code (ASCII.NUL)); + New_Val := End_String; + end if; + + E := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Ent), 'A')); + + -- The generated actions must be elaborated at the subsequent + -- freeze point, not at the point of the attribute definition. + + Append_Freeze_Action (Ent, + Make_Object_Declaration (Loc, + Defining_Identifier => E, + Constant_Present => True, + Object_Definition => + New_Reference_To (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, Strval => New_Val))); + + Append_Freeze_Actions (Ent, New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Tag, + Prefix => New_Occurrence_Of (Ent, Loc)), + + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => New_Occurrence_Of (E, Loc)))), + + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Register_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Tag, + Prefix => New_Occurrence_Of (Ent, Loc)))))); + end Expand_External_Tag_Definition; + ---------------------------- -- Expand_N_Freeze_Entity -- ---------------------------- @@ -309,6 +320,22 @@ package body Exp_Ch13 is if Is_Enumeration_Type (E) then Build_Enumeration_Image_Tables (E, N); + + elsif Is_Tagged_Type (E) + and then Is_First_Subtype (E) + then + + -- Check for a definition of External_Tag, whose expansion must + -- be delayed until the dispatch table is built. + + declare + Def : Node_Id := + Get_Attribute_Definition_Clause (E, Attribute_External_Tag); + begin + if Present (Def) then + Expand_External_Tag_Definition (Def); + end if; + end; end if; -- If subprogram, freeze the subprogram diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 8118f2e21d3..7460591d833 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -29,6 +29,7 @@ with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; +with Errout; use Errout; with Exp_Smem; use Exp_Smem; with Exp_Util; use Exp_Util; with Exp_VFpt; use Exp_VFpt; @@ -210,6 +211,12 @@ package body Exp_Ch2 is E : constant Entity_Id := Entity (N); begin + -- Defend against errors + + if No (E) and then Total_Errors_Detected /= 0 then + return; + end if; + if Ekind (E) = E_Discriminant then Expand_Discriminant (N); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 22d84263da1..7a39b4c9380 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -30,6 +30,7 @@ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; with Elists; use Elists; +with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Ch4; use Exp_Ch4; with Exp_Ch7; use Exp_Ch7; @@ -118,6 +119,11 @@ package body Exp_Ch3 is -- Create An Equality function for the non-tagged variant record 'Typ' -- and attach it to the TSS list + procedure Check_Stream_Attributes (Typ : Entity_Id); + -- Check that if a limited extension has a parent with user-defined + -- stream attributes, any limited component of the extension also has + -- the corresponding user-defined stream attributes. + procedure Expand_Tagged_Root (T : Entity_Id); -- Add a field _Tag at the beginning of the record. This field carries -- the value of the access to the Dispatch table. This procedure is only @@ -147,6 +153,10 @@ package body Exp_Ch3 is -- applies only to E_Record_Type entities, not to class wide types, -- record subtypes, or private types. + procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id); + -- Treat user-defined stream operations as renaming_as_body if the + -- subprogram they rename is not frozen when the type is frozen. + function Init_Formals (Typ : Entity_Id) return List_Id; -- This function builds the list of formals for an initialization routine. -- The first formal is always _Init with the given type. For task value @@ -561,7 +571,6 @@ package body Exp_Ch3 is Set_Ekind (Proc_Id, E_Procedure); Set_Is_Public (Proc_Id, Is_Public (A_Type)); - Set_Is_Inlined (Proc_Id); Set_Is_Internal (Proc_Id); Set_Has_Completion (Proc_Id); @@ -569,6 +578,17 @@ package body Exp_Ch3 is Set_Debug_Info_Off (Proc_Id); end if; + -- Set inlined unless controlled stuff or tasks around, in which + -- case we do not want to inline, because nested stuff may cause + -- difficulties in interunit inlining, and furthermore there is + -- in any case no point in inlining such complex init procs. + + if not Has_Task (Proc_Id) + and then not Controlled_Type (Proc_Id) + then + Set_Is_Inlined (Proc_Id); + end if; + -- Associate Init_Proc with type, and determine if the procedure -- is null (happens because of the Initialize_Scalars pragma case, -- where we have to generate a null procedure in case it is called @@ -1325,14 +1345,10 @@ package body Exp_Ch3 is -- of the initialization procedure (by calling all the preceding -- auxiliary routines), and install it as the _init TSS. - procedure Build_Record_Checks - (S : Node_Id; - Related_Nod : Node_Id; - Check_List : List_Id); + procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); -- Add range checks to components of disciminated records. S is a - -- subtype indication of a record component. Related_Nod is passed - -- for compatibility with Process_Range_Expr_In_Decl. Check_List is - -- a list to which the check actions are appended. + -- subtype indication of a record component. Check_List is a list + -- to which the check actions are appended. function Component_Needs_Simple_Initialization (T : Entity_Id) @@ -1345,20 +1361,17 @@ package body Exp_Ch3 is -- initialized by other means. procedure Constrain_Array - (SI : Node_Id; - Related_Nod : Node_Id; - Check_List : List_Id); + (SI : Node_Id; + Check_List : List_Id); -- Called from Build_Record_Checks. -- Apply a list of index constraints to an unconstrained array type. -- The first parameter is the entity for the resulting subtype. - -- Related_Nod is passed for compatibility with Process_Range_Expr_In_ - -- Decl. Check_List is a list to which the check actions are appended. + -- Check_List is a list to which the check actions are appended. procedure Constrain_Index - (Index : Node_Id; - S : Node_Id; - Related_Nod : Node_Id; - Check_List : List_Id); + (Index : Node_Id; + S : Node_Id; + Check_List : List_Id); -- Called from Build_Record_Checks. -- Process an index constraint in a constrained array declaration. -- The constraint can be a subtype name, or a range with or without @@ -1864,10 +1877,7 @@ package body Exp_Ch3 is Decl := First_Non_Pragma (Component_Items (Comp_List)); while Present (Decl) loop Loc := Sloc (Decl); - Build_Record_Checks - (Subtype_Indication (Decl), - Decl, - Check_List); + Build_Record_Checks (Subtype_Indication (Decl), Check_List); Id := Defining_Identifier (Decl); Typ := Etype (Id); @@ -2065,15 +2075,11 @@ package body Exp_Ch3 is -- Build_Record_Checks -- ------------------------- - procedure Build_Record_Checks - (S : Node_Id; - Related_Nod : Node_Id; - Check_List : List_Id) - is + procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is P : Node_Id; Subtype_Mark_Id : Entity_Id; - begin + begin if Nkind (S) = N_Subtype_Indication then Find_Type (Subtype_Mark (S)); P := Parent (S); @@ -2084,13 +2090,12 @@ package body Exp_Ch3 is case Ekind (Subtype_Mark_Id) is when Array_Kind => - Constrain_Array (S, Related_Nod, Check_List); + Constrain_Array (S, Check_List); when others => null; end case; end if; - end Build_Record_Checks; ------------------------------------------- @@ -2114,7 +2119,6 @@ package body Exp_Ch3 is procedure Constrain_Array (SI : Node_Id; - Related_Nod : Node_Id; Check_List : List_Id) is C : constant Node_Id := Constraint (SI); @@ -2148,7 +2152,7 @@ package body Exp_Ch3 is -- Apply constraints to each index type for J in 1 .. Number_Of_Constraints loop - Constrain_Index (Index, S, Related_Nod, Check_List); + Constrain_Index (Index, S, Check_List); Next (Index); Next (S); end loop; @@ -2162,14 +2166,13 @@ package body Exp_Ch3 is procedure Constrain_Index (Index : Node_Id; S : Node_Id; - Related_Nod : Node_Id; Check_List : List_Id) is T : constant Entity_Id := Etype (Index); begin if Nkind (S) = N_Range then - Process_Range_Expr_In_Decl (S, T, Related_Nod, Check_List); + Process_Range_Expr_In_Decl (S, T, Check_List); end if; end Constrain_Index; @@ -2376,8 +2379,10 @@ package body Exp_Ch3 is -- yet. The initialization of controlled records contains a nested -- clean-up procedure that makes it impractical to inline as well, -- and leads to undefined symbols if inlined in a different unit. + -- Similar considerations apply to task types. - if not Is_Protected_Record_Type (Rec_Type) + if not Is_Concurrent_Type (Rec_Type) + and then not Has_Task (Rec_Type) and then not Controlled_Type (Rec_Type) then Set_Is_Inlined (Proc_Id); @@ -2482,8 +2487,8 @@ package body Exp_Ch3 is if Has_Unchecked_Union (Typ) then Append_To (Stmts, - Make_Raise_Program_Error (Loc)); - + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); else Append_To (Stmts, Make_Eq_If (Typ, @@ -2504,6 +2509,41 @@ package body Exp_Ch3 is end if; end Build_Variant_Record_Equality; + ----------------------------- + -- Check_Stream_Attributes -- + ----------------------------- + + procedure Check_Stream_Attributes (Typ : Entity_Id) is + Comp : Entity_Id; + Par : constant Entity_Id := Root_Type (Base_Type (Typ)); + Par_Read : Boolean := Present (TSS (Par, Name_uRead)); + Par_Write : Boolean := Present (TSS (Par, Name_uWrite)); + + begin + if Par_Read or else Par_Write then + Comp := First_Component (Typ); + while Present (Comp) loop + if Comes_From_Source (Comp) + and then Original_Record_Component (Comp) = Comp + and then Is_Limited_Type (Etype (Comp)) + then + if (Par_Read and then + No (TSS (Base_Type (Etype (Comp)), Name_uRead))) + or else + (Par_Write and then + No (TSS (Base_Type (Etype (Comp)), Name_uWrite))) + then + Error_Msg_N + ("|component must have Stream attribute", + Parent (Comp)); + end if; + end if; + + Next_Component (Comp); + end loop; + end if; + end Check_Stream_Attributes; + --------------------------- -- Expand_Derived_Record -- --------------------------- @@ -2679,7 +2719,7 @@ package body Exp_Ch3 is end if; elsif Has_Task (Def_Id) then - Expand_Previous_Access_Type (N, Def_Id); + Expand_Previous_Access_Type (Def_Id); end if; Par_Id := Etype (B_Id); @@ -2757,10 +2797,19 @@ package body Exp_Ch3 is Expr_Q : Node_Id; begin + -- If we have a task type in no run time mode, then complain and ignore + + if No_Run_Time + and then not Restricted_Profile + and then Is_Task_Type (Typ) + then + Disallow_In_No_Run_Time_Mode (N); + return; + -- Don't do anything for deferred constants. All proper actions will -- be expanded during the redeclaration. - if No (Expr) and Constant_Present (N) then + elsif No (Expr) and Constant_Present (N) then return; end if; @@ -2870,6 +2919,14 @@ package body Exp_Ch3 is Insert_Actions_After (N, Build_Initialization_Call (Loc, Id_Ref, Typ)); + -- The initialization call may well set Not_Source_Assigned + -- to False, because it looks like an modification, but the + -- proper criterion is whether or not the type is at least + -- partially initialized, so reset the flag appropriately. + + Set_Not_Source_Assigned + (Def_Id, not Is_Partially_Initialized_Type (Typ)); + -- If simple initialization is required, then set an appropriate -- simple initialization expression in place. This special -- initialization is required even though No_Init_Flag is present. @@ -3076,7 +3133,7 @@ package body Exp_Ch3 is -- Expand_Previous_Access_Type -- --------------------------------- - procedure Expand_Previous_Access_Type (N : Node_Id; Def_Id : Entity_Id) is + procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is T : Entity_Id := First_Entity (Current_Scope); begin @@ -3456,7 +3513,8 @@ package body Exp_Ch3 is Discrete_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List ( Make_Raise_Program_Error (Loc, - Condition => Make_Identifier (Loc, Name_uF)), + Condition => Make_Identifier (Loc, Name_uF), + Reason => PE_Invalid_Data), Make_Return_Statement (Loc, Expression => Make_Integer_Literal (Loc, -1))))); @@ -3568,6 +3626,13 @@ package body Exp_Ch3 is end; end if; + if Is_Derived_Type (Def_Id) + and then Is_Limited_Type (Def_Id) + and then Is_Tagged_Type (Def_Id) + then + Check_Stream_Attributes (Def_Id); + end if; + -- Update task and controlled component flags, because some of the -- component types may have been private at the point of the record -- declaration. @@ -3760,6 +3825,40 @@ package body Exp_Ch3 is end Freeze_Record_Type; + ------------------------------ + -- Freeze_Stream_Operations -- + ------------------------------ + + procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is + Names : constant array (1 .. 4) of Name_Id := + (Name_uInput, Name_uOutput, Name_uRead, Name_uWrite); + Stream_Op : Entity_Id; + + begin + -- Primitive operations of tagged types are frozen when the dispatch + -- table is constructed. + + if not Comes_From_Source (Typ) + or else Is_Tagged_Type (Typ) + then + return; + end if; + + for J in Names'Range loop + Stream_Op := TSS (Typ, Names (J)); + + if Present (Stream_Op) + and then Is_Subprogram (Stream_Op) + and then Nkind (Unit_Declaration_Node (Stream_Op)) = + N_Subprogram_Declaration + and then not Is_Frozen (Stream_Op) + then + Append_Freeze_Actions + (Typ, Freeze_Entity (Stream_Op, Sloc (N))); + end if; + end loop; + end Freeze_Stream_Operations; + ----------------- -- Freeze_Type -- ----------------- @@ -3974,7 +4073,6 @@ package body Exp_Ch3 is -- Third discriminant is the alignment DT_Align))))); - end; Set_Associated_Storage_Pool (Def_Id, Pool_Object); @@ -3990,7 +4088,6 @@ package body Exp_Ch3 is -- when analyzing the rep. clause null; - end if; -- For access-to-controlled types (including class-wide types @@ -4078,6 +4175,8 @@ package body Exp_Ch3 is -- the freeze nodes are there for use by Gigi. end if; + + Freeze_Stream_Operations (N, Def_Id); end Freeze_Type; ------------------------- @@ -4095,9 +4194,34 @@ package body Exp_Ch3 is Val_RE : RE_Id; begin + -- For a private type, we should always have an underlying type + -- (because this was already checked in Needs_Simple_Initialization). + -- What we do is to get the value for the underlying type and then + -- do an Unchecked_Convert to the private type. + + if Is_Private_Type (T) then + Val := Get_Simple_Init_Val (Underlying_Type (T), Loc); + + -- A special case, if the underlying value is null, then qualify + -- it with the underlying type, so that the null is properly typed + -- Similarly, if it is an aggregate it must be qualified, because + -- an unchecked conversion does not provide a context for it. + + if Nkind (Val) = N_Null + or else Nkind (Val) = N_Aggregate + then + Val := + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Underlying_Type (T), Loc), + Expression => Val); + end if; + + return Unchecked_Convert_To (T, Val); + -- For scalars, we must have normalize/initialize scalars case - if Is_Scalar_Type (T) then + elsif Is_Scalar_Type (T) then pragma Assert (Init_Or_Norm_Scalars); -- Processing for Normalize_Scalars case @@ -4248,33 +4372,12 @@ package body Exp_Ch3 is return Nod; end; - -- Otherwise we have a case of a private type whose underlying type - -- needs simple initialization. In this case, we get the value for - -- the underlying type, then unchecked convert to the private type. + -- No other possibilities should arise, since we should only be + -- calling Get_Simple_Init_Val if Needs_Simple_Initialization + -- returned True, indicating one of the above cases held. else - pragma Assert - (Is_Private_Type (T) - and then Present (Underlying_Type (T))); - - Val := Get_Simple_Init_Val (Underlying_Type (T), Loc); - - -- A special case, if the underlying value is null, then qualify - -- it with the underlying type, so that the null is properly typed - -- Similarly, if it is an aggregate it must be qualified, because - -- an unchecked conversion does not provide a context for it. - - if Nkind (Val) = N_Null - or else Nkind (Val) = N_Aggregate - then - Val := - Make_Qualified_Expression (Loc, - Subtype_Mark => - New_Occurrence_Of (Underlying_Type (T), Loc), - Expression => Val); - end if; - - return Unchecked_Convert_To (T, Val); + raise Program_Error; end if; end Get_Simple_Init_Val; @@ -4718,11 +4821,26 @@ package body Exp_Ch3 is function Needs_Simple_Initialization (T : Entity_Id) return Boolean is begin + -- Check for private type, in which case test applies to the + -- underlying type of the private type. + + if Is_Private_Type (T) then + declare + RT : constant Entity_Id := Underlying_Type (T); + + begin + if Present (RT) then + return Needs_Simple_Initialization (RT); + else + return False; + end if; + end; + -- Cases needing simple initialization are access types, and, if pragma -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar -- types. - if Is_Access_Type (T) + elsif Is_Access_Type (T) or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T))) or else (Is_Bit_Packed_Array (T) @@ -4745,21 +4863,6 @@ package body Exp_Ch3 is then return True; - -- Check for private type, in which case test applies to the - -- underlying type of the private type. - - elsif Is_Private_Type (T) then - declare - RT : constant Entity_Id := Underlying_Type (T); - - begin - if Present (RT) then - return Needs_Simple_Initialization (RT); - else - return False; - end if; - end; - else return False; end if; diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index ff65667b8e5..915b0c241a3 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.36 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -38,8 +38,8 @@ package Exp_Ch3 is procedure Expand_N_Variant_Part (N : Node_Id); procedure Expand_N_Full_Type_Declaration (N : Node_Id); - procedure Expand_Previous_Access_Type (N : Node_Id; Def_Id : Entity_Id); - -- For a full type declaration that contains tasks, or that is a task, + procedure Expand_Previous_Access_Type (Def_Id : Entity_Id); + -- For a full type declaration that contains tasks, or that is a task, -- check whether there exists an access type whose designated type is an -- incomplete declarations for the current composite type. If so, build -- the master for that access type, now that it is known to denote an diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 111a17e9670..1d2bd7f7089 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.3 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -46,6 +46,7 @@ with Inline; use Inline; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; +with Restrict; use Restrict; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Cat; use Sem_Cat; @@ -54,10 +55,12 @@ with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Sinfo.CN; use Sinfo.CN; with Snames; use Snames; with Stand; use Stand; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; @@ -1298,11 +1301,11 @@ package body Exp_Ch4 is end if; -- If we have anything other than Standard_Character or - -- Standard_String, then we must have had an error earlier. - -- So we just abandon the attempt at expansion. + -- Standard_String, then we must have had a serious error + -- earlier, so we just abandon the attempt at expansion. else - pragma Assert (Errors_Detected > 0); + pragma Assert (Serious_Errors_Detected > 0); return; end if; @@ -1649,10 +1652,9 @@ package body Exp_Ch4 is if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then - -- Propagate constraint_error to enclosing allocator. + -- Propagate constraint_error to enclosing allocator - Rewrite - (Exp, New_Copy (Expression (Exp))); + Rewrite (Exp, New_Copy (Expression (Exp))); end if; else -- First check against the type of the qualified expression @@ -2572,7 +2574,7 @@ package body Exp_Ch4 is -- Deal with software overflow checking - if Software_Overflow_Checking + if not Backend_Overflow_Checks_On_Target and then Is_Signed_Integer_Type (Etype (N)) and then Do_Overflow_Check (N) then @@ -3069,6 +3071,7 @@ package body Exp_Ch4 is Typ : constant Entity_Id := Etype (N); Rtyp : constant Entity_Id := Root_Type (Typ); Base : constant Node_Id := Relocate_Node (Left_Opnd (N)); + Bastyp : constant Node_Id := Etype (Base); Exp : constant Node_Id := Relocate_Node (Right_Opnd (N)); Exptyp : constant Entity_Id := Etype (Exp); Ovflo : constant Boolean := Do_Overflow_Check (N); @@ -3081,6 +3084,36 @@ package body Exp_Ch4 is begin Binary_Op_Validity_Checks (N); + -- If either operand is of a private type, then we have the use of + -- an intrinsic operator, and we get rid of the privateness, by using + -- root types of underlying types for the actual operation. Otherwise + -- the private types will cause trouble if we expand multiplications + -- or shifts etc. We also do this transformation if the result type + -- is different from the base type. + + if Is_Private_Type (Etype (Base)) + or else + Is_Private_Type (Typ) + or else + Is_Private_Type (Exptyp) + or else + Rtyp /= Root_Type (Bastyp) + then + declare + Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp)); + Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp)); + + begin + Rewrite (N, + Unchecked_Convert_To (Typ, + Make_Op_Expon (Loc, + Left_Opnd => Unchecked_Convert_To (Bt, Base), + Right_Opnd => Unchecked_Convert_To (Et, Exp)))); + Analyze_And_Resolve (N, Typ); + return; + end; + end if; + -- At this point the exponentiation must be dynamic since the static -- case has already been folded after Resolve by Eval_Op_Expon. @@ -3201,9 +3234,14 @@ package body Exp_Ch4 is end; end if; - -- Fall through if exponentiation must be done using a runtime routine. + -- Fall through if exponentiation must be done using a runtime routine + + if No_Run_Time then + Disallow_In_No_Run_Time_Mode (N); + return; + end if; - -- First deal with modular case. + -- First deal with modular case if Is_Modular_Integer_Type (Rtyp) then @@ -3496,7 +3534,7 @@ package body Exp_Ch4 is begin Unary_Op_Validity_Checks (N); - if Software_Overflow_Checking + if not Backend_Overflow_Checks_On_Target and then Is_Signed_Integer_Type (Etype (N)) and then Do_Overflow_Check (N) then @@ -4738,25 +4776,26 @@ package body Exp_Ch4 is Expression => Conv), Make_Raise_Constraint_Error (Loc, - Condition => - Make_Or_Else (Loc, - Left_Opnd => - Make_Op_Lt (Loc, - Left_Opnd => New_Occurrence_Of (Tnn, Loc), - Right_Opnd => - Make_Attribute_Reference (Loc, - Attribute_Name => Name_First, - Prefix => - New_Occurrence_Of (Target_Type, Loc))), + Condition => + Make_Or_Else (Loc, + Left_Opnd => + Make_Op_Lt (Loc, + Left_Opnd => New_Occurrence_Of (Tnn, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => + New_Occurrence_Of (Target_Type, Loc))), - Right_Opnd => - Make_Op_Gt (Loc, - Left_Opnd => New_Occurrence_Of (Tnn, Loc), - Right_Opnd => - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Last, - Prefix => - New_Occurrence_Of (Target_Type, Loc))))))); + Right_Opnd => + Make_Op_Gt (Loc, + Left_Opnd => New_Occurrence_Of (Tnn, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => + New_Occurrence_Of (Target_Type, Loc)))), + Reason => CE_Range_Check_Failed))); Rewrite (N, New_Occurrence_Of (Tnn, Loc)); Analyze_And_Resolve (N, Btyp); @@ -4826,10 +4865,12 @@ package body Exp_Ch4 is -- cases. elsif In_Instance_Body - and then Type_Access_Level (Operand_Type) - > Type_Access_Level (Target_Type) + and then Type_Access_Level (Operand_Type) > + Type_Access_Level (Target_Type) then - Rewrite (N, Make_Raise_Program_Error (Sloc (N))); + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Accessibility_Check_Failed)); Set_Etype (N, Target_Type); -- When the operand is a selected access discriminant @@ -4845,7 +4886,9 @@ package body Exp_Ch4 is and then Object_Access_Level (Operand) > Type_Access_Level (Target_Type) then - Rewrite (N, Make_Raise_Program_Error (Sloc (N))); + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Accessibility_Check_Failed)); Set_Etype (N, Target_Type); end if; end if; @@ -4936,7 +4979,8 @@ package body Exp_Ch4 is Insert_Action (N, Make_Raise_Constraint_Error (Loc, - Condition => Cond)); + Condition => Cond, + Reason => CE_Tag_Check_Failed)); Change_Conversion_To_Unchecked (N); Analyze_And_Resolve (N, Target_Type); @@ -5310,13 +5354,16 @@ package body Exp_Ch4 is -- statement directly. if No (Parent (Lhs)) then - Result := Make_Raise_Program_Error (Loc); + Result := + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction); Set_Etype (Result, Standard_Boolean); return Result; else Insert_Action (Lhs, - Make_Raise_Program_Error (Loc)); + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); return New_Occurrence_Of (Standard_True, Loc); end if; end if; @@ -5919,11 +5966,13 @@ package body Exp_Ch4 is Rewrite (N, Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N)))); Analyze_And_Resolve (N, Typ); + Warn_On_Known_Condition (N); elsif False_Result then Rewrite (N, Convert_To (Typ, New_Occurrence_Of (Standard_False, Sloc (N)))); Analyze_And_Resolve (N, Typ); + Warn_On_Known_Condition (N); end if; end Rewrite_Comparison; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 110249f0c16..509738929aa 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.3 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -311,12 +311,6 @@ package body Exp_Ch5 is -- Note: overlap is never possible if there is a change of -- representation, so we can exclude this case - -- In the case of compiling for the Java Virtual Machine, - -- slices are always passed by making a copy, so we don't - -- have to worry about overlap. We also want to prevent - -- generation of "<" comparisons for array addresses, - -- since that's a meaningless operation on the JVM. - if Ndim = 1 and then not Crep and then @@ -325,6 +319,13 @@ package body Exp_Ch5 is (Lhs_Formal and Rhs_Non_Local_Var) or else (Rhs_Formal and Lhs_Non_Local_Var)) + + -- In the case of compiling for the Java Virtual Machine, + -- slices are always passed by making a copy, so we don't + -- have to worry about overlap. We also want to prevent + -- generation of "<" comparisons for array addresses, + -- since that's a meaningless operation on the JVM. + and then not Java_VM then Set_Forwards_OK (N, False); @@ -352,15 +353,24 @@ package body Exp_Ch5 is elsif Has_Controlled_Component (L_Type) then Loop_Required := True; - -- The only remaining cases involve slice assignments. If no slices - -- are involved, then the assignment can definitely be handled by gigi. - -- unless we have the parameter case mentioned above. + -- Case where no slice is involved elsif not L_Slice and not R_Slice then - -- The following is temporary code??? It is not clear why it is - -- necessary. For further investigation, look at the following - -- short program which fails: + -- The following code deals with the case of unconstrained bit + -- packed arrays. The problem is that the template for such + -- arrays contains the bounds of the actual source level array, + + -- But the copy of an entire array requires the bounds of the + -- underlying array. It would be nice if the back end could take + -- care of this, but right now it does not know how, so if we + -- have such a type, then we expand out into a loop, which is + -- inefficient but works correctly. If we don't do this, we + -- get the wrong length computed for the array to be moved. + -- The two cases we need to worry about are: + + -- Explicit deference of an unconstrained packed array type as + -- in the following example: -- procedure C52 is -- type BITS is array(INTEGER range <>) of BOOLEAN; @@ -373,22 +383,45 @@ package body Exp_Ch5 is -- P2.ALL := P1.ALL; -- end C52; - -- To deal with the above, we expand out if either of the operands - -- is an explicit dereference to an unconstrained bit packed array. + -- A formal parameter reference with an unconstrained bit + -- array type is the other case we need to worry about (here + -- we assume the same BITS type declared above: + + -- procedure Write_All (File : out BITS; Contents : in BITS); + -- begin + -- File.Storage := Contents; + -- end Write_All; + + -- We expand to a loop in either of these two cases. + + -- Question for future thought. Another potentially more efficient + -- approach would be to create the actual subtype, and then do an + -- unchecked conversion to this actual subtype ??? - Temporary_Code : declare - function Is_Deref_Of_UBP (Opnd : Node_Id) return Boolean; - -- Function to perform required test for special case above + Check_Unconstrained_Bit_Packed_Array : declare - function Is_Deref_Of_UBP (Opnd : Node_Id) return Boolean is + function Is_UBPA_Reference (Opnd : Node_Id) return Boolean; + -- Function to perform required test for the first case, + -- above (dereference of an unconstrained bit packed array) + + ----------------------- + -- Is_UBPA_Reference -- + ----------------------- + + function Is_UBPA_Reference (Opnd : Node_Id) return Boolean is + Typ : constant Entity_Id := Underlying_Type (Etype (Opnd)); P_Type : Entity_Id; Des_Type : Entity_Id; begin - if Nkind (Opnd) /= N_Explicit_Dereference then - return False; - else - P_Type := Etype (Prefix (Opnd)); + if Present (Packed_Array_Type (Typ)) + and then Is_Array_Type (Packed_Array_Type (Typ)) + and then not Is_Constrained (Packed_Array_Type (Typ)) + then + return True; + + elsif Nkind (Opnd) = N_Explicit_Dereference then + P_Type := Underlying_Type (Etype (Prefix (Opnd))); if not Is_Access_Type (P_Type) then return False; @@ -399,24 +432,32 @@ package body Exp_Ch5 is Is_Bit_Packed_Array (Des_Type) and then not Is_Constrained (Des_Type); end if; + + else + return False; end if; - end Is_Deref_Of_UBP; + end Is_UBPA_Reference; - -- Start of processing for temporary code + -- Start of processing for Check_Unconstrained_Bit_Packed_Array begin - if Is_Deref_Of_UBP (Lhs) + if Is_UBPA_Reference (Lhs) or else - Is_Deref_Of_UBP (Rhs) + Is_UBPA_Reference (Rhs) then Loop_Required := True; - -- Normal case (will be only case when above temp code removed ??? + -- Here if we do not have the case of a reference to a bit + -- packed unconstrained array case. In this case gigi can + -- most certainly handle the assignment if a forwards move + -- is allowed. + + -- (could it handle the backwards case also???) elsif Forwards_OK (N) then return; end if; - end Temporary_Code; + end Check_Unconstrained_Bit_Packed_Array; -- Gigi can always handle the assignment if the right side is a string -- literal (note that overlap is definitely impossible in this case). @@ -1498,7 +1539,10 @@ package body Exp_Ch5 is Exception_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List ( - Make_Raise_Program_Error (Loc))))))); + Make_Raise_Program_Error (Loc, + Reason => + PE_Finalize_Raised_Exception) + )))))); end if; end if; @@ -2378,7 +2422,8 @@ package body Exp_Ch5 is Right_Opnd => Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To - (Access_Disp_Table (Base_Type (Utyp)), Loc))))); + (Access_Disp_Table (Base_Type (Utyp)), Loc))), + Reason => CE_Tag_Check_Failed)); -- If the result type is a specific nonlimited tagged type, -- then we have to ensure that the tag of the result is that @@ -2716,13 +2761,6 @@ package body Exp_Ch5 is and then No_Initialization (Parent (Entity (Expression (L)))) then null; - - elsif Nkind (L) = N_Indexed_Component - and then Is_Entity_Name (Original_Node (Prefix (L))) - and then Is_Entry_Formal (Entity (Original_Node (Prefix (L)))) - then - null; - else Append_List_To (Res, Make_Final_Call ( diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d58b01cd231..cbe6df63f98 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.3 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -464,7 +464,8 @@ package body Exp_Ch6 is Make_If_Statement (Loc, Condition => Test, Then_Statements => New_List ( - Make_Raise_Storage_Error (Loc)), + Make_Raise_Storage_Error (Loc, + Reason => SE_Infinite_Recursion)), Else_Statements => New_List ( Relocate_Node (Node (Call))))); @@ -1208,6 +1209,12 @@ package body Exp_Ch6 is -- Start of processing for Expand_Call begin + -- Ignore if previous error + + if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then + return; + end if; + -- Call using access to subprogram with explicit dereference if Nkind (Name (N)) = N_Explicit_Dereference then @@ -1474,7 +1481,10 @@ package body Exp_Ch6 is Make_Op_Eq (Loc, Left_Opnd => Duplicate_Subexpr (Prev), Right_Opnd => Make_Null (Loc)); - Insert_Action (Prev, Make_Raise_Constraint_Error (Loc, Cond)); + Insert_Action (Prev, + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Access_Parameter_Is_Null)); end if; -- Perform appropriate validity checks on parameters @@ -1678,6 +1688,7 @@ package body Exp_Ch6 is if Etype (Formal) /= Etype (Parent_Formal) and then Is_Scalar_Type (Etype (Formal)) and then Ekind (Formal) = E_In_Parameter + and then not Raises_Constraint_Error (Actual) then Rewrite (Actual, OK_Convert_To (Etype (Parent_Formal), @@ -2169,7 +2180,9 @@ package body Exp_Ch6 is -- use a qualified expression, because an aggregate is not a -- legal argument of a conversion. - if Nkind (Expression (N)) = N_Aggregate then + if Nkind (Expression (N)) = N_Aggregate + or else Nkind (Expression (N)) = N_Null + then Ret := Make_Qualified_Expression (Sloc (N), Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), @@ -2876,7 +2889,8 @@ package body Exp_Ch6 is Make_Block_Statement (Hloc, Handled_Statement_Sequence => H); Rais : constant Node_Id := - Make_Raise_Program_Error (Hloc); + Make_Raise_Program_Error (Hloc, + Reason => PE_Missing_Return); begin Set_Handled_Statement_Sequence (N, @@ -2912,7 +2926,7 @@ package body Exp_Ch6 is if Present (Next_Op) then Dec := Parent (Base_Type (Scop)); Set_Privals (Dec, Next_Op, Loc); - Set_Discriminals (Dec, Next_Op, Loc); + Set_Discriminals (Dec); end if; end if; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 0e13169789e..74225b4f371 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -380,22 +380,56 @@ package body Exp_Ch7 is ---------------------- procedure Build_Final_List (N : Node_Id; Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; begin Set_Associated_Final_Chain (Typ, Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'L'))); - Insert_Action (N, + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Associated_Final_Chain (Typ), Object_Definition => New_Reference_To - (RTE (RE_List_Controller), Loc))); + (RTE (RE_List_Controller), Loc)); + + -- The type may have been frozen already, and this is a late + -- freezing action, in which case the declaration must be elaborated + -- at once. If the call is for an allocator, the chain must also be + -- created now, because the freezing of the type does not build one. + -- Otherwise, the declaration is one of the freezing actions for a + -- user-defined type. + + if Is_Frozen (Typ) + or else (Nkind (N) = N_Allocator + and then Ekind (Etype (N)) = E_Anonymous_Access_Type) + then + Insert_Action (N, Decl); + else + Append_Freeze_Action (Typ, Decl); + end if; end Build_Final_List; + --------------------- + -- Build_Late_Proc -- + --------------------- + + procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is + begin + for Final_Prim in Name_Of'Range loop + if Name_Of (Final_Prim) = Nam then + Set_TSS (Typ, + Make_Deep_Proc ( + Prim => Final_Prim, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Final_Prim, Typ))); + end if; + end loop; + end Build_Late_Proc; + ----------------------------- -- Build_Record_Deep_Procs -- ----------------------------- @@ -428,18 +462,65 @@ package body Exp_Ch7 is --------------------- function Controlled_Type (T : Entity_Id) return Boolean is + + function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; + -- If type is not frozen yet, check explicitly among its components, + -- because flag is not necessarily set. + + ------------------------------------ + -- Has_Some_Controlled_Component -- + ------------------------------------ + + function Has_Some_Controlled_Component (Rec : Entity_Id) + return Boolean + is + Comp : Entity_Id; + + begin + if Has_Controlled_Component (Rec) then + return True; + + elsif not Is_Frozen (Rec) then + if Is_Record_Type (Rec) then + Comp := First_Entity (Rec); + + while Present (Comp) loop + if not Is_Type (Comp) + and then Controlled_Type (Etype (Comp)) + then + return True; + end if; + + Next_Entity (Comp); + end loop; + + return False; + + elsif Is_Array_Type (Rec) then + return Is_Controlled (Component_Type (Rec)); + + else + return Has_Controlled_Component (Rec); + end if; + else + return False; + end if; + end Has_Some_Controlled_Component; + + -- Start of processing for Controlled_Type + begin - -- Class-wide types are considered controlled because they may contain - -- an extension that has controlled components + -- Class-wide types must be treated as controlled because they may + -- contain an extension that has controlled components return (Is_Class_Wide_Type (T) and then not No_Run_Time and then not In_Finalization_Root (T)) or else Is_Controlled (T) - or else Has_Controlled_Component (T) + or else Has_Some_Controlled_Component (T) or else (Is_Concurrent_Type (T) - and then Present (Corresponding_Record_Type (T)) - and then Controlled_Type (Corresponding_Record_Type (T))); + and then Present (Corresponding_Record_Type (T)) + and then Controlled_Type (Corresponding_Record_Type (T))); end Controlled_Type; -------------------------- @@ -2040,7 +2121,8 @@ package body Exp_Ch7 is Make_Exception_Handler (Loc, Exception_Choices => New_List (Make_Others_Choice (Loc)), Statements => New_List ( - Make_Raise_Program_Error (Loc)))); + Make_Raise_Program_Error (Loc, + Reason => PE_Finalize_Raised_Exception)))); end if; Proc_Name := Make_Defining_Identifier (Loc, Deep_Name_Of (Prim)); diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index aeff51f2b96..e2207deefe6 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.42 $ +-- $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- -- @@ -52,6 +52,10 @@ package Exp_Ch7 is -- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize -- that take care of finalization management at run-time. + procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id); + -- Build one controlling procedure when a late body overrides one of + -- the controlling operations. + function Controller_Component (Typ : Entity_Id) return Entity_Id; -- Returns the entity of the component whose name is 'Name_uController' diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 7acc5512447..905cb41acc8 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -99,10 +99,6 @@ package body Exp_Ch9 is -- of the System.Address pointer passed to entry barrier functions -- and entry body procedures. - function Array_Type (E : Entity_Id; Trec : Node_Id) return Entity_Id; - -- Find the array type associated with an entry family in the - -- associated record for the task type. - function Build_Accept_Body (Astat : Node_Id) return Node_Id; -- Transform accept statement into a block with added exception handler. -- Used both for simple accept statements and for accept alternatives in @@ -592,31 +588,6 @@ package body Exp_Ch9 is end Add_Private_Declarations; - ---------------- - -- Array_Type -- - ---------------- - - function Array_Type (E : Entity_Id; Trec : Node_Id) return Entity_Id is - Arr : Entity_Id := First_Component (Trec); - - begin - while Present (Arr) loop - exit when Ekind (Arr) = E_Component - and then Is_Array_Type (Etype (Arr)) - and then Chars (Arr) = Chars (E); - - Next_Component (Arr); - end loop; - - -- This used to return Arr itself, but this caused problems - -- when used in expanding a protected type, possibly because - -- the record of which it is a component is not frozen yet. - -- I am going to try the type instead. This may pose visibility - -- problems. ??? - - return Etype (Arr); - end Array_Type; - ----------------------- -- Build_Accept_Body -- ----------------------- @@ -3283,7 +3254,7 @@ package body Exp_Ch9 is Update_Prival_Subtypes (B_F); Set_Privals (Spec_Decl, N, Loc); - Set_Discriminals (Spec_Decl, N, Loc); + Set_Discriminals (Spec_Decl); Set_Scope (Func, Scope (Prot)); else Analyze (Cond); @@ -4408,7 +4379,7 @@ package body Exp_Ch9 is if Present (Next_Op) then Set_Privals (Dec, Next_Op, Loc); - Set_Discriminals (Dec, Next_Op, Loc); + Set_Discriminals (Dec); end if; end Expand_N_Entry_Body; @@ -5793,7 +5764,8 @@ package body Exp_Ch9 is Condition => Make_Op_Eq (Loc, Left_Opnd => New_Reference_To (Xnam, Loc), Right_Opnd => - New_Reference_To (RTE (RE_No_Rendezvous), Loc)))); + New_Reference_To (RTE (RE_No_Rendezvous), Loc)), + Reason => PE_All_Guards_Closed)); return Stats; end Accept_Or_Raise; @@ -6756,6 +6728,17 @@ package body Exp_Ch9 is New_N : Node_Id; begin + -- Do not attempt expansion if in no run time mode + + if No_Run_Time + and then not Restricted_Profile + then + Disallow_In_No_Run_Time_Mode (N); + return; + end if; + + -- Here we start the expansion by generating discriminal declarations + Add_Discriminal_Declarations (Declarations (N), Ttyp, Name_uTask, Loc); -- Add a call to Abort_Undefer at the very beginning of the task @@ -6922,27 +6905,37 @@ package body Exp_Ch9 is Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); Tasknm : constant Name_Id := Chars (Tasktyp); Taskdef : constant Node_Id := Task_Definition (N); - Proc_Spec : Node_Id; + Proc_Spec : Node_Id; Rec_Decl : Node_Id; Rec_Ent : Entity_Id; Cdecls : List_Id; - Elab_Decl : Node_Id; Size_Decl : Node_Id; Body_Decl : Node_Id; begin - if Present (Corresponding_Record_Type (Tasktyp)) then + -- Do not attempt expansion if in no run time mode + + if No_Run_Time + and then not Restricted_Profile + then + Disallow_In_No_Run_Time_Mode (N); return; - else - Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); - Rec_Ent := Defining_Identifier (Rec_Decl); - Cdecls := Component_Items - (Component_List (Type_Definition (Rec_Decl))); + -- If already expanded, nothing to do + + elsif Present (Corresponding_Record_Type (Tasktyp)) then + return; end if; + -- Here we will do the expansion + + Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); + Rec_Ent := Defining_Identifier (Rec_Decl); + Cdecls := Component_Items (Component_List + (Type_Definition (Rec_Decl))); + Qualify_Entity_Names (N); -- First create the elaboration variable @@ -6994,7 +6987,7 @@ package body Exp_Ch9 is -- This is done last, since the corresponding record initialization -- procedure will reference the previously created entities. - -- Fill in the component declarations. First the _Task_Id field: + -- Fill in the component declarations. First the _Task_Id field. Append_To (Cdecls, Make_Component_Declaration (Loc, @@ -7116,7 +7109,7 @@ package body Exp_Ch9 is -- Complete the expansion of access types to the current task -- type, if any were declared. - Expand_Previous_Access_Type (N, Tasktyp); + Expand_Previous_Access_Type (Tasktyp); end Expand_N_Task_Type_Declaration; ------------------------------- @@ -7462,7 +7455,7 @@ package body Exp_Ch9 is Op := First_Protected_Operation (Declarations (N)); if Present (Op) then - Set_Discriminals (Parent (Spec_Id), Op, Sloc (N)); + Set_Discriminals (Parent (Spec_Id)); Set_Privals (Parent (Spec_Id), Op, Sloc (N)); end if; end if; @@ -8268,11 +8261,7 @@ package body Exp_Ch9 is -- Set_Discriminals -- ---------------------- - procedure Set_Discriminals - (Dec : Node_Id; - Op : Node_Id; - Loc : Source_Ptr) - is + procedure Set_Discriminals (Dec : Node_Id) is D : Entity_Id; Pdef : Entity_Id; D_Minal : Entity_Id; @@ -8497,6 +8486,21 @@ package body Exp_Ch9 is Update_Array_Bounds (Etype (Defining_Identifier (N))); return OK; + -- For array components of discriminated records, use the + -- base type directly, because it may depend indirectly + -- on the discriminants of the protected type. Cleaner would + -- be a systematic mechanism to compute actual subtypes of + -- private components ??? + + elsif Nkind (N) in N_Has_Etype + and then Present (Etype (N)) + and then Is_Array_Type (Etype (N)) + and then Nkind (N) = N_Selected_Component + and then Has_Discriminants (Etype (Prefix (N))) + then + Set_Etype (N, Base_Type (Etype (N))); + return OK; + else if Nkind (N) in N_Has_Etype and then Present (Etype (N)) diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 949356fb391..ebb021f9617 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.56 $ +-- $Revision$ -- -- --- Copyright (C) 1992-1999 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- -- @@ -289,10 +289,7 @@ package Exp_Ch9 is -- Given a protected operation node (a subprogram or entry body), -- find the following node in the declarations list. - procedure Set_Discriminals - (Dec : Node_Id; - Op : Node_Id; - Loc : Source_Ptr); + procedure Set_Discriminals (Dec : Node_Id); -- Replace discriminals in a protected type for use by the -- next protected operation on the type. Each operation needs a -- new set of discirminals, since it needs a unique renaming of diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index c5f362b83c1..1a130789641 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -8,7 +8,7 @@ -- -- -- $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- -- @@ -41,7 +41,7 @@ with Opt; use Opt; with Output; use Output; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; -with Sinput; use Sinput; +with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; @@ -139,6 +139,19 @@ package body Exp_Dbug is -- building this name to realize efficiently that b needs further -- qualification. + -------------------- + -- Homonym_Suffix -- + -------------------- + + -- The string defined here (and its associated length) is used to + -- gather the homonym string that will be appended to Name_Buffer + -- when the name is complete. Strip_Suffixes appends to this string + -- as does Append_Homonym_Number, and Output_Homonym_Numbers_Suffix + -- appends the string to the end of Name_Buffer. + + Homonym_Numbers : String (1 .. 256); + Homonym_Len : Natural := 0; + ---------------------- -- Local Procedures -- ---------------------- @@ -150,6 +163,10 @@ package body Exp_Dbug is -- Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of -- the normalized numerator and denominator of the given real value. + procedure Append_Homonym_Number (E : Entity_Id); + -- If the entity E has homonyms in the same scope, then make an entry + -- in the Homonym_Numbers array, bumping Homonym_Count accordingly. + function Bounds_Match_Size (E : Entity_Id) return Boolean; -- Determine whether the bounds of E match the size of the type. This is -- used to determine whether encoding is required for a discrete type. @@ -171,6 +188,9 @@ package body Exp_Dbug is -- sequence in the string S (defined as two underscores -- which are preceded and followed by a non-underscore) + procedure Output_Homonym_Numbers_Suffix; + -- If homonym numbers are stored, then output them into Name_Buffer. + procedure Prepend_String_To_Buffer (S : String); -- Prepend given string to the contents of the string buffer, updating -- the value in Name_Len (i.e. string is added at start of buffer). @@ -185,12 +205,15 @@ package body Exp_Dbug is -- If not already done, replaces the Chars field of the given entity -- with the appropriate fully qualified name. - procedure Strip_BNPE_Suffix (Suffix_Found : in out Boolean); + procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean); -- Given an qualified entity name in Name_Buffer, remove any plain X or -- X{nb} qualification suffix. The contents of Name_Buffer is not changed -- but Name_Len may be adjusted on return to remove the suffix. If a - -- suffix is found and stripped, then Suffix_Found is set to True. If - -- no suffix is found, then Suffix_Found is not modified. + -- BNPE suffix is found and stripped, then BNPE_Suffix_Found is set to + -- True. If no suffix is found, then BNPE_Suffix_Found is not modified. + -- This routine also searches for a homonym suffix, and if one is found + -- it is also stripped, and the entries are added to the global homonym + -- list (Homonym_Numbers) so that they can later be put back. ------------------------ -- Add_Real_To_Buffer -- @@ -218,6 +241,57 @@ package body Exp_Dbug is end if; end Add_Uint_To_Buffer; + --------------------------- + -- Append_Homonym_Number -- + --------------------------- + + procedure Append_Homonym_Number (E : Entity_Id) is + + procedure Add_Nat_To_H (Nr : Nat); + -- Little procedure to append Nr to Homonym_Numbers + + ------------------ + -- Add_Nat_To_H -- + ------------------ + + procedure Add_Nat_To_H (Nr : Nat) is + begin + if Nr >= 10 then + Add_Nat_To_H (Nr / 10); + end if; + + Homonym_Len := Homonym_Len + 1; + Homonym_Numbers (Homonym_Len) := + Character'Val (Nr mod 10 + Character'Pos ('0')); + end Add_Nat_To_H; + + -- Start of processing for Append_Homonym_Number + + begin + if Has_Homonym (E) then + declare + H : Entity_Id := Homonym (E); + Nr : Nat := 1; + + begin + while Present (H) loop + if (Scope (H) = Scope (E)) then + Nr := Nr + 1; + end if; + + H := Homonym (H); + end loop; + + if Homonym_Len > 0 then + Homonym_Len := Homonym_Len + 1; + Homonym_Numbers (Homonym_Len) := '_'; + end if; + + Add_Nat_To_H (Nr); + end; + end if; + end Append_Homonym_Number; + ----------------------- -- Bounds_Match_Size -- ----------------------- @@ -827,15 +901,6 @@ package body Exp_Dbug is Name_Buffer (Name_Len + 1) := ASCII.NUL; end Get_Encoded_Name; - ------------------- - -- Get_Entity_Id -- - ------------------- - - function Get_Entity_Id (External_Name : String) return Entity_Id is - begin - return Empty; - end Get_Entity_Id; - ----------------------- -- Get_External_Name -- ----------------------- @@ -867,9 +932,13 @@ package body Exp_Dbug is then Get_Qualified_Name_And_Append (Scope (Entity)); Add_Str_To_Name_Buffer ("__"); + Get_Name_String_And_Append (Chars (Entity)); + Append_Homonym_Number (Entity); + + else + Get_Name_String_And_Append (Chars (Entity)); end if; - Get_Name_String_And_Append (Chars (Entity)); end Get_Qualified_Name_And_Append; -- Start of processing for Get_External_Name @@ -934,32 +1003,6 @@ package body Exp_Dbug is end if; Get_Qualified_Name_And_Append (E); - - if Has_Homonym (E) then - declare - H : Entity_Id := Homonym (E); - Nr : Nat := 1; - - begin - while Present (H) loop - if (Scope (H) = Scope (E)) then - Nr := Nr + 1; - end if; - - H := Homonym (H); - end loop; - - if Nr > 1 then - if No_Dollar_In_Label then - Add_Str_To_Name_Buffer ("__"); - else - Add_Char_To_Name_Buffer ('$'); - end if; - - Add_Nat_To_Name_Buffer (Nr); - end if; - end; - end if; end if; Name_Buffer (Name_Len + 1) := ASCII.Nul; @@ -1103,6 +1146,46 @@ package body Exp_Dbug is return Name_Find; end Make_Packed_Array_Type_Name; + ----------------------------------- + -- Output_Homonym_Numbers_Suffix -- + ----------------------------------- + + procedure Output_Homonym_Numbers_Suffix is + J : Natural; + + begin + if Homonym_Len > 0 then + + -- Check for all 1's, in which case we do not output + + J := 1; + loop + exit when Homonym_Numbers (J) /= '1'; + + -- If we reached end of string we do not output + + if J = Homonym_Len then + Homonym_Len := 0; + return; + end if; + + exit when Homonym_Numbers (J + 1) /= '_'; + J := J + 2; + end loop; + + -- If we exit the loop then suffix must be output + + if No_Dollar_In_Label then + Add_Str_To_Name_Buffer ("__"); + else + Add_Char_To_Name_Buffer ('$'); + end if; + + Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len)); + Homonym_Len := 0; + end if; + end Output_Homonym_Numbers_Suffix; + ------------------------------ -- Prepend_String_To_Buffer -- ------------------------------ @@ -1240,12 +1323,17 @@ package body Exp_Dbug is Discard : Boolean := False; begin + -- Ignore empty entry (can happen in error cases) + + if No (E) then + return; + -- If this we are qualifying entities local to a generic -- instance, use the name of the original instantiation, -- not that of the anonymous subprogram in the wrapper -- package, so that gdb doesn't have to know about these. - if Is_Generic_Instance (E) + elsif Is_Generic_Instance (E) and then Is_Subprogram (E) and then not Comes_From_Source (E) and then not Is_Compilation_Unit (Scope (E)) @@ -1258,7 +1346,7 @@ package body Exp_Dbug is if Has_Fully_Qualified_Name (E) then Get_Name_String (Chars (E)); - Strip_BNPE_Suffix (Discard); + Strip_Suffixes (Discard); Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); Full_Qualify_Len := Name_Len; Set_Has_Fully_Qualified_Name (Ent); @@ -1285,6 +1373,7 @@ package body Exp_Dbug is (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) := Name_Buffer (1 .. Name_Len); Full_Qualify_Len := Full_Qualify_Len + Name_Len; + Append_Homonym_Number (E); end if; if Is_BNPE (E) then @@ -1367,7 +1456,7 @@ package body Exp_Dbug is if Has_Qualified_Name (E) then Get_Name_String_And_Append (Chars (E)); - Strip_BNPE_Suffix (BNPE_Suffix_Needed); + Strip_Suffixes (BNPE_Suffix_Needed); -- If the top level name we are adding is itself fully -- qualified, then that means that the name that we are @@ -1395,6 +1484,8 @@ package body Exp_Dbug is if Is_BNPE (E) then BNPE_Suffix_Needed := True; end if; + + Append_Homonym_Number (E); end if; end Set_Entity_Name; @@ -1409,6 +1500,7 @@ package body Exp_Dbug is elsif Ekind (Ent) = E_Enumeration_Literal and then Present (Debug_Renaming_Link (Ent)) then + Name_Len := 0; Set_Entity_Name (Debug_Renaming_Link (Ent)); Get_Name_String (Chars (Ent)); Prepend_String_To_Buffer @@ -1436,6 +1528,8 @@ package body Exp_Dbug is -- Fall through with a fully qualified name in Name_Buffer/Name_Len + Output_Homonym_Numbers_Suffix; + -- Add body-nested package suffix if required if BNPE_Suffix_Needed @@ -1474,250 +1568,6 @@ package body Exp_Dbug is Name_Qualify_Units.Append (N); end Qualify_Entity_Names; - -------------------------------- - -- Save_Unitname_And_Use_List -- - -------------------------------- - - procedure Save_Unitname_And_Use_List - (Main_Unit_Node : Node_Id; - Main_Kind : Node_Kind) - is - INITIAL_NAME_LENGTH : constant := 1024; - - Item : Node_Id; - Pack_Name : Node_Id; - - Unit_Spec : Node_Id := 0; - Unit_Body : Node_Id := 0; - - Main_Name : String_Id; - -- Fully qualified name of Main Unit - - Unit_Name : String_Id; - -- Name of unit specified in a Use clause - - Spec_Unit_Index : Source_File_Index; - Spec_File_Name : File_Name_Type := No_File; - - Body_Unit_Index : Source_File_Index; - Body_File_Name : File_Name_Type := No_File; - - type String_Ptr is access all String; - - Spec_File_Name_Str : String_Ptr; - Body_File_Name_Str : String_Ptr; - - type Label is record - Label_Name : String_Ptr; - Name_Length : Integer; - Pos : Integer; - end record; - - Spec_Label : Label; - Body_Label : Label; - - procedure Initialize (L : out Label); - -- Initialize label - - procedure Append (L : in out Label; Ch : Character); - -- Append character to label - - procedure Append (L : in out Label; Str : String); - -- Append string to label - - procedure Append_Name (L : in out Label; Unit_Name : String_Id); - -- Append name to label - - function Sufficient_Space - (L : Label; - Unit_Name : String_Id) - return Boolean; - -- Does sufficient space exist to append another name? - - procedure Append (L : in out Label; Str : String) is - begin - L.Label_Name (L.Pos + 1 .. L.Pos + Str'Length) := Str; - L.Pos := L.Pos + Str'Length; - end Append; - - procedure Append (L : in out Label; Ch : Character) is - begin - L.Pos := L.Pos + 1; - L.Label_Name (L.Pos) := Ch; - end Append; - - procedure Append_Name (L : in out Label; Unit_Name : String_Id) is - Char : Char_Code; - Upper_Offset : constant := Character'Pos ('a') - Character'Pos ('A'); - - begin - for J in 1 .. String_Length (Unit_Name) loop - Char := Get_String_Char (Unit_Name, J); - - if Character'Val (Char) = '.' then - Append (L, "__"); - elsif Character'Val (Char) in 'A' .. 'Z' then - Append (L, Character'Val (Char + Upper_Offset)); - elsif Char /= 0 then - Append (L, Character'Val (Char)); - end if; - end loop; - end Append_Name; - - procedure Initialize (L : out Label) is - begin - L.Name_Length := INITIAL_NAME_LENGTH; - L.Pos := 0; - L.Label_Name := new String (1 .. L.Name_Length); - end Initialize; - - function Sufficient_Space - (L : Label; - Unit_Name : String_Id) - return Boolean - is - Len : Integer := Integer (String_Length (Unit_Name)) + 1; - - begin - for J in 1 .. String_Length (Unit_Name) loop - if Character'Val (Get_String_Char (Unit_Name, J)) = '.' then - Len := Len + 1; - end if; - end loop; - - return L.Pos + Len < L.Name_Length; - end Sufficient_Space; - - -- Start of processing for Save_Unitname_And_Use_List - - begin - Initialize (Spec_Label); - Initialize (Body_Label); - - case Main_Kind is - when N_Package_Declaration => - Main_Name := Full_Qualified_Name - (Defining_Unit_Name (Specification (Unit (Main_Unit_Node)))); - Unit_Spec := Main_Unit_Node; - Append (Spec_Label, "_LPS__"); - Append (Body_Label, "_LPB__"); - - when N_Package_Body => - Unit_Spec := Corresponding_Spec (Unit (Main_Unit_Node)); - Unit_Body := Main_Unit_Node; - Main_Name := Full_Qualified_Name (Unit_Spec); - Append (Spec_Label, "_LPS__"); - Append (Body_Label, "_LPB__"); - - when N_Subprogram_Body => - Unit_Body := Main_Unit_Node; - - if Present (Corresponding_Spec (Unit (Main_Unit_Node))) then - Unit_Spec := Corresponding_Spec (Unit (Main_Unit_Node)); - Main_Name := Full_Qualified_Name - (Corresponding_Spec (Unit (Main_Unit_Node))); - else - Main_Name := Full_Qualified_Name - (Defining_Unit_Name (Specification (Unit (Main_Unit_Node)))); - end if; - - Append (Spec_Label, "_LSS__"); - Append (Body_Label, "_LSB__"); - - when others => - return; - end case; - - Append_Name (Spec_Label, Main_Name); - Append_Name (Body_Label, Main_Name); - - -- If we have a body, process it first - - if Present (Unit_Body) then - - Item := First (Context_Items (Unit_Body)); - - while Present (Item) loop - if Nkind (Item) = N_Use_Package_Clause then - Pack_Name := First (Names (Item)); - while Present (Pack_Name) loop - Unit_Name := Full_Qualified_Name (Entity (Pack_Name)); - - if Sufficient_Space (Body_Label, Unit_Name) then - Append (Body_Label, '$'); - Append_Name (Body_Label, Unit_Name); - end if; - - Pack_Name := Next (Pack_Name); - end loop; - end if; - - Item := Next (Item); - end loop; - end if; - - while Present (Unit_Spec) and then - Nkind (Unit_Spec) /= N_Compilation_Unit - loop - Unit_Spec := Parent (Unit_Spec); - end loop; - - if Present (Unit_Spec) then - - Item := First (Context_Items (Unit_Spec)); - - while Present (Item) loop - if Nkind (Item) = N_Use_Package_Clause then - Pack_Name := First (Names (Item)); - while Present (Pack_Name) loop - Unit_Name := Full_Qualified_Name (Entity (Pack_Name)); - - if Sufficient_Space (Spec_Label, Unit_Name) then - Append (Spec_Label, '$'); - Append_Name (Spec_Label, Unit_Name); - end if; - - if Sufficient_Space (Body_Label, Unit_Name) then - Append (Body_Label, '$'); - Append_Name (Body_Label, Unit_Name); - end if; - - Pack_Name := Next (Pack_Name); - end loop; - end if; - - Item := Next (Item); - end loop; - end if; - - if Present (Unit_Spec) then - Append (Spec_Label, Character'Val (0)); - Spec_Unit_Index := Source_Index (Get_Cunit_Unit_Number (Unit_Spec)); - Spec_File_Name := Full_File_Name (Spec_Unit_Index); - Get_Name_String (Spec_File_Name); - Spec_File_Name_Str := new String (1 .. Name_Len + 1); - Spec_File_Name_Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); - Spec_File_Name_Str (Name_Len + 1) := Character'Val (0); - Spec_Filename := Spec_File_Name_Str (1)'Unrestricted_Access; - Spec_Context_List := - Spec_Label.Label_Name.all (1)'Unrestricted_Access; - end if; - - if Present (Unit_Body) then - Append (Body_Label, Character'Val (0)); - Body_Unit_Index := Source_Index (Get_Cunit_Unit_Number (Unit_Body)); - Body_File_Name := Full_File_Name (Body_Unit_Index); - Get_Name_String (Body_File_Name); - Body_File_Name_Str := new String (1 .. Name_Len + 1); - Body_File_Name_Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); - Body_File_Name_Str (Name_Len + 1) := Character'Val (0); - Body_Filename := Body_File_Name_Str (1)'Unrestricted_Access; - Body_Context_List := - Body_Label.Label_Name.all (1)'Unrestricted_Access; - end if; - - end Save_Unitname_And_Use_List; - --------- -- SEq -- --------- @@ -1737,21 +1587,76 @@ package body Exp_Dbug is (Hindex'First + Hindex (CDN_Hash (S.all) mod Hindex'Range_Length)); end SHash; - ----------------------- - -- Strip_BNPE_Suffix -- - ----------------------- + -------------------- + -- Strip_Suffixes -- + -------------------- + + procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is + SL : Natural; - procedure Strip_BNPE_Suffix (Suffix_Found : in out Boolean) is begin + -- Search for and strip BNPE suffix + for J in reverse 2 .. Name_Len loop if Name_Buffer (J) = 'X' then Name_Len := J - 1; - Suffix_Found := True; + BNPE_Suffix_Found := True; exit; end if; exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n'; end loop; - end Strip_BNPE_Suffix; + + -- Search for and strip homonym numbers suffix + + -- Case of __ used for homonym numbers suffix + + if No_Dollar_In_Label then + for J in reverse 2 .. Name_Len - 2 loop + if Name_Buffer (J) = '_' + and then Name_Buffer (J + 1) = '_' + then + if Name_Buffer (J + 2) in '0' .. '9' then + if Homonym_Len > 0 then + Homonym_Len := Homonym_Len + 1; + Homonym_Numbers (Homonym_Len) := '-'; + end if; + + SL := Name_Len - (J + 1); + + Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) := + Name_Buffer (J + 2 .. Name_Len); + Name_Len := J - 1; + Homonym_Len := Homonym_Len + SL; + end if; + + exit; + end if; + end loop; + + -- Case of $ used for homonym numbers suffix + + else + for J in reverse 2 .. Name_Len - 1 loop + if Name_Buffer (J) = '$' then + if Name_Buffer (J + 1) in '0' .. '9' then + if Homonym_Len > 0 then + Homonym_Len := Homonym_Len + 1; + Homonym_Numbers (Homonym_Len) := '-'; + end if; + + SL := Name_Len - J; + + Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) := + Name_Buffer (J + 1 .. Name_Len); + Name_Len := J - 1; + Homonym_Len := Homonym_Len + SL; + end if; + + exit; + end if; + end loop; + end if; + end Strip_Suffixes; end Exp_Dbug; diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index 5351ea71b87..9e6f8caca57 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.74 $ +-- $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- -- @@ -30,7 +30,6 @@ -- debugger. In accordance with the Dwarf 2.2 specification, certain -- type names are encoded to provide information to the debugger. -with Sinfo; use Sinfo; with Types; use Types; with Uintp; use Uintp; with Get_Targ; use Get_Targ; @@ -63,9 +62,9 @@ package Exp_Dbug is -- case of nested procedures.) In addition, we also consider all types -- to be global entities, even if they are defined within a procedure. - -- The reason for full treating all type names as global entities is - -- that a number of our type encodings work by having related type - -- names, and we need the full qualification to keep this unique. + -- The reason for treating all type names as global entities is that + -- a number of our type encodings work by having related type names, + -- and we need the full qualification to keep this unique. -- For global entities, the encoded name includes all components of the -- fully expanded name (but omitting Standard at the start). For example, @@ -95,10 +94,6 @@ package Exp_Dbug is -- The separating dots are translated into double underscores. - -- Note: there is one exception, which is that on IRIX, for workshop - -- back compatibility, dots are retained as dots. In the rest of this - -- document we assume the double underscore encoding. - ----------------------------- -- Handling of Overloading -- ----------------------------- @@ -107,61 +102,59 @@ package Exp_Dbug is -- subprograms, since overloading can legitimately result in a -- case of two entities with exactly the same fully qualified names. -- To distinguish between entries in a set of overloaded subprograms, - -- the encoded names are serialized by adding one of the two suffixes: + -- the encoded names are serialized by adding one of the suffixes: -- $n (dollar sign) -- __nn (two underscores) - -- where nn is a serial number (1 for the first overloaded function, - -- 2 for the second, etc.). The former suffix is used when a dollar - -- sign is a valid symbol on the target machine and the latter is - -- used when it is not. No suffix need appear on the encoding of - -- the first overloading of a subprogram. + -- where nn is a serial number (2 for the second overloaded function, + -- 2 for the third, etc.). We use $ if this symbol is allowed, and + -- double underscore if it is not. In the remaining examples in this + -- section, we use a $ sign, but the $ is replaced by __ throughout + -- these examples if $ sign is not available. A suffix of $1 is + -- always omitted (i.e. no suffix implies the first instance). -- These names are prefixed by the normal full qualification. So -- for example, the third instance of the subprogram qrs in package - -- yz would have one of the two names: + -- yz would have the name: -- yz__qrs$3 - -- yz__qrs__3 - -- The serial number always appears at the end as shown, even in the - -- case of subprograms nested inside overloaded subprograms, and only - -- when the named subprogram is overloaded. For example, consider - -- the following situation: + -- A more subtle case arises with entities declared within overloaded + -- subprograms. If we have two overloaded subprograms, and both declare + -- an entity xyz, then the fully expanded name of the two xyz's is the + -- same. To distinguish these, we add the same __n suffix at the end of + -- the inner entity names. + + -- In more complex cases, we can have multiple levels of overloading, + -- and we must make sure to distinguish which final declarative region + -- we are talking about. For this purpose, we use a more complex suffix + -- which has the form: + + -- $nn_nn_nn ... + + -- where the nn values are the homonym numbers as needed for any of + -- the qualifying entities, separated by a single underscore. If all + -- the nn values are 1, the suffix is omitted, Otherwise the suffix + -- is present (including any values of 1). The following example + -- shows how this suffixing works. -- package body Yz is - -- procedure Qrs is -- Encoded name is yz__qrs - -- procedure Tuv is ... end; -- Encoded name is yz__qrs__tuv + -- procedure Qrs is -- Name is yz__qrs + -- procedure Tuv is ... end; -- Name is yz__qrs__tuv -- begin ... end Qrs; - -- procedure Qrs (X: Integer) is -- Encoded name is yz__qrs__2 - -- procedure Tuv is ... end; -- Encoded name is yz__qrs__tuv - -- -- (not yz__qrs__2__tuv). - -- procedure Tuv (X: INTEGER) -- Encoded name is yz__qrs__tuv__2 + -- procedure Qrs (X: Int) is -- Name is yz__qrs$2 + -- procedure Tuv is ... end; -- Name is yz__qrs__tuv$2_1 + -- procedure Tuv (X: Int) is -- Name is yz__qrs__tuv$2_2 -- begin ... end Tuv; - -- procedure Tuv (X: INTEGER) -- Encoded name is yz__qrs__tuv__3 + -- procedure Tuv (X: Float) is -- Name is yz__qrs__tuv$2_3 + -- type m is new float; -- Name is yz__qrs__tuv__m$2_3 -- begin ... end Tuv; -- begin ... end Qrs; -- end Yz; - -- This example also serves to illustrate, a case in which the - -- debugging data are currently ambiguous. The two parameterless - -- versions of Yz.Qrs.Tuv have the same encoded names in the - -- debugging data. However, the actual external symbols (which - -- linkers use to resolve references) will be modified with an - -- an additional suffix so that they do not clash. Thus, there will - -- be cases in which the name of a function shown in the debugging - -- data differs from that function's "official" external name, and - -- in which several different functions have exactly the same name - -- as far as the debugger is concerned. We don't consider this too - -- much of a problem, since the only way the user has of referring - -- to these functions by name is, in fact, Yz.Qrs.Tuv, so that the - -- reference is inherently ambiguous from the user's perspective, - -- regardless of internal encodings (in these cases, the debugger - -- can provide a menu of options to allow the user to disambiguate). - -------------------- -- Operator Names -- -------------------- @@ -217,7 +210,7 @@ package Exp_Dbug is -- interpretation 1: entity c in child package a.b -- interpretation 2: entity c in nested package b in body of a - -- It is perfectly valid in both cases for both interpretations to + -- It is perfectly legal in both cases for both interpretations to -- be valid within a single program. This is a bit of a surprise since -- certainly in Ada 83, full qualification was sufficient, but not in -- Ada 95. The result is that the above scheme can result in duplicate @@ -367,10 +360,9 @@ package Exp_Dbug is -- from outside of the object, and a non-locking one that is used for -- calls from other operations on the same object. The locking operation -- simply acquires the lock, and then calls the non-locking version. - -- The names of all of these have a prefix constructed from the name - -- of the name of the type, the string "PT", and a suffix which is P - -- or N, depending on whether this is the protected or non-locking - -- version of the operation. + -- The names of all of these have a prefix constructed from the name of + -- the type, the string "PT", and a suffix which is P or N, depending on + -- whether this is the protected/non-locking version of the operation. -- Given the declaration: @@ -410,7 +402,8 @@ package Exp_Dbug is -- or "X_" if the next entity is a subunit) -- - the name of the entity -- - the string "$" (or "__" if target does not allow "$"), followed - -- by homonym number, if the entity is an overloaded subprogram + -- by homonym suffix, if the entity is an overloaded subprogram + -- or is defined within an overloaded subprogram. procedure Get_External_Name_With_Suffix (Entity : Entity_Id; @@ -424,13 +417,10 @@ package Exp_Dbug is -- or "X_" if the next entity is a subunit) -- - the name of the entity -- - the string "$" (or "__" if target does not allow "$"), followed - -- by homonym number, if the entity is an overloaded subprogram + -- by homonym suffix, if the entity is an overloaded subprogram + -- or is defined within an overloaded subprogram. -- - the string "___" followed by Suffix - function Get_Entity_Id (External_Name : String) return Entity_Id; - -- Find entity in current compilation unit, which has the given - -- External_Name. - ---------------------------- -- Debug Name Compression -- ---------------------------- @@ -653,6 +643,22 @@ package Exp_Dbug is -- or static values, with the encoding first for the lower bound, -- then for the upper bound, as previously described. + ------------------- + -- Modular Types -- + ------------------- + + -- A type declared + + -- type x is mod N; + + -- Is encoded as a subrange of an unsigned base type with lower bound + -- 0 and upper bound N. That is, there is no name encoding. We use + -- the standard encodings provided by the debugging format. Thus + -- we give these types a non-standard interpretation: the standard + -- interpretation of our encoding would not, in general, imply that + -- arithmetic on type x was to be performed modulo N (especially not + -- when N is not a power of 2). + ------------------ -- Biased Types -- ------------------ @@ -760,6 +766,21 @@ package Exp_Dbug is -- that contains the variants is replaced by a normal C union. -- In this case, the positions are all zero. + -- Discriminants appear before any variable-length fields that depend + -- on them, with one exception. In some cases, a discriminant + -- governing the choice of a variant clause may appear in the list + -- of fields of an XVE type after the entry for the variant clause + -- itself (this can happen in the presence of a representation clause + -- for the record type in the source program). However, when this + -- happens, the discriminant's position may be determined by first + -- applying the rules described in this section, ignoring the variant + -- clause. As a result, discriminants can always be located + -- independently of the variable-length fields that depend on them. + + -- The size of the ___XVE or ___XVU record or union is set to the + -- alignment (in bytes) of the original object so that the debugger + -- can calculate the size of the original type. + -- As an example of this encoding, consider the declarations: -- type Q is array (1 .. V1) of Float; -- alignment 4 @@ -805,15 +826,6 @@ package Exp_Dbug is -- but this may not be detected in this case by the conversion -- routines. - -- All discriminants always appear before any variable-length - -- fields that depend on them. So they can be located independent - -- of the variable-length field, using the standard procedure for - -- computing positions described above. - - -- The size of the ___XVE or ___XVU record or union is set to the - -- alignment (in bytes) of the original object so that the debugger - -- can calculate the size of the original type. - -- 3) Our conventions do not cover all XVE-encoded records in which -- some, but not all, fields have representation clauses. Such -- records may, therefore, be displayed incorrectly by debuggers. @@ -1350,79 +1362,4 @@ package Exp_Dbug is -- the second enumeration literal would be named QU43 and the -- value assigned to it would be 1. - ------------------- - -- Modular Types -- - ------------------- - - -- A type declared - - -- type x is mod N; - - -- Is encoded as a subrange of an unsigned base type with lower bound - -- 0 and upper bound N. That is, there is no name encoding; we only use - -- the standard encodings provided by the debugging format. Thus, - -- we give these types a non-standard interpretation: the standard - -- interpretation of our encoding would not, in general, imply that - -- arithmetic on type x was to be performed modulo N (especially not - -- when N is not a power of 2). - - --------------------- - -- Context Clauses -- - --------------------- - - -- The SGI Workshop debugger requires a very peculiar and nonstandard - -- symbol name containing $ signs to be generated that records the - -- use clauses that are used in a unit. GDB does not use this name, - -- since it takes a different philsophy of universal use visibility, - -- with manual resolution of any ambiguities. - - -- The routines and data in this section are used to prepare this - -- specialized name, whose exact contents are described below. Gigi - -- will output this encoded name only in the SGI case (indeed, not - -- only is it useless on other targets, but hazardous, given the use - -- of the non-standard character $ rejected by many assemblers.) - - -- "Use" clauses are encoded as follows: - - -- _LSS__ prefix for clauses in a subprogram spec - -- _LSB__ prefix for clauses in a subprogram body - -- _LPS__ prefix for clauses in a package spec - -- _LPB__ prefix for clauses in a package body - - -- Following the prefix is the fully qualified filename, followed by - -- '$' separated names of fully qualified units in the "use" clause. - -- If a unit appears in both the spec and the body "use" clause, it - -- will appear once in the _L[SP]S__ encoding and twice in the _L[SP]B__ - -- encoding. The encoding appears as a global symbol in the object file. - - ------------------------------------------------------------------------ - -- Subprograms and Declarations for Handling Context Clause Encodings -- - ------------------------------------------------------------------------ - - procedure Save_Unitname_And_Use_List - (Main_Unit_Node : Node_Id; - Main_Kind : Node_Kind); - -- Creates a string containing the current compilation unit name - -- and a dollar sign delimited list of packages named in a Use_Package - -- clause for the compilation unit. Needed for the SGI debugger. The - -- procedure is called unconditionally to set the variables declared - -- below, then gigi decides whether or not to use the values. - - -- The following variables are used for communication between the front - -- end and the debugging output routines in Gigi. - - type Char_Ptr is access all Character; - pragma Convention (C, Char_Ptr); - -- Character pointers accessed from C - - Spec_Context_List, Body_Context_List : Char_Ptr; - -- List of use package clauses for spec and body, respectively, as - -- built by the call to Save_Unitname_And_Use_List. Used by gigi if - -- these strings are to be output. - - Spec_Filename, Body_Filename : Char_Ptr; - -- Filenames for the spec and body, respectively, as built by the - -- call to Save_Unitname_And_Use_List. Used by gigi if these strings - -- are to be output. - end Exp_Dbug; diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index f5ff995d61b..722d7887474 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.9 $ -- +-- $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- -- @@ -54,7 +54,6 @@ package Exp_Disp is TSD_Entry_Size, TSD_Prologue_Size); - function Fill_DT_Entry (Loc : Source_Ptr; Prim : Entity_Id) diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index c0d79d12d22..a4fbe7c776d 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.125 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -58,7 +58,7 @@ package body Exp_Dist is -- form: -- type Stub is tagged record -- [...declaration similar to s-parint.ads RACW_Stub_Type...] - -- end Stub; + -- end record; -- is built. This type has two properties: -- -- 1) Since it has the same structure than RACW_Stub_Type, it can be @@ -2635,7 +2635,8 @@ package body Exp_Dist is Append_To (Decls, Make_Raise_Constraint_Error (Loc, Condition => - Make_Op_Not (Loc, Right_Opnd => Condition))); + Make_Op_Not (Loc, Right_Opnd => Condition), + Reason => CE_Partition_Check_Failed)); end Insert_Partition_Check; -- Start of processing for Build_Subprogram_Calling_Stubs diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index 0eba7e2673e..2d49f900069 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -1960,6 +1960,13 @@ package body Exp_Fixd is Right : constant Node_Id := Right_Opnd (N); begin + -- Suppress expansion of a fixed-by-fixed division if the + -- operation is supported directly by the target. + + if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then + return; + end if; + if Etype (Left) = Universal_Real then Do_Divide_Universal_Fixed (N); @@ -2100,6 +2107,13 @@ package body Exp_Fixd is end Rewrite_Non_Static_Universal; begin + -- Suppress expansion of a fixed-by-fixed multiplication if the + -- operation is supported directly by the target. + + if Target_Has_Fixed_Ops (Etype (Left), Etype (Right), Etype (N)) then + return; + end if; + if Etype (Left) = Universal_Real then if Nkind (Left) = N_Real_Literal then Do_Multiply_Fixed_Universal (N, Right, Left); diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 53be18f7e39..ae28efd647e 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.76 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -82,11 +82,11 @@ package body Exp_Intr is -- Expand a call to an instantiation of Unchecked_Convertion into a node -- N_Unchecked_Type_Conversion. - procedure Expand_Unc_Deallocation (N : Node_Id; E : Entity_Id); + procedure Expand_Unc_Deallocation (N : Node_Id); -- Expand a call to an instantiation of Unchecked_Deallocation into a node -- N_Free_Statement and appropriate context. - procedure Expand_Source_Info (N : Node_Id; E : Entity_Id; Nam : Name_Id); + procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id); -- Rewrite the node by the appropriate string or positive constant. -- Nam can be one of the following: -- Name_File - expand string that is the name of source file @@ -267,14 +267,14 @@ package body Exp_Intr is Expand_Unc_Conversion (N, E); elsif Nam = Name_Unchecked_Deallocation then - Expand_Unc_Deallocation (N, E); + Expand_Unc_Deallocation (N); elsif Nam = Name_File or else Nam = Name_Line or else Nam = Name_Source_Location or else Nam = Name_Enclosing_Entity then - Expand_Source_Info (N, E, Nam); + Expand_Source_Info (N, Nam); else -- Only other possibility is a renaming, in which case we expand @@ -389,7 +389,7 @@ package body Exp_Intr is -- Expand_Source_Info -- ------------------------ - procedure Expand_Source_Info (N : Node_Id; E : Entity_Id; Nam : Name_Id) is + procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is Loc : constant Source_Ptr := Sloc (N); Ent : Entity_Id; @@ -515,7 +515,7 @@ package body Exp_Intr is -- task itself is freed if it is terminated, ditto for a simple protected -- object, with a call to Finalize_Protection - procedure Expand_Unc_Deallocation (N : Node_Id; E : Entity_Id) is + procedure Expand_Unc_Deallocation (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Arg : constant Node_Id := First_Actual (N); Typ : constant Entity_Id := Etype (Arg); diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 5656569669c..511cd4c95a5 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -591,7 +591,7 @@ package body Exp_Pakd is Right_Opnd => Convert_To (Standard_Integer, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Styp, Loc), + Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_First))); -- For larger integer types, subtract first, then convert to @@ -606,7 +606,7 @@ package body Exp_Pakd is Left_Opnd => Newsub, Right_Opnd => Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Styp, Loc), + Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_First))); end if; @@ -625,18 +625,18 @@ package body Exp_Pakd is Make_Op_Subtract (Loc, Left_Opnd => Convert_To (Standard_Integer, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Styp, Loc), + Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_Pos, - Expressions => New_List (Newsub))), + Expressions => New_List (Newsub))), Right_Opnd => Convert_To (Standard_Integer, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Styp, Loc), + Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_Pos, - Expressions => New_List ( + Expressions => New_List ( Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Styp, Loc), + Prefix => New_Occurrence_Of (Styp, Loc), Attribute_Name => Name_First))))); end if; @@ -761,7 +761,7 @@ package body Exp_Pakd is end if; Set_Is_Itype (PAT, True); - Set_Is_Packed_Array_Type (PAT, True); + Set_Packed_Array_Type (Typ, PAT); Analyze (Decl, Suppress => All_Checks); if Pushed_Scope then @@ -780,10 +780,11 @@ package body Exp_Pakd is -- Set remaining fields of packed array type - Init_Alignment (PAT); - Set_Parent (PAT, Empty); - Set_Packed_Array_Type (Typ, PAT); + Init_Alignment (PAT); + Set_Parent (PAT, Empty); Set_Associated_Node_For_Itype (PAT, Typ); + Set_Is_Packed_Array_Type (PAT, True); + Set_Original_Array_Type (PAT, Typ); -- We definitely do not want to delay freezing for packed array -- types. This is of particular importance for the itypes that @@ -801,14 +802,17 @@ package body Exp_Pakd is procedure Set_PB_Type is begin -- If the user has specified an explicit alignment for the - -- component, take it into account. + -- type or component, take it into account. if Csize <= 2 or else Csize = 4 or else Csize mod 2 /= 0 + or else Alignment (Typ) = 1 or else Component_Alignment (Typ) = Calign_Storage_Unit then PB_Type := RTE (RE_Packed_Bytes1); - elsif Csize mod 4 /= 0 then + elsif Csize mod 4 /= 0 + or else Alignment (Typ) = 2 + then PB_Type := RTE (RE_Packed_Bytes2); else @@ -973,17 +977,28 @@ package body Exp_Pakd is Type_Definition => Typedef); end; + -- Set type as packed array type and install it + + Set_Is_Packed_Array_Type (PAT); Install_PAT; return; - -- Case of bit-packing required for unconstrained array. We simply - -- use Packed_Bytes{1,2,4} as appropriate, and we do not need to - -- construct a special packed array type. + -- Case of bit-packing required for unconstrained array. We create + -- a subtype that is equivalent to use Packed_Bytes{1,2,4} as needed. elsif not Is_Constrained (Typ) then + PAT := + Make_Defining_Identifier (Loc, + Chars => Make_Packed_Array_Type_Name (Typ, Csize)); + + Set_Packed_Array_Type (Typ, PAT); Set_PB_Type; - Set_Packed_Array_Type (Typ, PB_Type); - Set_Is_Packed_Array_Type (Packed_Array_Type (Typ), True); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => PAT, + Subtype_Indication => New_Occurrence_Of (PB_Type, Loc)); + Install_PAT; return; -- Remaining code is for the case of bit-packing for constrained array @@ -1453,9 +1468,9 @@ package body Exp_Pakd is Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Set_nn, Loc), Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, + Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, - Prefix => Obj), + Prefix => Obj), Subscr, Unchecked_Convert_To (Bits_nn, Convert_To (Ctyp, Rhs))))); @@ -1507,13 +1522,13 @@ package body Exp_Pakd is Left_Opnd => Subscr, Right_Opnd => Make_Attribute_Reference (Ploc, - Prefix => New_Occurrence_Of (Atyp, Ploc), + Prefix => New_Occurrence_Of (Atyp, Ploc), Attribute_Name => Name_Component_Size)); elsif Nkind (Pref) = N_Selected_Component then Term := Make_Attribute_Reference (Ploc, - Prefix => Selector_Name (Pref), + Prefix => Selector_Name (Pref), Attribute_Name => Name_Bit_Position); else @@ -1541,7 +1556,7 @@ package body Exp_Pakd is Left_Opnd => Unchecked_Convert_To (RTE (RE_Integer_Address), Make_Attribute_Reference (Loc, - Prefix => Pref, + Prefix => Pref, Attribute_Name => Name_Address)), Right_Opnd => @@ -1619,7 +1634,8 @@ package body Exp_Pakd is Right_Opnd => Convert_To (BT, - New_Occurrence_Of (Standard_True, Loc)))))); + New_Occurrence_Of (Standard_True, Loc)))), + Reason => CE_Range_Check_Failed)); end; end if; @@ -1701,9 +1717,9 @@ package body Exp_Pakd is Name => New_Occurrence_Of (RTE (E_Id), Loc), Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, + Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, - Prefix => L), + Prefix => L), Make_Op_Multiply (Loc, Left_Opnd => @@ -1715,9 +1731,9 @@ package body Exp_Pakd is Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Ltyp))), - Make_Attribute_Reference (Loc, + Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, - Prefix => R), + Prefix => R), Make_Op_Multiply (Loc, Left_Opnd => @@ -1729,7 +1745,7 @@ package body Exp_Pakd is Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Rtyp))), - Make_Attribute_Reference (Loc, + Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, Prefix => New_Occurrence_Of (Result_Ent, Loc)))))); @@ -1841,9 +1857,9 @@ package body Exp_Pakd is Make_Function_Call (Loc, Name => New_Occurrence_Of (Get_nn, Loc), Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, + Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, - Prefix => Obj), + Prefix => Obj), Subscr)))); end; end if; @@ -1885,7 +1901,7 @@ package body Exp_Pakd is Left_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Length, - Prefix => New_Occurrence_Of (Ltyp, Loc)), + Prefix => New_Occurrence_Of (Ltyp, Loc)), Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Ltyp))); @@ -1894,7 +1910,7 @@ package body Exp_Pakd is Left_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Length, - Prefix => New_Occurrence_Of (Rtyp, Loc)), + Prefix => New_Occurrence_Of (Rtyp, Loc)), Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Rtyp))); @@ -1934,15 +1950,15 @@ package body Exp_Pakd is Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Bit_Eq), Loc), Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, + Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, - Prefix => L), + Prefix => L), LLexpr, - Make_Attribute_Reference (Loc, + Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, - Prefix => R), + Prefix => R), RLexpr))); end if; @@ -1995,7 +2011,8 @@ package body Exp_Pakd is Right_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (CT, Loc), - Attribute_Name => Name_Last)))); + Attribute_Name => Name_Last)), + Reason => CE_Range_Check_Failed)); end; -- Now that that silliness is taken care of, get packed array type @@ -2052,9 +2069,9 @@ package body Exp_Pakd is Name => New_Occurrence_Of (RTE (RE_Bit_Not), Loc), Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, + Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, - Prefix => Opnd), + Prefix => Opnd), Make_Op_Multiply (Loc, Left_Opnd => @@ -2066,7 +2083,7 @@ package body Exp_Pakd is Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Rtyp))), - Make_Attribute_Reference (Loc, + Make_Byte_Aligned_Attribute_Reference (Loc, Attribute_Name => Name_Address, Prefix => New_Occurrence_Of (Result_Ent, Loc)))))); @@ -2146,13 +2163,11 @@ package body Exp_Pakd is -- If we have a specified alignment, see if it is sufficient, if not -- then we can't possibly be aligned enough in any case. - elsif Is_Entity_Name (Obj) - and then Known_Alignment (Entity (Obj)) - then + elsif Known_Alignment (Etype (Obj)) then -- Alignment required is 4 if size is a multiple of 4, and -- 2 otherwise (e.g. 12 bits requires 4, 10 bits requires 2) - if Alignment (Entity (Obj)) < 4 - (Csiz mod 4) then + if Alignment (Etype (Obj)) < 4 - (Csiz mod 4) then return False; end if; end if; @@ -2345,7 +2360,7 @@ package body Exp_Pakd is then Rewrite (Expr, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Expr_Typ, Loc), + Prefix => New_Occurrence_Of (Expr_Typ, Loc), Attribute_Name => Name_Pos, Expressions => New_List (Relocate_Node (Expr)))); Analyze_And_Resolve (Expr, Standard_Natural); diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 855c3725dd1..54ea0413cb7 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.53 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -59,7 +59,6 @@ package body Exp_Prag is function Arg1 (N : Node_Id) return Node_Id; function Arg2 (N : Node_Id) return Node_Id; - function Arg3 (N : Node_Id) return Node_Id; -- Obtain specified Pragma_Argument_Association procedure Expand_Pragma_Abort_Defer (N : Node_Id); @@ -69,25 +68,24 @@ package body Exp_Prag is procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); - -------------- - -- Arg1,2,3 -- - -------------- + ---------- + -- Arg1 -- + ---------- function Arg1 (N : Node_Id) return Node_Id is begin return First (Pragma_Argument_Associations (N)); end Arg1; + ---------- + -- Arg2 -- + ---------- + function Arg2 (N : Node_Id) return Node_Id is begin return Next (Arg1 (N)); end Arg2; - function Arg3 (N : Node_Id) return Node_Id is - begin - return Next (Arg2 (N)); - end Arg3; - --------------------- -- Expand_N_Pragma -- --------------------- diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 92ff393b2ef..604d1922aab 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.39 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -807,7 +807,10 @@ package body Exp_Strm is -- procedure is erroneous, because there are no discriminants to read. if Is_Unchecked_Union (Typ) then - Stms := New_List (Make_Raise_Program_Error (Loc)); + Stms := + New_List ( + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); end if; if Is_Non_Empty_List ( @@ -870,7 +873,10 @@ package body Exp_Strm is -- because there are no discriminants to write. if Is_Unchecked_Union (Typ) then - Stms := New_List (Make_Raise_Program_Error (Loc)); + Stms := + New_List ( + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); end if; if Is_Non_Empty_List ( @@ -890,10 +896,13 @@ package body Exp_Strm is -- The function we build looks like -- function InputN (S : access RST) return Typ is - -- C1 : constant Disc_Type_1 := Discr_Type_1'Input (S); - -- C2 : constant Disc_Type_1 := Discr_Type_2'Input (S); + -- C1 : constant Disc_Type_1; + -- Discr_Type_1'Read (S, C1); + -- C2 : constant Disc_Type_2; + -- Discr_Type_2'Read (S, C2); -- ... - -- Cn : constant Disc_Type_1 := Discr_Type_n'Input (S); + -- Cn : constant Disc_Type_n; + -- Discr_Type_n'Read (S, Cn); -- V : Typ (C1, C2, .. Cn) -- begin @@ -934,14 +943,16 @@ package body Exp_Strm is Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Cn), - Object_Definition => New_Occurrence_Of (Etype (Discr), Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of - (Stream_Base_Type (Etype (Discr)), Loc), - Attribute_Name => Name_Input, - Expressions => New_List (Make_Identifier (Loc, Name_S))))); + Object_Definition => + New_Occurrence_Of (Etype (Discr), Loc))); + + Append_To (Decls, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (Discr), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Cn)))); Append_To (Constr, Make_Identifier (Loc, Cn)); @@ -1161,7 +1172,9 @@ package body Exp_Strm is if Present (VP) then if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then - return New_List (Make_Raise_Program_Error (Sloc (VP))); + return New_List ( + Make_Raise_Program_Error (Sloc (VP), + Reason => PE_Unchecked_Union_Restriction)); end if; V := First_Non_Pragma (Variants (VP)); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 66bf2a96e5b..7c17fb65017 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.8 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -50,9 +50,11 @@ with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Stand; use Stand; with Stringt; use Stringt; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; +with Urealp; use Urealp; with Validsw; use Validsw; package body Exp_Util is @@ -98,7 +100,6 @@ package body Exp_Util is function Build_Task_Record_Image (Loc : Source_Ptr; Id_Ref : Node_Id; - A_Type : Entity_Id; Dyn : Boolean := False) return Node_Id; -- Build function to generate the image string for a task that is a @@ -633,7 +634,7 @@ package body Exp_Util is T_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (Selector_Name (Id_Ref)), 'I')); - Fun := Build_Task_Record_Image (Loc, Id_Ref, A_Type, Is_Dyn); + Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn); elsif Nkind (Id_Ref) = N_Indexed_Component then T_Id := @@ -786,7 +787,6 @@ package body Exp_Util is function Build_Task_Record_Image (Loc : Source_Ptr; Id_Ref : Node_Id; - A_Type : Entity_Id; Dyn : Boolean := False) return Node_Id is @@ -1657,7 +1657,6 @@ package body Exp_Util is if Nkind (Parent (P)) = N_Aggregate and then Present (Aggregate_Bounds (Parent (P))) and then Nkind (First (Choices (P))) = N_Others_Choice - and then Nkind (First (Ins_Actions)) /= N_Freeze_Entity then if No (Loop_Actions (P)) then Set_Loop_Actions (P, Ins_Actions); @@ -2093,12 +2092,20 @@ package body Exp_Util is Remove_Handler_Entries (N); Remove_Warning_Messages (N); - -- Recurse into block statements to process declarations/statements + -- Recurse into block statements and bodies to process declarations + -- and statements - if Nkind (N) = N_Block_Statement then + if Nkind (N) = N_Block_Statement + or else Nkind (N) = N_Subprogram_Body + or else Nkind (N) = N_Package_Body + then Kill_Dead_Code (Declarations (N)); Kill_Dead_Code (Statements (Handled_Statement_Sequence (N))); + if Nkind (N) = N_Subprogram_Body then + Set_Is_Eliminated (Defining_Entity (N)); + end if; + -- Recurse into composite statement to kill individual statements, -- in particular instantiations. @@ -2168,6 +2175,89 @@ package body Exp_Util is end if; end Known_Non_Negative; + -------------------------- + -- Target_Has_Fixed_Ops -- + -------------------------- + + Integer_Sized_Small : Ureal; + -- Set to 2.0 ** -(Integer'Size - 1) the first time that this + -- function is called (we don't want to compute it more than once!) + + Long_Integer_Sized_Small : Ureal; + -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this + -- functoin is called (we don't want to compute it more than once) + + First_Time_For_THFO : Boolean := True; + -- Set to False after first call (if Fractional_Fixed_Ops_On_Target) + + function Target_Has_Fixed_Ops + (Left_Typ : Entity_Id; + Right_Typ : Entity_Id; + Result_Typ : Entity_Id) + return Boolean + is + function Is_Fractional_Type (Typ : Entity_Id) return Boolean; + -- Return True if the given type is a fixed-point type with a small + -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have + -- an absolute value less than 1.0. This is currently limited + -- to fixed-point types that map to Integer or Long_Integer. + + ------------------------ + -- Is_Fractional_Type -- + ------------------------ + + function Is_Fractional_Type (Typ : Entity_Id) return Boolean is + begin + if Esize (Typ) = Standard_Integer_Size then + return Small_Value (Typ) = Integer_Sized_Small; + + elsif Esize (Typ) = Standard_Long_Integer_Size then + return Small_Value (Typ) = Long_Integer_Sized_Small; + + else + return False; + end if; + end Is_Fractional_Type; + + -- Start of processing for Target_Has_Fixed_Ops + + begin + -- Return False if Fractional_Fixed_Ops_On_Target is false + + if not Fractional_Fixed_Ops_On_Target then + return False; + end if; + + -- Here the target has Fractional_Fixed_Ops, if first time, compute + -- standard constants used by Is_Fractional_Type. + + if First_Time_For_THFO then + First_Time_For_THFO := False; + + Integer_Sized_Small := + UR_From_Components + (Num => Uint_1, + Den => UI_From_Int (Standard_Integer_Size - 1), + Rbase => 2); + + Long_Integer_Sized_Small := + UR_From_Components + (Num => Uint_1, + Den => UI_From_Int (Standard_Long_Integer_Size - 1), + Rbase => 2); + end if; + + -- Return True if target supports fixed-by-fixed multiply/divide + -- for fractional fixed-point types (see Is_Fractional_Type) and + -- the operand and result types are equivalent fractional types. + + return Is_Fractional_Type (Base_Type (Left_Typ)) + and then Is_Fractional_Type (Base_Type (Right_Typ)) + and then Is_Fractional_Type (Base_Type (Result_Typ)) + and then Esize (Left_Typ) = Esize (Right_Typ) + and then Esize (Left_Typ) = Esize (Result_Typ); + end Target_Has_Fixed_Ops; + ----------------------------- -- Make_CW_Equivalent_Type -- ----------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index b2c9ed52dc7..44b71edc871 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -407,6 +407,16 @@ package Exp_Util is -- in the binder. We do that so that we can detect cases where this is -- the only elaboration action that is required. + function Target_Has_Fixed_Ops + (Left_Typ : Entity_Id; + Right_Typ : Entity_Id; + Result_Typ : Entity_Id) + return Boolean; + -- Returns True if and only if the target machine has direct support + -- for fixed-by-fixed multiplications and divisions for the given + -- operand and result types. This is called in package Exp_Fixd to + -- determine whether to expand such operations. + procedure Wrap_Cleanup_Procedure (N : Node_Id); -- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer -- call at the start of the statement sequence, and an Abort_Undefer call diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index 7c48655ecc5..55bbf386d1b 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.120 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -103,7 +103,7 @@ package body Expander is -- expansion on (see the spec of sem). -- Finally, expansion is turned off in a regular compilation if there - -- are semantic errors. In that case there will be no further expansion, + -- are serious errors. In that case there will be no further expansion, -- but one cleanup action may be required: if a transient scope was -- created (e.g. for a function that returns an unconstrained type) -- the scope may still be on the stack, and must be removed explicitly, @@ -113,7 +113,7 @@ package body Expander is if not Expander_Active then Set_Analyzed (N, Full_Analysis); - if Errors_Detected > 0 + if Serious_Errors_Detected > 0 and then Scope_Is_Transient then Scope_Stack.Table @@ -127,7 +127,6 @@ package body Expander is return; else - Debug_A_Entry ("expanding ", N); -- Processing depends on node kind. For full details on the expansion @@ -473,7 +472,7 @@ package body Expander is Expander_Active := Expander_Flags.Table (Expander_Flags.Last); Expander_Flags.Decrement_Last; - if Errors_Detected /= 0 then + if Serious_Errors_Detected /= 0 then Expander_Active := False; end if; end Expander_Mode_Restore; diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c index 591401cf1dc..663eb3f9298 100644 --- a/gcc/ada/expect.c +++ b/gcc/ada/expect.c @@ -6,9 +6,9 @@ * * * C Implementation File * * * - * $Revision: 1.1 $ + * $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- * @@ -74,11 +74,12 @@ __gnat_expect_fork () } void -__gnat_expect_portable_execvp (cmd, argv) +__gnat_expect_portable_execvp (pid, cmd, argv) + int *pid; char *cmd; char *argv[]; { - (void) spawnve (_P_NOWAIT, cmd, argv, NULL); + *pid = (int) spawnve (_P_NOWAIT, cmd, argv, NULL); } int @@ -108,15 +109,15 @@ __gnat_expect_poll (fd, num_fd, timeout, is_set) is_set[i] = 0; for (i = 0; i < num_fd; i++) - handles[i] = (HANDLE) _get_osfhandle (fd [i]); + handles[i] = (HANDLE) _get_osfhandle (fd[i]); - num = timeout / 10; + num = timeout / 50; while (1) { for (i = 0; i < num_fd; i++) { - if (!PeekNamedPipe (handles [i], NULL, 0, NULL, &avail, NULL)) + if (!PeekNamedPipe (handles[i], NULL, 0, NULL, &avail, NULL)) return -1; if (avail > 0) @@ -129,11 +130,130 @@ __gnat_expect_poll (fd, num_fd, timeout, is_set) if (timeout >= 0 && num == 0) return 0; - Sleep (10); + Sleep (50); num--; } } +#elif defined (VMS) +#include <unistd.h> +#include <stdio.h> +#include <unixio.h> +#include <stdlib.h> +#include <string.h> +#include <descrip.h> +#include <stdio.h> +#include <stsdef.h> +#include <iodef.h> + +int +__gnat_pipe (fd) + int *fd; +{ + return pipe (fd); +} + +int +__gnat_expect_fork () +{ + return -1; +} + +void +__gnat_expect_portable_execvp (pid, cmd, argv) + int *pid; + char *cmd; + char *argv[]; +{ + *pid = (int) getpid(); + /* Since cmd is fully qualified, it is incorrect to to call execvp */ + execv (cmd, argv); +} + +int +__gnat_expect_poll (fd, num_fd, timeout, is_set) + int *fd; + int num_fd; + int timeout; + int *is_set; +{ + int i, num, ready = 0; + unsigned int status; + int mbxchans [num_fd]; + struct dsc$descriptor_s mbxname; + struct io_status_block { + short int condition; + short int count; + int dev; + } iosb; + char buf [256]; + + for (i = 0; i < num_fd; i++) + is_set[i] = 0; + + for (i = 0; i < num_fd; i++) + { + + /* Get name of the mailbox used in the pipe */ + getname (fd [i], buf); + + /* Assign a channel to the mailbox */ + if (strlen (buf) > 0) + { + mbxname.dsc$w_length = strlen (buf); + mbxname.dsc$b_dtype = DSC$K_DTYPE_T; + mbxname.dsc$b_class = DSC$K_CLASS_S; + mbxname.dsc$a_pointer = buf; + + status = SYS$ASSIGN (&mbxname, &mbxchans[i], 0, 0, 0); + } + } + + num = timeout / 100; + + while (1) + { + for (i = 0; i < num_fd; i++) + { + if (mbxchans[i] > 0) + { + + /* Peek in the mailbox to see if there's data */ + status = SYS$QIOW + (0, mbxchans[i], IO$_SENSEMODE|IO$M_READERCHECK, + &iosb, 0, 0, 0, 0, 0, 0, 0, 0); + + if (iosb.count > 0) + { + is_set[i] = 1; + ready = 1; + goto deassign; + } + } + } + + if (timeout >= 0 && num == 0) + { + ready = 0; + goto deassign; + } + + usleep (100000); + num--; + } + + deassign: + + /* Deassign channels assigned above */ + for (i = 0; i < num_fd; i++) + { + if (mbxchans[i] > 0) + status = SYS$DASSGN (mbxchans[i]); + } + + return ready; +} + #elif defined (unix) #include <sys/time.h> @@ -165,10 +285,12 @@ __gnat_expect_fork () } void -__gnat_expect_portable_execvp (cmd, argv) +__gnat_expect_portable_execvp (pid, cmd, argv) + int *pid; char *cmd; char *argv[]; { + *pid = (int) getpid(); execvp (cmd, argv); } @@ -189,9 +311,9 @@ __gnat_expect_poll (fd, num_fd, timeout, is_set) for (i = 0; i < num_fd; i++) { - FD_SET (fd [i], &rset); - if (fd [i] > max_fd) - max_fd = fd [i]; + FD_SET (fd[i], &rset); + if (fd[i] > max_fd) + max_fd = fd[i]; } tv.tv_sec = timeout / 1000; @@ -201,7 +323,7 @@ __gnat_expect_poll (fd, num_fd, timeout, is_set) if (ready > 0) for (i = 0; i < num_fd; i++) - is_set [i] = (FD_ISSET (fd [i], &rset) ? 1 : 0); + is_set[i] = (FD_ISSET (fd[i], &rset) ? 1 : 0); return ready; } @@ -222,10 +344,12 @@ __gnat_expect_fork () } void -__gnat_expect_portable_execvp (cmd, argv) +__gnat_expect_portable_execvp (pid, cmd, argv) + int *pid; char *cmd; char *argv[]; { + *pid = 0; } int diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index e21f0cf49b2..4b2dc8e6696 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -6,9 +6,9 @@ * * * C Header File * * * - * $Revision: 1.1 $ + * $Revision$ * * - * Copyright (C) 1992-2001 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- * @@ -81,6 +81,14 @@ extern void Set_RM_Size PARAMS ((Entity_Id, Uint)); extern void Set_Component_Bit_Offset PARAMS ((Entity_Id, Uint)); extern void Set_Present_Expr PARAMS ((Node_Id, Uint)); +/* Test if the node N is the name of an entity (i.e. is an identifier, + expanded name, or an attribute reference that returns an entity). */ +#define Is_Entity_Name einfo__is_entity_name +extern Boolean Is_Entity_Name PARAMS ((Node_Id)); + +#define Get_Attribute_Definition_Clause einfo__get_attribute_definition_clause +extern Node_Id Get_Attribute_Definition_Clause PARAMS ((Entity_Id, char)); + /* errout: */ #define Error_Msg_N errout__error_msg_n @@ -144,7 +152,12 @@ extern Boolean In_Extended_Main_Code_Unit PARAMS ((Entity_Id)); /* opt: */ #define Global_Discard_Names opt__global_discard_names +#define Exception_Mechanism opt__exception_mechanism + +typedef enum {Setjmp_Longjmp, Front_End_ZCX, GCC_ZCX} Exception_Mechanism_Type; + extern Boolean Global_Discard_Names; +extern Exception_Mechanism_Type Exception_Mechanism; /* restrict: */ @@ -154,12 +167,6 @@ extern Boolean Global_Discard_Names; extern void Check_Elaboration_Code_Allowed PARAMS ((Node_Id)); extern Boolean No_Exception_Handlers_Set PARAMS ((void)); -/* sem_ch13: */ - -#define Get_Attribute_Definition_Clause \ - sem_ch13__get_attribute_definition_clause -extern Node_Id Get_Attribute_Definition_Clause PARAMS ((Entity_Id, char)); - /* sem_eval: */ #define Compile_Time_Known_Value sem_eval__compile_time_known_value @@ -194,4 +201,3 @@ extern void Set_Has_No_Elaboration_Code PARAMS ((Node_Id, Boolean)); #define Stack_Check_Probes_On_Target targparm__stack_check_probes_on_target extern Boolean Stack_Check_Probes_On_Target; - diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb index 54409cd9e35..9c1ffea5191 100644 --- a/gcc/ada/fmap.adb +++ b/gcc/ada/fmap.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- -- Copyright (C) 2001, Free Software Foundation, Inc. -- -- -- @@ -26,9 +26,11 @@ -- -- ------------------------------------------------------------------------------ -with Namet; use Namet; -with Osint; use Osint; -with Output; use Output; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Namet; use Namet; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; with Table; with Unchecked_Conversion; @@ -43,8 +45,13 @@ package body Fmap is function To_Big_String_Ptr is new Unchecked_Conversion (Source_Buffer_Ptr, Big_String_Ptr); + type Mapping is record + Uname : Unit_Name_Type; + Fname : File_Name_Type; + end record; + package File_Mapping is new Table.Table ( - Table_Component_Type => File_Name_Type, + Table_Component_Type => Mapping, Table_Index_Type => Int, Table_Low_Bound => 0, Table_Initial => 1_000, @@ -53,7 +60,7 @@ package body Fmap is -- Mapping table to map unit names to file names. package Path_Mapping is new Table.Table ( - Table_Component_Type => File_Name_Type, + Table_Component_Type => Mapping, Table_Index_Type => Int, Table_Low_Bound => 0, Table_Initial => 1_000, @@ -89,6 +96,8 @@ package body Fmap is -- Hash table to map file names to path names. Used in conjunction with -- table Path_Mapping above. + Last_In_Table : Int := 0; + --------------------- -- Add_To_File_Map -- --------------------- @@ -101,10 +110,12 @@ package body Fmap is begin File_Mapping.Increment_Last; Unit_Hash_Table.Set (Unit_Name, File_Mapping.Last); - File_Mapping.Table (File_Mapping.Last) := File_Name; + File_Mapping.Table (File_Mapping.Last) := + (Uname => Unit_Name, Fname => File_Name); Path_Mapping.Increment_Last; File_Hash_Table.Set (File_Name, Path_Mapping.Last); - Path_Mapping.Table (Path_Mapping.Last) := Path_Name; + Path_Mapping.Table (Path_Mapping.Last) := + (Uname => Unit_Name, Fname => Path_Name); end Add_To_File_Map; ---------- @@ -126,13 +137,15 @@ package body Fmap is BS : Big_String_Ptr; SP : String_Ptr; - Deb : Positive := 1; - Fin : Natural := 0; + First : Positive := 1; + Last : Natural := 0; Uname : Unit_Name_Type; Fname : Name_Id; Pname : Name_Id; + The_Mapping : Mapping; + procedure Empty_Tables; -- Remove all entries in case of incorrect mapping file @@ -153,6 +166,7 @@ package body Fmap is File_Hash_Table.Reset; Path_Mapping.Set_Last (0); File_Mapping.Set_Last (0); + Last_In_Table := 0; end Empty_Tables; -------------- @@ -163,29 +177,29 @@ package body Fmap is use ASCII; begin - Deb := Fin + 1; + First := Last + 1; -- If not at the end of file, skip the end of line - while Deb < SP'Last - and then (SP (Deb) = CR - or else SP (Deb) = LF - or else SP (Deb) = EOF) + while First < SP'Last + and then (SP (First) = CR + or else SP (First) = LF + or else SP (First) = EOF) loop - Deb := Deb + 1; + First := First + 1; end loop; - -- If not at the end of line, find the end of this new line + -- If not at the end of file, find the end of this new line - if Deb < SP'Last and then SP (Deb) /= EOF then - Fin := Deb; + if First < SP'Last and then SP (First) /= EOF then + Last := First; - while Fin < SP'Last - and then SP (Fin + 1) /= CR - and then SP (Fin + 1) /= LF - and then SP (Fin + 1) /= EOF + while Last < SP'Last + and then SP (Last + 1) /= CR + and then SP (Last + 1) /= LF + and then SP (Last + 1) /= EOF loop - Fin := Fin + 1; + Last := Last + 1; end loop; end if; @@ -197,22 +211,27 @@ package body Fmap is procedure Report_Truncated is begin - Write_Str ("warning: mapping file """); - Write_Str (File_Name); - Write_Line (""" is truncated"); + if not Quiet_Output then + Write_Str ("warning: mapping file """); + Write_Str (File_Name); + Write_Line (""" is truncated"); + end if; end Report_Truncated; -- Start of procedure Initialize begin + Empty_Tables; Name_Len := File_Name'Length; Name_Buffer (1 .. Name_Len) := File_Name; Read_Source_File (Name_Enter, 0, Hi, Src, Config); if Src = null then - Write_Str ("warning: could not read mapping file """); - Write_Str (File_Name); - Write_Line (""""); + if not Quiet_Output then + Write_Str ("warning: could not read mapping file """); + Write_Str (File_Name); + Write_Line (""""); + end if; else BS := To_Big_String_Ptr (Src); @@ -225,14 +244,14 @@ package body Fmap is -- Exit if end of file has been reached - exit when Deb > Fin; + exit when First > Last; - pragma Assert (Fin >= Deb + 2); - pragma Assert (SP (Fin - 1) = '%'); - pragma Assert (SP (Fin) = 's' or else SP (Fin) = 'b'); + pragma Assert (Last >= First + 2); + pragma Assert (SP (Last - 1) = '%'); + pragma Assert (SP (Last) = 's' or else SP (Last) = 'b'); - Name_Len := Fin - Deb + 1; - Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin); + Name_Len := Last - First + 1; + Name_Buffer (1 .. Name_Len) := SP (First .. Last); Uname := Name_Find; -- Get the file name @@ -241,14 +260,14 @@ package body Fmap is -- If end of line has been reached, file is truncated - if Deb > Fin then + if First > Last then Report_Truncated; Empty_Tables; return; end if; - Name_Len := Fin - Deb + 1; - Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin); + Name_Len := Last - First + 1; + Name_Buffer (1 .. Name_Len) := SP (First .. Last); Fname := Name_Find; -- Get the path name @@ -257,34 +276,48 @@ package body Fmap is -- If end of line has been reached, file is truncated - if Deb > Fin then + if First > Last then Report_Truncated; Empty_Tables; return; end if; - Name_Len := Fin - Deb + 1; - Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin); + Name_Len := Last - First + 1; + Name_Buffer (1 .. Name_Len) := SP (First .. Last); Pname := Name_Find; -- Check for duplicate entries if Unit_Hash_Table.Get (Uname) /= No_Entry then - Write_Str ("warning: duplicate entry """); - Write_Str (Get_Name_String (Uname)); - Write_Str (""" in mapping file """); - Write_Str (File_Name); - Write_Line (""""); + if not Quiet_Output then + Write_Str ("warning: duplicate entry """); + Write_Str (Get_Name_String (Uname)); + Write_Str (""" in mapping file """); + Write_Str (File_Name); + Write_Line (""""); + The_Mapping := + File_Mapping.Table (Unit_Hash_Table.Get (Uname)); + Write_Line (Get_Name_String (The_Mapping.Uname)); + Write_Line (Get_Name_String (The_Mapping.Fname)); + end if; + Empty_Tables; return; end if; if File_Hash_Table.Get (Fname) /= No_Entry then - Write_Str ("warning: duplicate entry """); - Write_Str (Get_Name_String (Fname)); - Write_Str (""" in mapping file """); - Write_Str (File_Name); - Write_Line (""""); + if not Quiet_Output then + Write_Str ("warning: duplicate entry """); + Write_Str (Get_Name_String (Fname)); + Write_Str (""" in mapping file """); + Write_Str (File_Name); + Write_Line (""""); + The_Mapping := + Path_Mapping.Table (File_Hash_Table.Get (Fname)); + Write_Line (Get_Name_String (The_Mapping.Uname)); + Write_Line (Get_Name_String (The_Mapping.Fname)); + end if; + Empty_Tables; return; end if; @@ -294,6 +327,11 @@ package body Fmap is Add_To_File_Map (Uname, Fname, Pname); end loop; end if; + + -- Record the length of the two mapping tables + + Last_In_Table := File_Mapping.Last; + end Initialize; ---------------------- @@ -307,7 +345,7 @@ package body Fmap is if The_Index = No_Entry then return No_File; else - return File_Mapping.Table (The_Index); + return File_Mapping.Table (The_Index).Fname; end if; end Mapped_File_Name; @@ -324,8 +362,83 @@ package body Fmap is if Index = No_Entry then return No_File; else - return Path_Mapping.Table (Index); + return Path_Mapping.Table (Index).Fname; end if; end Mapped_Path_Name; + ------------------------- + -- Update_Mapping_File -- + ------------------------- + + procedure Update_Mapping_File (File_Name : String) is + File : File_Descriptor; + + procedure Put_Line (Name : Name_Id); + -- Put Name as a line in the Mapping File + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (Name : Name_Id) is + N_Bytes : Integer; + begin + Get_Name_String (Name); + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ASCII.LF; + N_Bytes := Write (File, Name_Buffer (1)'Address, Name_Len); + + if N_Bytes < Name_Len then + Fail ("disk full"); + end if; + + end Put_Line; + + -- Start of Update_Mapping_File + + begin + + -- Only Update if there are new entries in the mappings + + if Last_In_Table < File_Mapping.Last then + + -- If the tables have been emptied, recreate the file. + -- Otherwise, append to it. + + if Last_In_Table = 0 then + declare + Discard : Boolean; + + begin + Delete_File (File_Name, Discard); + end; + + File := Create_File (File_Name, Binary); + + else + File := Open_Read_Write (Name => File_Name, Fmode => Binary); + end if; + + if File /= Invalid_FD then + if Last_In_Table > 0 then + Lseek (File, 0, Seek_End); + end if; + + for Unit in Last_In_Table + 1 .. File_Mapping.Last loop + Put_Line (File_Mapping.Table (Unit).Uname); + Put_Line (File_Mapping.Table (Unit).Fname); + Put_Line (Path_Mapping.Table (Unit).Fname); + end loop; + + Close (File); + + elsif not Quiet_Output then + Write_Str ("warning: could not open mapping file """); + Write_Str (File_Name); + Write_Line (""" for update"); + end if; + + end if; + end Update_Mapping_File; + end Fmap; diff --git a/gcc/ada/fmap.ads b/gcc/ada/fmap.ads index 57ea0165165..0e37b9b5c7c 100644 --- a/gcc/ada/fmap.ads +++ b/gcc/ada/fmap.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- -- Copyright (C) 2001, Free Software Foundation, Inc. -- -- -- @@ -37,6 +37,8 @@ package Fmap is -- Initialize the mappings from the mapping file File_Name. -- If the mapping file is incorrect (non existent file, truncated file, -- duplicate entries), output a warning and do not initialize the mappings. + -- Record the state of the mapping tables in case Update is called + -- later on. function Mapped_Path_Name (File : File_Name_Type) return File_Name_Type; -- Return the path name mapped to the file name File. @@ -52,4 +54,10 @@ package Fmap is Path_Name : File_Name_Type); -- Add mapping of Unit_Name to File_Name and of File_Name to Path_Name + procedure Update_Mapping_File (File_Name : String); + -- If Add_To_File_Map has been called (after Initialize or any time + -- if Initialize has not been called), append the new entries to the + -- to the mapping file. + -- What is the significance of the parameter File_Name ??? + end Fmap; diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb index f2b549c3ac6..5f4fb9a22bb 100644 --- a/gcc/ada/fname-uf.adb +++ b/gcc/ada/fname-uf.adb @@ -370,36 +370,43 @@ package body Fname.UF is Fnam := File_Name_Type (Name_Find); - -- If we are in the first search of the table, then - -- we check if the file is present, and only accept - -- the entry if it is indeed present. For the second - -- search, we accept the entry without this check. + -- If we are in the second search of the table, we accept + -- the file name without checking, because we know that + -- the file does not exist. - -- If we only have two entries in the table, then there - -- is no point in seeing if the file exists, since we - -- will end up accepting it anyway on the second search, - -- so just quit and accept it now to save time. - - if No_File_Check or else SFN_Patterns.Last = 2 then + if No_File_Check then return Fnam; - -- Check if file exists and if so, return the entry + -- Otherwise we check if the file exists else Pname := Find_File (Fnam, Source); - -- Check if file exists and if so, return the entry + -- If it does exist, we add it to the mappings and + -- return the file name. if Pname /= No_File then -- Add to mapping, so that we don't do another -- path search in Find_File for this file name + -- and, if we use a mapping file, we are ready + -- to update it at the end of this compilation + -- for the benefit of other compilation processes. Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname); return Fnam; - -- This entry does not match after all, because this is - -- the first search loop, and the file does not exist. + -- If there are only two entries, they are those of + -- the default GNAT naming scheme. The file does + -- not exist, but there is no point doing the + -- second search, because we will end up with the + -- same file name. Just return the file name. + + elsif SFN_Patterns.Last = 2 then + return Fnam; + + -- The file does not exist, but there may be other + -- naming scheme. Keep on searching. else Fnam := No_File; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 55a98104f57..7fe7f8affb3 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -36,6 +36,7 @@ with Exp_Ch11; use Exp_Ch11; with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; with Layout; use Layout; +with Lib.Xref; use Lib.Xref; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; @@ -248,7 +249,18 @@ package body Freeze is end if; if Is_Entity_Name (Nam) then - Call_Name := New_Reference_To (Old_S, Loc); + + -- If the renamed entity is a predefined operator, retain full + -- name to ensure its visibility. + + if Ekind (Old_S) = E_Operator + and then Nkind (Nam) = N_Expanded_Name + then + Call_Name := New_Copy (Name (N)); + else + Call_Name := New_Reference_To (Old_S, Loc); + end if; + else Call_Name := New_Copy (Name (N)); @@ -291,6 +303,8 @@ package body Freeze is -- in the declaration. However, default values that are aggregates -- are rewritten when partially analyzed, so we recover the original -- aggregate to insure that subsequent conformity checking works. + -- Similarly, if the default expression was constant-folded, recover + -- the original expression. Formal := First_Formal (Defining_Entity (Decl)); @@ -308,7 +322,10 @@ package body Freeze is Set_Entity (Parameter_Type (Param_Spec), Etype (O_Formal)); end if; - elsif Nkind (Default_Value (O_Formal)) = N_Aggregate then + elsif Nkind (Default_Value (O_Formal)) = N_Aggregate + or else Nkind (Original_Node (Default_Value (O_Formal))) /= + Nkind (Default_Value (O_Formal)) + then Set_Expression (Param_Spec, New_Copy_Tree (Original_Node (Default_Value (O_Formal)))); end if; @@ -409,9 +426,7 @@ package body Freeze is -- to give a smaller size. function Size_Known (T : Entity_Id) return Boolean; - -- Recursive function that does all the work. - -- Is this right??? isn't recursive case already handled??? - -- certainly yes for normal call, but what about bogus sem_res call??? + -- Recursive function that does all the work function Static_Discriminated_Components (T : Entity_Id) return Boolean; -- If T is a constrained subtype, its size is not known if any of its @@ -468,9 +483,6 @@ package body Freeze is if Size_Known_At_Compile_Time (T) then return True; - elsif Error_Posted (T) then - return False; - elsif Is_Scalar_Type (T) or else Is_Task_Type (T) then @@ -485,6 +497,12 @@ package body Freeze is elsif not Is_Constrained (T) then return False; + -- Don't do any recursion on type with error posted, since + -- we may have a malformed type that leads us into a loop + + elsif Error_Posted (T) then + return False; + elsif not Size_Known (Component_Type (T)) then return False; end if; @@ -541,7 +559,14 @@ package body Freeze is and then not Is_Generic_Type (T) and then Present (Underlying_Type (T)) then - return Size_Known (Underlying_Type (T)); + -- Don't do any recursion on type with error posted, since + -- we may have a malformed type that leads us into a loop + + if Error_Posted (T) then + return False; + else + return Size_Known (Underlying_Type (T)); + end if; elsif Is_Record_Type (T) then if Is_Class_Wide_Type (T) then @@ -551,6 +576,12 @@ package body Freeze is return Size_Known_At_Compile_Time (Base_Type (T)) and then Static_Discriminated_Components (T); + -- Don't do any recursion on type with error posted, since + -- we may have a malformed type that leads us into a loop + + elsif Error_Posted (T) then + return False; + else declare Packed_Size_Known : Boolean := Is_Packed (T); @@ -1218,6 +1249,17 @@ package body Freeze is end if; end; + -- If this is a constrained subtype of an already frozen type, + -- make the subtype frozen as well. It might otherwise be frozen + -- in the wrong scope, and a freeze node on subtype has no effect. + + elsif Is_Access_Type (Etype (Comp)) + and then not Is_Frozen (Designated_Type (Etype (Comp))) + and then Is_Itype (Designated_Type (Etype (Comp))) + and then Is_Frozen (Base_Type (Designated_Type (Etype (Comp)))) + then + Set_Is_Frozen (Designated_Type (Etype (Comp))); + elsif Is_Array_Type (Etype (Comp)) and then Is_Access_Type (Component_Type (Etype (Comp))) and then Present (Parent (Comp)) @@ -1250,9 +1292,11 @@ package body Freeze is if Present (CC) then Placed_Component := True; - if not Size_Known_At_Compile_Time + if Inside_A_Generic then + null; + + elsif not Size_Known_At_Compile_Time (Underlying_Type (Etype (Comp))) - and then not Inside_A_Generic then Error_Msg_N ("component clause not allowed for variable " & @@ -1827,9 +1871,12 @@ package body Freeze is Next_Index (Indx); end loop; - -- For base type, propagate flags for component type + -- Processing that is done only for base types if Ekind (E) = E_Array_Type then + + -- Propagate flags for component type + if Is_Controlled (Component_Type (E)) or else Has_Controlled_Component (Ctyp) then @@ -1839,18 +1886,16 @@ package body Freeze is if Has_Unchecked_Union (Component_Type (E)) then Set_Has_Unchecked_Union (E); end if; - end if; - -- If packing was requested or if the component size was set - -- explicitly, then see if bit packing is required. This - -- processing is only done for base types, since all the - -- representation aspects involved are type-related. This - -- is not just an optimization, if we start processing the - -- subtypes, they intefere with the settings on the base - -- type (this is because Is_Packed has a slightly different - -- meaning before and after freezing). + -- If packing was requested or if the component size was set + -- explicitly, then see if bit packing is required. This + -- processing is only done for base types, since all the + -- representation aspects involved are type-related. This + -- is not just an optimization, if we start processing the + -- subtypes, they intefere with the settings on the base + -- type (this is because Is_Packed has a slightly different + -- meaning before and after freezing). - if E = Base_Type (E) then declare Csiz : Uint; Esiz : Uint; @@ -1939,6 +1984,63 @@ package body Freeze is end if; end if; end; + + -- Processing that is done only for subtypes + + else + -- Acquire alignment from base type + + if Unknown_Alignment (E) then + Set_Alignment (E, Alignment (Base_Type (E))); + end if; + end if; + + -- Check one common case of a size given where the array + -- needs to be packed, but was not so the size cannot be + -- honored. This would of course be caught by the backend, + -- and indeed we don't catch all cases. The point is that + -- we can give a better error message in those cases that + -- we do catch with the circuitry here. + + if Present (Size_Clause (E)) + and then Known_Static_Esize (E) + and then not Has_Pragma_Pack (E) + and then Number_Dimensions (E) = 1 + and then not Has_Component_Size_Clause (E) + and then Known_Static_Component_Size (E) + then + declare + Lo, Hi : Node_Id; + Ctyp : constant Entity_Id := Component_Type (E); + + begin + Get_Index_Bounds (First_Index (E), Lo, Hi); + + if Compile_Time_Known_Value (Lo) + and then Compile_Time_Known_Value (Hi) + and then Known_Static_RM_Size (Ctyp) + and then RM_Size (Ctyp) < 64 + then + declare + Lov : constant Uint := Expr_Value (Lo); + Hiv : constant Uint := Expr_Value (Hi); + Len : constant Uint := + UI_Max (Uint_0, Hiv - Lov + 1); + + begin + if Esize (E) < Len * Component_Size (E) + and then Esize (E) = Len * RM_Size (Ctyp) + then + Error_Msg_NE + ("size given for& too small", + Size_Clause (E), E); + Error_Msg_N + ("\explicit pragma Pack is required", + Size_Clause (E)); + end if; + end; + end if; + end; end if; -- If any of the index types was an enumeration type with @@ -2241,10 +2343,10 @@ package body Freeze is elsif Has_Discriminants (E) and Is_Constrained (E) then - declare Constraint : Elmt_Id; Expr : Node_Id; + begin Constraint := First_Elmt (Discriminant_Constraint (E)); @@ -2285,9 +2387,10 @@ package body Freeze is then declare Prim_List : constant Elist_Id := Primitive_Operations (E); - Prim : Elmt_Id := First_Elmt (Prim_List); + Prim : Elmt_Id; begin + Prim := First_Elmt (Prim_List); while Present (Prim) loop if Convention (Node (Prim)) = Convention_Ada then Set_Convention (Node (Prim), Convention (E)); @@ -2299,6 +2402,43 @@ package body Freeze is end if; end if; + -- Generate primitive operation references for a tagged type + + if Is_Tagged_Type (E) + and then not Is_Class_Wide_Type (E) + then + declare + Prim_List : constant Elist_Id := Primitive_Operations (E); + Prim : Elmt_Id; + Ent : Entity_Id; + + begin + Prim := First_Elmt (Prim_List); + while Present (Prim) loop + Ent := Node (Prim); + + -- If the operation is derived, get the original for + -- cross-reference purposes (it is the original for + -- which we want the xref, and for which the comes + -- from source test needs to be performed). + + while Present (Alias (Ent)) loop + Ent := Alias (Ent); + end loop; + + Generate_Reference (E, Ent, 'p', Set_Ref => False); + Next_Elmt (Prim); + end loop; + + -- If we get an exception, then something peculiar has happened + -- probably as a result of a previous error. Since this is only + -- for non-critical cross-references, ignore the error. + + exception + when others => null; + end; + end if; + -- Now that all types from which E may depend are frozen, see -- if the size is known at compile time, if it must be unsigned, -- or if strict alignent is required @@ -2316,9 +2456,14 @@ package body Freeze is if Has_Size_Clause (E) and then not Size_Known_At_Compile_Time (E) then - Error_Msg_N - ("size clause not allowed for variable length type", - Size_Clause (E)); + -- Supress this message if errors posted on E, even if we are + -- in all errors mode, since this is often a junk message + + if not Error_Posted (E) then + Error_Msg_N + ("size clause not allowed for variable length type", + Size_Clause (E)); + end if; end if; -- Remaining process is to set/verify the representation information, diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index a42626a07ab..d8460d261a1 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -292,13 +292,6 @@ begin -- make sure that all the necessary information is at hand. Exp_Ch11.Generate_Unit_Exception_Table; - - -- Save the unit name and list of packages named in Use_Package - -- clauses for subsequent use in generating a special symbol for - -- the debugger for certain targets that require this. - - Exp_Dbug.Save_Unitname_And_Use_List - (Cunit (Main_Unit), Nkind (Unit (Cunit (Main_Unit)))); end if; -- List library units if requested @@ -328,4 +321,12 @@ begin -- of -gnatD, where it rewrites all source locations in the tree. Sprint.Source_Dump; + + -- If a mapping file has been specified by a -gnatem switch, + -- update it if there has been some sourcs that were not in the mappings. + + if Mapping_File_Name /= null then + Fmap.Update_Mapping_File (Mapping_File_Name.all); + end if; + end Frontend; diff --git a/gcc/ada/g-awk.adb b/gcc/ada/g-awk.adb index 654e11c494c..3a303eea3c0 100644 --- a/gcc/ada/g-awk.adb +++ b/gcc/ada/g-awk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- -- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- -- -- @@ -383,6 +383,8 @@ package body GNAT.AWK is (A : Simple_Action; Session : Session_Type) is + pragma Warnings (Off, Session); + begin A.Proc.all; end Call; @@ -446,6 +448,8 @@ package body GNAT.AWK is Session : Session_Type) return Boolean is + pragma Warnings (Off, Session); + begin return P.Pattern.all; end Match; @@ -455,6 +459,8 @@ package body GNAT.AWK is ------------- procedure Release (P : in out Pattern) is + pragma Warnings (Off, P); + begin null; end Release; @@ -907,14 +913,20 @@ package body GNAT.AWK is Read_Line (Session); Split_Line (Session); - if Callbacks in Only .. Pass_Through then - Filter_Active := Apply_Filters (Session); - end if; + case Callbacks is + + when None => + exit; + + when Only => + Filter_Active := Apply_Filters (Session); + exit when not Filter_Active; - exit when Callbacks = None - or else Callbacks = Pass_Through - or else (Callbacks = Only and then not Filter_Active); + when Pass_Through => + Filter_Active := Apply_Filters (Session); + exit; + end case; end loop; end Get_Line; diff --git a/gcc/ada/g-cgideb.adb b/gcc/ada/g-cgideb.adb index fb4ad490b27..b3a3469cba2 100644 --- a/gcc/ada/g-cgideb.adb +++ b/gcc/ada/g-cgideb.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.3 $ +-- $Revision$ -- -- -- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- -- -- @@ -208,6 +208,8 @@ package body GNAT.CGI.Debug is ------------ function Header (IO : in Format; Str : in String) return String is + pragma Warnings (Off, IO); + begin return "<h2>" & Str & "</h2>" & NL; end Header; @@ -226,6 +228,8 @@ package body GNAT.CGI.Debug is -------------- function New_Line (IO : in Format) return String is + pragma Warnings (Off, IO); + begin return "<br>" & NL; end New_Line; @@ -235,6 +239,8 @@ package body GNAT.CGI.Debug is ----------- function Title (IO : in Format; Str : in String) return String is + pragma Warnings (Off, IO); + begin return "<p align=center><font size=+2>" & Str & "</font></p>" & NL; end Title; @@ -249,6 +255,8 @@ package body GNAT.CGI.Debug is Value : String) return String is + pragma Warnings (Off, IO); + begin return Bold (Name) & " = " & Italic (Value); end Variable; @@ -275,6 +283,8 @@ package body GNAT.CGI.Debug is -------------- function New_Line (IO : in Format) return String is + pragma Warnings (Off, IO); + begin return String'(1 => ASCII.LF); end New_Line; @@ -301,6 +311,8 @@ package body GNAT.CGI.Debug is Value : String) return String is + pragma Warnings (Off, IO); + begin return " " & Name & " = " & Value; end Variable; diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index f2ee9b8a054..16aea3f7330 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.21 $ +-- $Revision$ -- -- --- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1999-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- -- @@ -33,6 +33,7 @@ ------------------------------------------------------------------------------ with Ada.Command_Line; +with GNAT.OS_Lib; use GNAT.OS_Lib; package body GNAT.Command_Line is @@ -41,12 +42,11 @@ package body GNAT.Command_Line is type Section_Number is new Natural range 0 .. 65534; for Section_Number'Size use 16; - type Parameter_Type is - record - Arg_Num : Positive; - First : Positive; - Last : Positive; - end record; + type Parameter_Type is record + Arg_Num : Positive; + First : Positive; + Last : Positive; + end record; The_Parameter : Parameter_Type; The_Switch : Parameter_Type; -- This type and this variable are provided to store the current switch @@ -101,8 +101,39 @@ package body GNAT.Command_Line is -- Go to the next argument on the command line. If we are at the end -- of the current section, we want to make sure there is no other -- identical section on the command line (there might be multiple - -- instances of -largs). - -- Return True if there as another argument, False otherwise + -- instances of -largs). Returns True iff there is another argument. + + function Get_File_Names_Case_Sensitive return Integer; + pragma Import (C, Get_File_Names_Case_Sensitive, + "__gnat_get_file_names_case_sensitive"); + File_Names_Case_Sensitive : constant Boolean := + Get_File_Names_Case_Sensitive /= 0; + + procedure Canonical_Case_File_Name (S : in out String); + -- Given a file name, converts it to canonical case form. For systems + -- where file names are case sensitive, this procedure has no effect. + -- If file names are not case sensitive (i.e. for example if you have + -- the file "xyz.adb", you can refer to it as XYZ.adb or XyZ.AdB), then + -- this call converts the given string to canonical all lower case form, + -- so that two file names compare equal if they refer to the same file. + + ------------------------------ + -- Canonical_Case_File_Name -- + ------------------------------ + + procedure Canonical_Case_File_Name (S : in out String) is + begin + if not File_Names_Case_Sensitive then + for J in S'Range loop + if S (J) in 'A' .. 'Z' then + S (J) := Character'Val ( + Character'Pos (S (J)) + + Character'Pos ('a') - + Character'Pos ('A')); + end if; + end loop; + end if; + end Canonical_Case_File_Name; --------------- -- Expansion -- @@ -116,17 +147,81 @@ package body GNAT.Command_Line is Last : Natural; It : Pointer := Iterator'Unrestricted_Access; + Current : Depth := It.Current_Depth; + NL : Positive; + begin + -- It is assumed that a directory is opened at the current level; + -- otherwise, GNAT.Directory_Operations.Directory_Error will be raised + -- at the first call to Read. + loop - Read (It.Dir, S, Last); + Read (It.Levels (Current).Dir, S, Last); + + -- If we have exhausted the directory, close it and go back one level if Last = 0 then - Close (It.Dir); - return String'(1 .. 0 => ' '); - end if; + Close (It.Levels (Current).Dir); + + -- If we are at level 1, we are finished; return an empty string. + + if Current = 1 then + return String'(1 .. 0 => ' '); + else + -- Otherwise, continue with the directory at the previous level + + Current := Current - 1; + It.Current_Depth := Current; + end if; + + -- If this is a directory, that is neither "." or "..", attempt to + -- go to the next level. + + elsif Is_Directory + (It.Dir_Name (1 .. It.Levels (Current).Name_Last) & S (1 .. Last)) + and then S (1 .. Last) /= "." + and then S (1 .. Last) /= ".." + then + -- We can go to the next level only if we have not reached the + -- maximum depth, + + if Current < It.Maximum_Depth then + NL := It.Levels (Current).Name_Last; + + -- And if relative path of this new directory is not too long + + if NL + Last + 1 < Max_Path_Length then + Current := Current + 1; + It.Current_Depth := Current; + It.Dir_Name (NL + 1 .. NL + Last) := S (1 .. Last); + NL := NL + Last + 1; + It.Dir_Name (NL) := Directory_Separator; + It.Levels (Current).Name_Last := NL; + Canonical_Case_File_Name (It.Dir_Name (1 .. NL)); + + -- Open the new directory, and read from it - if GNAT.Regexp.Match (S (1 .. Last), Iterator.Regexp) then - return S (1 .. Last); + GNAT.Directory_Operations.Open + (It.Levels (Current).Dir, It.Dir_Name (1 .. NL)); + end if; + end if; + + -- If not a directory, check the relative path against the pattern + + else + declare + Name : String := + It.Dir_Name (It.Start .. It.Levels (Current).Name_Last) & + S (1 .. Last); + begin + Canonical_Case_File_Name (Name); + + -- If it matches, return the relative path + + if GNAT.Regexp.Match (Name, Iterator.Regexp) then + return Name; + end if; + end; end if; end loop; @@ -155,13 +250,13 @@ package body GNAT.Command_Line is if In_Expansion then declare S : String := Expansion (Expansion_It); + begin if S'Length /= 0 then return S; else In_Expansion := False; end if; - end; end if; @@ -206,7 +301,7 @@ package body GNAT.Command_Line is Current_Argument := Current_Argument + 1; - -- Could it be a file name with wild cards to expand ? + -- Could it be a file name with wild cards to expand? if Do_Expansion then declare @@ -238,16 +333,16 @@ package body GNAT.Command_Line is ------------ function Getopt (Switches : String) return Character is - Dummy : Boolean; + Dummy : Boolean; begin - -- If we have finished to parse the current command line item (there + -- If we have finished parsing the current command line item (there -- might be multiple switches in a single item), then go to the next -- element if Current_Argument > CL.Argument_Count or else (Current_Index > CL.Argument (Current_Argument)'Last - and then not Goto_Next_Argument_In_Section) + and then not Goto_Next_Argument_In_Section) then return ASCII.NUL; end if; @@ -302,9 +397,10 @@ package body GNAT.Command_Line is Length := Length + 1; end loop; - if (Switches (Length - 1) = ':' - or else Switches (Length - 1) = '?' - or else Switches (Length - 1) = '!') + if (Switches (Length - 1) = ':' or else + Switches (Length - 1) = '=' or else + Switches (Length - 1) = '?' or else + Switches (Length - 1) = '!') and then Length > Index + 1 then Length := Length - 1; @@ -314,8 +410,8 @@ package body GNAT.Command_Line is if Current_Index + Length - 1 - Index <= Arg'Last and then - Switches (Index .. Length - 1) = - Arg (Current_Index .. Current_Index + Length - 1 - Index) + Switches (Index .. Length - 1) = + Arg (Current_Index .. Current_Index + Length - 1 - Index) and then Length - Index > Max_Length then Index_Switches := Index; @@ -323,18 +419,18 @@ package body GNAT.Command_Line is end if; -- Look for the next switch in Switches + while Index <= Switches'Last and then Switches (Index) /= ' ' loop Index := Index + 1; end loop; - Index := Index + 1; + Index := Index + 1; end loop; End_Index := Current_Index + Max_Length - 1; - -- If the switch is not accepted, skip it, unless we had a '*' in - -- Switches + -- If switch is not accepted, skip it, unless we had '*' in Switches if Index_Switches = 0 then if Switches (Switches'First) = '*' then @@ -360,7 +456,7 @@ package body GNAT.Command_Line is First => Current_Index, Last => End_Index); - -- If switch needs an argument + -- Case of switch needs an argument if Index_Switches + Max_Length <= Switches'Last then @@ -390,6 +486,43 @@ package body GNAT.Command_Line is raise Invalid_Parameter; end if; + when '=' => + + -- If the switch is of the form <switch>=xxx + + if End_Index < Arg'Last then + + if Arg (End_Index + 1) = '=' + and then End_Index + 1 < Arg'Last + then + Set_Parameter (The_Parameter, + Arg_Num => Current_Argument, + First => End_Index + 2, + Last => Arg'Last); + Dummy := Goto_Next_Argument_In_Section; + + else + Current_Index := End_Index + 1; + raise Invalid_Parameter; + end if; + + -- If the switch is of the form <switch> xxx + + elsif Section (Current_Argument + 1) /= 0 then + Set_Parameter + (The_Parameter, + Arg_Num => Current_Argument + 1, + First => 1, + Last => CL.Argument (Current_Argument + 1)'Last); + Current_Argument := Current_Argument + 1; + Is_Switch (Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section; + + else + Current_Index := End_Index + 1; + raise Invalid_Parameter; + end if; + when '!' => if End_Index < Arg'Last then @@ -447,6 +580,7 @@ package body GNAT.Command_Line is if Current_Argument > CL.Argument_Count then return False; end if; + Current_Argument := Current_Argument + 1; exit when Section (Current_Argument) = Current_Section; end loop; @@ -478,6 +612,7 @@ package body GNAT.Command_Line is then Current_Argument := Index + 1; Current_Index := 1; + if Current_Argument <= CL.Argument_Count then Current_Section := Section (Current_Argument); end if; @@ -486,6 +621,7 @@ package body GNAT.Command_Line is Index := Index + 1; end loop; + Current_Argument := Positive'Last; Current_Index := 2; -- so that Get_Argument returns nothing end Goto_Section; @@ -529,8 +665,10 @@ package body GNAT.Command_Line is for Index in 1 .. CL.Argument_Count loop if CL.Argument (Index)(1) = Switch_Character - and then CL.Argument (Index) = Switch_Character - & Section_Delimiters (Section_Index .. Last - 1) + and then + CL.Argument (Index) = Switch_Character & + Section_Delimiters + (Section_Index .. Last - 1) then Section (Index) := 0; Delimiter_Found := True; @@ -576,7 +714,8 @@ package body GNAT.Command_Line is (Variable : out Parameter_Type; Arg_Num : Positive; First : Positive; - Last : Positive) is + Last : Positive) + is begin Variable.Arg_Num := Arg_Num; Variable.First := First; @@ -595,16 +734,64 @@ package body GNAT.Command_Line is is Directory_Separator : Character; pragma Import (C, Directory_Separator, "__gnat_dir_separator"); + First : Positive := Pattern'First; + + Pat : String := Pattern; begin + Canonical_Case_File_Name (Pat); + Iterator.Current_Depth := 1; + + -- If Directory is unspecified, use the current directory ("./" or ".\") + if Directory = "" then - GNAT.Directory_Operations.Open - (Iterator.Dir, "." & Directory_Separator); + Iterator.Dir_Name (1 .. 2) := "." & Directory_Separator; + Iterator.Start := 3; + else - GNAT.Directory_Operations.Open (Iterator.Dir, Directory); + Iterator.Dir_Name (1 .. Directory'Length) := Directory; + Iterator.Start := Directory'Length + 1; + Canonical_Case_File_Name (Iterator.Dir_Name (1 .. Directory'Length)); + + -- Make sure that the last character is a directory separator + + if Directory (Directory'Last) /= Directory_Separator then + Iterator.Dir_Name (Iterator.Start) := Directory_Separator; + Iterator.Start := Iterator.Start + 1; + end if; + end if; + + Iterator.Levels (1).Name_Last := Iterator.Start - 1; + + -- Open the initial Directory, at depth 1 + + GNAT.Directory_Operations.Open + (Iterator.Levels (1).Dir, Iterator.Dir_Name (1 .. Iterator.Start - 1)); + + -- If in the current directory and the pattern starts with "./", + -- drop the "./" from the pattern. + + if Directory = "" and then Pat'Length > 2 + and then Pat (Pat'First .. Pat'First + 1) = "./" + then + First := Pat'First + 2; end if; - Iterator.Regexp := GNAT.Regexp.Compile (Pattern, Basic_Regexp, True); + Iterator.Regexp := + GNAT.Regexp.Compile (Pat (First .. Pat'Last), Basic_Regexp, True); + + Iterator.Maximum_Depth := 1; + + -- Maximum_Depth is equal to 1 plus the number of directory separators + -- in the pattern. + + for Index in First .. Pat'Last loop + if Pat (Index) = Directory_Separator then + Iterator.Maximum_Depth := Iterator.Maximum_Depth + 1; + exit when Iterator.Maximum_Depth = Max_Depth; + end if; + end loop; + end Start_Expansion; begin diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads index d2c874e92e5..37f11f15493 100644 --- a/gcc/ada/g-comlin.ads +++ b/gcc/ada/g-comlin.ads @@ -8,7 +8,7 @@ -- -- -- $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- -- @@ -36,19 +36,19 @@ -- This package provides an interface to Ada.Command_Line, to do the -- parsing of command line arguments. Here is a small usage example: --- + -- begin -- loop -- case Getopt ("a b: ad") is -- Accepts '-a', '-ad', or '-b argument' -- when ASCII.NUL => exit; --- + -- when 'a' => -- if Full_Switch = "a" then -- Put_Line ("Got a"); -- else -- Put_Line ("Got ad"); -- end if; --- + -- when 'b' => -- Put_Line ("Got b + " & Parameter); -- @@ -56,11 +56,10 @@ -- raise Program_Error; -- cannot occur! -- end case; -- end loop; --- + -- loop -- declare -- S : constant String := Get_Argument (Do_Expansion => True); - -- begin -- exit when S'Length = 0; -- Put_Line ("Got " & S); @@ -71,27 +70,27 @@ -- when Invalid_Switch => Put_Line ("Invalid Switch " & Full_Switch); -- when Invalid_Parameter => Put_Line ("No parameter for " & Full_Switch); -- end; --- + -- A more complicated example would involve the use of sections for the -- switches, as for instance in gnatmake. These sections are separated by -- special switches, chosen by the programer. Each section act as a -- command line of its own. --- + -- begin -- Initialize_Option_Scan ('-', False, "largs bargs cargs"); -- loop --- -- same loop as above to get switches and arguments +-- -- Same loop as above to get switches and arguments -- end loop; --- + -- Goto_Section ("bargs"); -- loop --- -- same loop as above to get switches and arguments +-- -- Same loop as above to get switches and arguments -- -- The supports switches in Get_Opt might be different -- end loop; --- + -- Goto_Section ("cargs"); -- loop --- -- same loop as above to get switches and arguments +-- -- Same loop as above to get switches and arguments -- -- The supports switches in Get_Opt might be different -- end loop; -- end; @@ -161,6 +160,8 @@ package GNAT.Command_Line is -- -- ':' The switch requires a parameter. There can optionally be a space -- on the command line between the switch and its parameter + -- '=' The switch requires a parameter. There can either be a '=' or a + -- space on the command line between the switch and its parameter -- '!' The switch requires a parameter, but there can be no space on the -- command line between the switch and its parameter -- '?' The switch may have an optional parameter. There can no space @@ -238,16 +239,27 @@ package GNAT.Command_Line is Pattern : String; Directory : String := ""; Basic_Regexp : Boolean := True); - -- Initialize an wild card expansion. The next calls to Expansion will + -- Initialize a wild card expansion. The next calls to Expansion will -- return the next file name in Directory which match Pattern (Pattern -- is a regular expression, using only the Unix shell and DOS syntax if - -- Basic_Regexp is True. When Directory is an empty string, the current + -- Basic_Regexp is True). When Directory is an empty string, the current -- directory is searched. + -- + -- Pattern may contains directory separators (as in "src/*/*.ada"). + -- Subdirectories of Directory will also be searched, up to one + -- hundred levels deep. + -- + -- When Start_Expansion has been called, function Expansion should be + -- called repetitively until it returns an empty string, before + -- Start_Expansion can be called again with the same Expansion_Iterator + -- variable. function Expansion (Iterator : Expansion_Iterator) return String; -- Return the next file in the directory matching the parameters given -- to Start_Expansion and updates Iterator to point to the next entry. - -- Returns an empty string when there are no more files in the directory. + -- Returns an empty string when there are no more files in the directory + -- and its subdirectories. + -- -- If Expansion is called again after an empty string has been returned, -- then the exception GNAT.Directory_Operations.Directory_Error is raised. @@ -263,9 +275,39 @@ package GNAT.Command_Line is private + Max_Depth : constant := 100; + -- Maximum depth of subdirectories + + Max_Path_Length : constant := 1024; + -- Maximum length of relative path + + type Depth is range 1 .. Max_Depth; + + type Level is record + Name_Last : Natural := 0; + Dir : GNAT.Directory_Operations.Dir_Type; + end record; + + type Level_Array is array (Depth) of Level; + type Expansion_Iterator is limited record - Dir : GNAT.Directory_Operations.Dir_Type; + Start : Positive := 1; + -- Position of the first character of the relative path to check + -- against the pattern. + + Dir_Name : String (1 .. Max_Path_Length); + + Current_Depth : Depth := 1; + + Levels : Level_Array; + Regexp : GNAT.Regexp.Regexp; + -- Regular expression built with the pattern + + Maximum_Depth : Depth := 1; + -- The maximum depth of directories, reflecting the number of + -- directory separators in the pattern. + end record; end GNAT.Command_Line; diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index d3d2e7468f8..f4e779ad455 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.14 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -68,7 +68,10 @@ package body GNAT.Debug_Pools is (Pool : in out Debug_Pool; Storage_Address : out Address; Size_In_Storage_Elements : Storage_Count; - Alignment : Storage_Count) is + Alignment : Storage_Count) + is + pragma Warnings (Off, Alignment); + begin Storage_Address := Alloc (size_t (Size_In_Storage_Elements)); @@ -94,8 +97,10 @@ package body GNAT.Debug_Pools is Size_In_Storage_Elements : Storage_Count; Alignment : Storage_Count) is + pragma Warnings (Off, Alignment); + procedure Free (Address : System.Address; Siz : Storage_Count); - -- Faked free, that reset all the deallocated storage to "DEADBEEF" + -- Fake free, that resets all the deallocated storage to "DEADBEEF" procedure Free (Address : System.Address; Siz : Storage_Count) is DB1 : constant Integer := 16#DEAD#; @@ -151,6 +156,10 @@ package body GNAT.Debug_Pools is Size_In_Storage_Elements : Storage_Count; Alignment : Storage_Count) is + pragma Warnings (Off, Pool); + pragma Warnings (Off, Size_In_Storage_Elements); + pragma Warnings (Off, Alignment); + S : State := Table.Get (Storage_Address); Max_Dim : constant := 3; Dim : Integer := 1; @@ -216,6 +225,8 @@ package body GNAT.Debug_Pools is ------------------ function Storage_Size (Pool : Debug_Pool) return Storage_Count is + pragma Warnings (Off, Pool); + begin return Storage_Count'Last; end Storage_Size; diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb index 38fd69593b1..8c26c63107e 100644 --- a/gcc/ada/g-dirope.adb +++ b/gcc/ada/g-dirope.adb @@ -460,6 +460,45 @@ package body GNAT.Directory_Operations is end File_Name; --------------------- + -- Format_Pathname -- + --------------------- + + function Format_Pathname + (Path : Path_Name; + Style : Path_Style := System_Default) + return String + is + N_Path : String := Path; + K : Positive := N_Path'First; + Prev_Dirsep : Boolean := False; + + begin + for J in Path'Range loop + + if Strings.Maps.Is_In (Path (J), Dir_Seps) then + if not Prev_Dirsep then + case Style is + when UNIX => N_Path (K) := '/'; + when DOS => N_Path (K) := '\'; + when System_Default => N_Path (K) := Dir_Separator; + end case; + + K := K + 1; + end if; + + Prev_Dirsep := True; + + else + N_Path (K) := Path (J); + K := K + 1; + Prev_Dirsep := False; + end if; + end loop; + + return N_Path (N_Path'First .. K - 1); + end Format_Pathname; + + --------------------- -- Get_Current_Dir -- --------------------- @@ -522,46 +561,6 @@ package body GNAT.Directory_Operations is end if; end Make_Dir; - ------------------------ - -- Normalize_Pathname -- - ------------------------ - - function Normalize_Pathname - (Path : Path_Name; - Style : Path_Style := System_Default) - return String - is - N_Path : String := Path; - K : Positive := N_Path'First; - Prev_Dirsep : Boolean := False; - - begin - for J in Path'Range loop - - if Strings.Maps.Is_In (Path (J), Dir_Seps) then - if not Prev_Dirsep then - - case Style is - when UNIX => N_Path (K) := '/'; - when DOS => N_Path (K) := '\'; - when System_Default => N_Path (K) := Dir_Separator; - end case; - - K := K + 1; - end if; - - Prev_Dirsep := True; - - else - N_Path (K) := Path (J); - K := K + 1; - Prev_Dirsep := False; - end if; - end loop; - - return N_Path (N_Path'First .. K - 1); - end Normalize_Pathname; - ---------- -- Open -- ---------- diff --git a/gcc/ada/g-dirope.ads b/gcc/ada/g-dirope.ads index 6e0e988d090..62308a674b1 100644 --- a/gcc/ada/g-dirope.ads +++ b/gcc/ada/g-dirope.ads @@ -136,7 +136,7 @@ package GNAT.Directory_Operations is type Path_Style is (UNIX, DOS, System_Default); - function Normalize_Pathname + function Format_Pathname (Path : Path_Name; Style : Path_Style := System_Default) return Path_Name; diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb index 02c1bc19636..d788f9257bd 100644 --- a/gcc/ada/g-dyntab.adb +++ b/gcc/ada/g-dyntab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.4 $ +-- $Revision$ -- -- -- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- -- -- @@ -32,15 +32,15 @@ -- -- ------------------------------------------------------------------------------ -with System; use System; +with System; use System; +with System.Memory; use System.Memory; +with System.Address_To_Access_Conversions; package body GNAT.Dynamic_Tables is Min : constant Integer := Integer (Table_Low_Bound); -- Subscript of the minimum entry in the currently allocated table - type size_t is new Integer; - ----------------------- -- Local Subprograms -- ----------------------- @@ -50,6 +50,18 @@ package body GNAT.Dynamic_Tables is -- in Max. Works correctly to do an initial allocation if the table -- is currently null. + package Table_Conversions is + new System.Address_To_Access_Conversions (Big_Table_Type); + -- Address and Access conversions for a Table object. + + function To_Address (Table : Table_Ptr) return Address; + pragma Inline (To_Address); + -- Returns the Address for the Table object. + + function To_Pointer (Table : Address) return Table_Ptr; + pragma Inline (To_Pointer); + -- Returns the Access pointer for the Table object. + -------------- -- Allocate -- -------------- @@ -90,11 +102,8 @@ package body GNAT.Dynamic_Tables is ---------- procedure Free (T : in out Instance) is - procedure free (T : Table_Ptr); - pragma Import (C, free); - begin - free (T.Table); + Free (To_Address (T.Table)); T.Table := null; T.P.Length := 0; end Free; @@ -155,18 +164,6 @@ package body GNAT.Dynamic_Tables is ---------------- procedure Reallocate (T : in out Instance) is - - function realloc - (memblock : Table_Ptr; - size : size_t) - return Table_Ptr; - pragma Import (C, realloc); - - function malloc - (size : size_t) - return Table_Ptr; - pragma Import (C, malloc); - New_Size : size_t; begin @@ -182,13 +179,12 @@ package body GNAT.Dynamic_Tables is (Table_Type'Component_Size / Storage_Unit)); if T.Table = null then - T.Table := malloc (New_Size); + T.Table := To_Pointer (Alloc (New_Size)); elsif New_Size > 0 then T.Table := - realloc - (memblock => T.Table, - size => New_Size); + To_Pointer (Realloc (Ptr => To_Address (T.Table), + Size => New_Size)); end if; if T.P.Length /= 0 and then T.Table = null then @@ -243,4 +239,23 @@ package body GNAT.Dynamic_Tables is end if; end Set_Last; + ---------------- + -- To_Address -- + ---------------- + + function To_Address (Table : Table_Ptr) return Address is + begin + return Table_Conversions.To_Address + (Table_Conversions.Object_Pointer (Table)); + end To_Address; + + ---------------- + -- To_Pointer -- + ---------------- + + function To_Pointer (Table : Address) return Table_Ptr is + begin + return Table_Ptr (Table_Conversions.To_Pointer (Table)); + end To_Pointer; + end GNAT.Dynamic_Tables; diff --git a/gcc/ada/g-enblsp.adb b/gcc/ada/g-enblsp.adb new file mode 100644 index 00000000000..cec401f3207 --- /dev/null +++ b/gcc/ada/g-enblsp.adb @@ -0,0 +1,117 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . E X P E C T . N O N _ B L O C K I N G _ S P A W N -- +-- -- +-- B o d y -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 2002 Ada Core Technologies, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default version. Used everywhere except VMS. + +separate (GNAT.Expect) +procedure Non_Blocking_Spawn + (Descriptor : out Process_Descriptor'Class; + Command : String; + Args : GNAT.OS_Lib.Argument_List; + Buffer_Size : Natural := 4096; + Err_To_Out : Boolean := False) +is + function Fork return Process_Id; + pragma Import (C, Fork, "__gnat_expect_fork"); + -- Starts a new process if possible. + -- See the Unix command fork for more information. On systems that + -- don't support this capability (Windows...), this command does + -- nothing, and Fork will return Null_Pid. + + Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; + + Arg : String_Access; + Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; + + Command_With_Path : String_Access; + +begin + -- Create the rest of the pipes + + Set_Up_Communications + (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); + + -- Fork a new process + + Descriptor.Pid := Fork; + + -- Are we now in the child (or, for Windows, still in the common + -- process). + + if Descriptor.Pid = Null_Pid then + + Command_With_Path := Locate_Exec_On_Path (Command); + + -- Prepare an array of arguments to pass to C + Arg := new String (1 .. Command_With_Path'Length + 1); + Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; + Arg (Arg'Last) := ASCII.Nul; + Arg_List (1) := Arg.all'Address; + + for J in Args'Range loop + Arg := new String (1 .. Args (J)'Length + 1); + Arg (1 .. Args (J)'Length) := Args (J).all; + Arg (Arg'Last) := ASCII.Nul; + Arg_List (J + 2 - Args'First) := Arg.all'Address; + end loop; + + Arg_List (Arg_List'Last) := System.Null_Address; + + -- This does not return on Unix systems + + Set_Up_Child_Communications + (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, + Arg_List'Address); + + Free (Command_With_Path); + end if; + + -- Did we have an error when spawning the child ? + + if Descriptor.Pid < Null_Pid then + null; + else + -- We are now in the parent process + + Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); + end if; + + -- Create the buffer + + Descriptor.Buffer_Size := Buffer_Size; + + if Buffer_Size /= 0 then + Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); + end if; +end Non_Blocking_Spawn; diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb index 651b6201483..e114cd94c20 100644 --- a/gcc/ada/g-expect.adb +++ b/gcc/ada/g-expect.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.7 $ +-- $Revision$ -- -- --- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 2000-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- -- @@ -32,19 +32,17 @@ -- -- ------------------------------------------------------------------------------ +with System; use System; +with Ada.Calendar; use Ada.Calendar; + with GNAT.IO; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Regpat; use GNAT.Regpat; -with System; use System; -with Unchecked_Conversion; + with Unchecked_Deallocation; -with Ada.Calendar; use Ada.Calendar; package body GNAT.Expect is - function To_Pid is new - Unchecked_Conversion (OS_Lib.Process_Id, Process_Id); - type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access; procedure Expect_Internal @@ -96,9 +94,10 @@ package body GNAT.Expect is pragma Import (C, Create_Pipe, "__gnat_pipe"); function Read - (Fd : File_Descriptor; - A : System.Address; - N : Integer) return Integer; + (Fd : File_Descriptor; + A : System.Address; + N : Integer) + return Integer; pragma Import (C, Read, "read"); -- Read N bytes to address A from file referenced by FD. Returned value -- is count of bytes actually read, which can be less than N at EOF. @@ -108,9 +107,10 @@ package body GNAT.Expect is -- Close a file given its file descriptor. function Write - (Fd : File_Descriptor; - A : System.Address; - N : Integer) return Integer; + (Fd : File_Descriptor; + A : System.Address; + N : Integer) + return Integer; pragma Import (C, Write, "write"); -- Read N bytes to address A from file referenced by FD. Returned value -- is count of bytes actually read, which can be less than N at EOF. @@ -128,6 +128,10 @@ package body GNAT.Expect is -- -- Out_Is_Set is set to 1 if data was available, 0 otherwise. + function Waitpid (Pid : Process_Id) return Integer; + pragma Import (C, Waitpid, "__gnat_waitpid"); + -- Wait for a specific process id, and return its exit code. + --------- -- "+" -- --------- @@ -171,8 +175,8 @@ package body GNAT.Expect is if Current = null then Descriptor.Filters := new Filter_List_Elem' - (Filter => Filter, Filter_On => Filter_On, - User_Data => User_Data, Next => null); + (Filter => Filter, Filter_On => Filter_On, + User_Data => User_Data, Next => null); else Current.Next := new Filter_List_Elem' @@ -218,10 +222,10 @@ package body GNAT.Expect is -- Close -- ----------- - procedure Close (Descriptor : in out Process_Descriptor) is - Success : Boolean; - Pid : OS_Lib.Process_Id; - + procedure Close + (Descriptor : in out Process_Descriptor; + Status : out Integer) + is begin Close (Descriptor.Input_Fd); @@ -231,14 +235,19 @@ package body GNAT.Expect is Close (Descriptor.Output_Fd); - -- ??? Should have timeouts for different signals, see ddd + -- ??? Should have timeouts for different signals Kill (Descriptor.Pid, 9); GNAT.OS_Lib.Free (Descriptor.Buffer); Descriptor.Buffer_Size := 0; - Wait_Process (Pid, Success); - Descriptor.Pid := To_Pid (Pid); + Status := Waitpid (Descriptor.Pid); + end Close; + + procedure Close (Descriptor : in out Process_Descriptor) is + Status : Integer; + begin + Close (Descriptor, Status); end Close; ------------ @@ -545,7 +554,7 @@ package body GNAT.Expect is Num_Descriptors : Integer; Buffer_Size : Integer := 0; - N : Integer; + N : Integer; type File_Descriptor_Array is array (Descriptors'Range) of File_Descriptor; @@ -849,79 +858,7 @@ package body GNAT.Expect is Buffer_Size : Natural := 4096; Err_To_Out : Boolean := False) is - function Fork return Process_Id; - pragma Import (C, Fork, "__gnat_expect_fork"); - -- Starts a new process if possible. - -- See the Unix command fork for more information. On systems that - -- don't support this capability (Windows...), this command does - -- nothing, and Fork will return Null_Pid. - - Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; - - Arg : String_Access; - Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; - - Command_With_Path : String_Access; - - begin - -- Create the rest of the pipes - - Set_Up_Communications - (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); - - -- Fork a new process - - Descriptor.Pid := Fork; - - -- Are we now in the child (or, for Windows, still in the common - -- process). - - if Descriptor.Pid = Null_Pid then - - Command_With_Path := Locate_Exec_On_Path (Command); - - -- Prepare an array of arguments to pass to C - Arg := new String (1 .. Command_With_Path'Length + 1); - Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; - Arg (Arg'Last) := ASCII.Nul; - Arg_List (1) := Arg.all'Address; - - for J in Args'Range loop - Arg := new String (1 .. Args (J)'Length + 1); - Arg (1 .. Args (J)'Length) := Args (J).all; - Arg (Arg'Last) := ASCII.Nul; - Arg_List (J + 2 - Args'First) := Arg.all'Address; - end loop; - - Arg_List (Arg_List'Last) := System.Null_Address; - - -- This does not return on Unix systems - - Set_Up_Child_Communications - (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, - Arg_List'Address); - - Free (Command_With_Path); - end if; - - -- Did we have an error when spawning the child ? - - if Descriptor.Pid < Null_Pid then - null; - else - -- We are now in the parent process - - Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); - end if; - - -- Create the buffer - - Descriptor.Buffer_Size := Buffer_Size; - - if Buffer_Size /= 0 then - Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); - end if; - end Non_Blocking_Spawn; + separate; ------------------------- -- Reinitialize_Buffer -- @@ -1061,7 +998,11 @@ package body GNAT.Expect is Cmd : in String; Args : in System.Address) is - Input, Output, Error : File_Descriptor; + pragma Warnings (Off, Pid); + + Input : File_Descriptor; + Output : File_Descriptor; + Error : File_Descriptor; begin -- Since Windows does not have a separate fork/exec, we need to @@ -1084,7 +1025,7 @@ package body GNAT.Expect is Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); - Portable_Execvp (Cmd & ASCII.Nul, Args); + Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.Nul, Args); -- The following commands are not executed on Unix systems, and are -- only required for Windows systems. We are now in the parent process. @@ -1108,7 +1049,8 @@ package body GNAT.Expect is Err_To_Out : Boolean; Pipe1 : access Pipe_Type; Pipe2 : access Pipe_Type; - Pipe3 : access Pipe_Type) is + Pipe3 : access Pipe_Type) + is begin -- Create the pipes @@ -1144,6 +1086,8 @@ package body GNAT.Expect is Pipe2 : in out Pipe_Type; Pipe3 : in out Pipe_Type) is + pragma Warnings (Off, Pid); + begin Close (Pipe1.Input); Close (Pipe2.Output); @@ -1159,6 +1103,9 @@ package body GNAT.Expect is Str : String; User_Data : System.Address := System.Null_Address) is + pragma Warnings (Off, Descriptor); + pragma Warnings (Off, User_Data); + begin GNAT.IO.Put (Str); end Trace_Filter; diff --git a/gcc/ada/g-expect.ads b/gcc/ada/g-expect.ads index d4295afe9df..e1b0daaa7c7 100644 --- a/gcc/ada/g-expect.ads +++ b/gcc/ada/g-expect.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- --- Copyright (C) 2000-2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 2000-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- -- @@ -48,7 +48,9 @@ -- -- Usage example: -- --- Non_Blocking_Spawn (Fd, "ftp machine@domaine"); +-- Non_Blocking_Spawn +-- (Fd, "ftp", +-- (1 => new String' ("machine@domaine"))); -- Timeout := 10000; -- 10 seconds -- Expect (Fd, Result, Regexp_Array'(+"\(user\)", +"\(passwd\)"), -- Timeout); @@ -78,12 +80,18 @@ -- processes, where you can give your own input and output filters every -- time characters are read from or written to the process. -- --- procedure My_Filter (Descriptor : Process_Descriptor; Str : String) is +-- procedure My_Filter +-- (Descriptor : Process_Descriptor'Class; +-- Str : String; +-- User_Data : System.Address) +-- is -- begin -- Put_Line (Str); -- end; -- --- Fd := Non_Blocking_Spawn ("tail -f a_file"); +-- Non_Blocking_Spawn +-- (Fd, "tail", +-- (new String' ("-f"), new String' ("a_file"))); -- Add_Filter (Fd, My_Filter'Access, Output); -- Expect (Fd, Result, "", 0); -- wait forever -- @@ -98,8 +106,9 @@ -- existing output, it is recommended to do something like: -- -- Expect (Fd, Result, ".*", Timeout => 0); --- -- empty the buffer, by matching everything (after checking --- -- if there was any input). +-- -- Empty the buffer, by matching everything (after checking +-- -- if there was any input). +-- -- Send (Fd, "command"); -- Expect (Fd, Result, ".."); -- match only on the output of command -- @@ -179,6 +188,12 @@ package GNAT.Expect is -- does the 'wait' command required to clean up the process table. -- This also frees the buffer associated with the process id. + procedure Close + (Descriptor : in out Process_Descriptor; + Status : out Integer); + -- Same as above, but also returns the exit status of the process, + -- as set for example by the procedure GNAT.OS_Lib.OS_Exit. + procedure Send_Signal (Descriptor : Process_Descriptor; Signal : Integer); @@ -510,20 +525,6 @@ package GNAT.Expect is -- valid process that died while Expect was executing. It is also raised -- when Expect receives an end-of-file. - ------------------------ - -- Internal functions -- - ------------------------ - - -- The following subprograms are provided so that it is easy to write - -- extensions to this package. However, clients should not use these - -- routines directly. - - procedure Portable_Execvp (Cmd : String; Args : System.Address); - -- Executes, in a portable way, the command Cmd (full path must be - -- specified), with the given Args. Note that the first element in Args - -- must be the executable name, and the last element must be a null - -- pointer - private type Filter_List_Elem; type Filter_List is access Filter_List_Elem; @@ -568,7 +569,7 @@ private -- newly created process. type Process_Descriptor is tagged record - Pid : Process_Id := Invalid_Pid; + Pid : aliased Process_Id := Invalid_Pid; Input_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; Output_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; Error_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; @@ -584,6 +585,18 @@ private Last_Match_End : Natural := 0; end record; + -- The following subprogram is provided for use in the body, and also + -- possibly in future child units providing extensions to this package. + + procedure Portable_Execvp + (Pid : access Process_Id; + Cmd : String; + Args : System.Address); pragma Import (C, Portable_Execvp, "__gnat_expect_portable_execvp"); + -- Executes, in a portable way, the command Cmd (full path must be + -- specified), with the given Args. Args must be an array of string + -- pointers. Note that the first element in Args must be the executable + -- name, and the last element must be a null pointer. The returned value + -- in Pid is the process ID, or zero if not supported on the platform. end GNAT.Expect; diff --git a/gcc/ada/g-io.ads b/gcc/ada/g-io.ads index 9b91406e864..1d3b285572b 100644 --- a/gcc/ada/g-io.ads +++ b/gcc/ada/g-io.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.10 $ +-- $Revision$ -- -- -- Copyright (C) 1995-2001 Ada Core Technologies, Inc. -- -- -- @@ -36,10 +36,10 @@ -- A simple text I/O package that can be used for simple I/O functions in -- user programs as required. This package is also preelaborated, unlike --- Text_Io, and can thus be with'ed by preelaborated library units. +-- Text_IO, and can thus be with'ed by preelaborated library units. -- Note that Data_Error is not raised by these subprograms for bad data. --- If such checks are needed then the regular Text_IO package such be used. +-- If such checks are needed then the regular Text_IO package must be used. package GNAT.IO is pragma Preelaborate (IO); diff --git a/gcc/ada/g-io_aux.adb b/gcc/ada/g-io_aux.adb index 95afbc548a2..27d78d9dd2c 100644 --- a/gcc/ada/g-io_aux.adb +++ b/gcc/ada/g-io_aux.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.7 $ +-- $Revision$ -- -- -- --- Copyright (C) 1995-2000 Ada Core Technologies, Inc. -- +-- Copyright (C) 1995-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- -- diff --git a/gcc/ada/g-io_aux.ads b/gcc/ada/g-io_aux.ads index 379d84abdf7..f6d1ce29d64 100644 --- a/gcc/ada/g-io_aux.ads +++ b/gcc/ada/g-io_aux.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.5 $ -- +-- $Revision$ -- -- -- --- Copyright (C) 1995-1998 Ada Core Technologies, Inc. -- +-- Copyright (C) 1995-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- -- diff --git a/gcc/ada/g-locfil.adb b/gcc/ada/g-locfil.adb index 3f263f7b654..ced160c7f97 100644 --- a/gcc/ada/g-locfil.adb +++ b/gcc/ada/g-locfil.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.4 $ +-- $Revision$ -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- @@ -44,8 +44,8 @@ package body GNAT.Lock_Files is --------------- procedure Lock_File - (Directory : String; - Lock_File_Name : String; + (Directory : Path_Name; + Lock_File_Name : Path_Name; Wait : Duration := 1.0; Retries : Natural := Natural'Last) is @@ -56,13 +56,26 @@ package body GNAT.Lock_Files is pragma Import (C, Try_Lock, "__gnat_try_lock"); begin + -- If a directory separator was provided, just remove the one we have + -- added above. + + if Directory (Directory'Last) = Dir_Separator + or else Directory (Directory'Last) = '/' + then + Dir (Dir'Last - 1) := ASCII.Nul; + end if; + + -- Try to lock the file Retries times + for I in 0 .. Retries loop if Try_Lock (Dir'Address, File'Address) = 1 then return; end if; + exit when I = Retries; delay Wait; end loop; + raise Lock_Error; end Lock_File; @@ -71,13 +84,15 @@ package body GNAT.Lock_Files is --------------- procedure Lock_File - (Lock_File_Name : String; + (Lock_File_Name : Path_Name; Wait : Duration := 1.0; Retries : Natural := Natural'Last) is begin for J in reverse Lock_File_Name'Range loop - if Lock_File_Name (J) = Dir_Separator then + if Lock_File_Name (J) = Dir_Separator + or else Lock_File_Name (J) = '/' + then Lock_File (Lock_File_Name (Lock_File_Name'First .. J - 1), Lock_File_Name (J + 1 .. Lock_File_Name'Last), @@ -94,7 +109,7 @@ package body GNAT.Lock_Files is -- Unlock_File -- ----------------- - procedure Unlock_File (Lock_File_Name : String) is + procedure Unlock_File (Lock_File_Name : Path_Name) is S : aliased String := Lock_File_Name & ASCII.NUL; procedure unlink (A : System.Address); @@ -108,9 +123,15 @@ package body GNAT.Lock_Files is -- Unlock_File -- ----------------- - procedure Unlock_File (Directory : String; Lock_File_Name : String) is + procedure Unlock_File (Directory : Path_Name; Lock_File_Name : Path_Name) is begin - Unlock_File (Directory & Dir_Separator & Lock_File_Name); + if Directory (Directory'Last) = Dir_Separator + or else Directory (Directory'Last) = '/' + then + Unlock_File (Directory & Lock_File_Name); + else + Unlock_File (Directory & Dir_Separator & Lock_File_Name); + end if; end Unlock_File; end GNAT.Lock_Files; diff --git a/gcc/ada/g-locfil.ads b/gcc/ada/g-locfil.ads index 47715c69bee..1034252548e 100644 --- a/gcc/ada/g-locfil.ads +++ b/gcc/ada/g-locfil.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- -- Copyright (C) 1995-2001 Ada Core Technologies, Inc. -- -- -- @@ -32,8 +32,8 @@ -- -- ------------------------------------------------------------------------------ - -- This package contains the necessary routines for using files for the - -- purpose of providing realiable system wide locking capability. +-- This package contains the necessary routines for using files for the +-- purpose of providing realiable system wide locking capability. package GNAT.Lock_Files is pragma Preelaborate; @@ -41,27 +41,35 @@ pragma Preelaborate; Lock_Error : exception; -- Exception raised if file cannot be locked + subtype Path_Name is String; + -- Pathname is used by all services provided in this unit to specified + -- directory name and file name. On DOS based systems both directory + -- separators are handled (i.e. slash and backslash). + procedure Lock_File - (Directory : String; - Lock_File_Name : String; + (Directory : Path_Name; + Lock_File_Name : Path_Name; Wait : Duration := 1.0; Retries : Natural := Natural'Last); -- Create a lock file Lock_File_Name in directory Directory. If the file -- cannot be locked because someone already owns the lock, this procedure -- waits Wait seconds and retries at most Retries times. If the file -- still cannot be locked, Lock_Error is raised. The default is to try - -- every second, almost forever (Natural'Last times). + -- every second, almost forever (Natural'Last times). The full path of + -- the file is constructed by concatenating Directory and Lock_File_Name. + -- Directory can optionally terminate with a directory separator. procedure Lock_File - (Lock_File_Name : String; + (Lock_File_Name : Path_Name; Wait : Duration := 1.0; Retries : Natural := Natural'Last); -- See above. The full lock file path is given as one string. - procedure Unlock_File (Directory : String; Lock_File_Name : String); - -- Unlock a file + procedure Unlock_File (Directory : Path_Name; Lock_File_Name : Path_Name); + -- Unlock a file. Directory can optionally terminate with a directory + -- separator. - procedure Unlock_File (Lock_File_Name : String); + procedure Unlock_File (Lock_File_Name : Path_Name); -- Unlock a file whose full path is given in Lock_File_Name end GNAT.Lock_Files; diff --git a/gcc/ada/g-md5.adb b/gcc/ada/g-md5.adb new file mode 100644 index 00000000000..d5ca09058b2 --- /dev/null +++ b/gcc/ada/g-md5.adb @@ -0,0 +1,551 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . M D 5 -- +-- -- +-- B o d y -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 2002 Ada Core Technologies, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body GNAT.MD5 is + + use Interfaces; + + Padding : constant String := + (1 => Character'Val (16#80#), 2 .. 64 => ASCII.NUL); + + Hex_Digit : constant array (Unsigned_32 range 0 .. 15) of Character := + ('0', '1', '2', '3', '4', '5', '6', '7', + '8', '9', 'a', 'b', 'c', 'd', 'e', 'f'); + -- Look-up table for each hex digit of the Message-Digest. + -- Used by function Digest (Context). + + -- The sixten values used to rotate the context words. + -- Four for each rounds. Used in procedure Transform. + + -- Round 1 + + S11 : constant := 7; + S12 : constant := 12; + S13 : constant := 17; + S14 : constant := 22; + + -- Round 2 + + S21 : constant := 5; + S22 : constant := 9; + S23 : constant := 14; + S24 : constant := 20; + + -- Round 3 + + S31 : constant := 4; + S32 : constant := 11; + S33 : constant := 16; + S34 : constant := 23; + + -- Round 4 + + S41 : constant := 6; + S42 : constant := 10; + S43 : constant := 15; + S44 : constant := 21; + + type Sixteen_Words is array (Natural range 0 .. 15) + of Interfaces.Unsigned_32; + -- Sixteen 32-bit words, converted from block of 64 characters. + -- Used in procedure Decode and Transform. + + procedure Decode + (Block : String; + X : out Sixteen_Words); + -- Convert a String of 64 characters into 16 32-bit numbers + + -- The following functions (F, FF, G, GG, H, HH, I and II) are the + -- equivalent of the macros of the same name in the example + -- C implementation in the annex of RFC 1321. + + function F (X, Y, Z : Unsigned_32) return Unsigned_32; + pragma Inline (F); + + procedure FF + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive); + pragma Inline (FF); + + function G (X, Y, Z : Unsigned_32) return Unsigned_32; + pragma Inline (G); + + procedure GG + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive); + pragma Inline (GG); + + function H (X, Y, Z : Unsigned_32) return Unsigned_32; + pragma Inline (H); + + procedure HH + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive); + pragma Inline (HH); + + function I (X, Y, Z : Unsigned_32) return Unsigned_32; + pragma Inline (I); + + procedure II + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive); + pragma Inline (II); + + procedure Transform + (C : in out Context; + Block : String); + -- Process one block of 64 characters. + + ------------ + -- Decode -- + ------------ + + procedure Decode + (Block : String; + X : out Sixteen_Words) + is + Cur : Positive := Block'First; + + begin + pragma Assert (Block'Length = 64); + + for Index in X'Range loop + X (Index) := + Unsigned_32 (Character'Pos (Block (Cur))) + + Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 1))), 8) + + Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 2))), 16) + + Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 3))), 24); + Cur := Cur + 4; + end loop; + end Decode; + + ------------ + -- Digest -- + ------------ + + function Digest (C : Context) return Message_Digest is + Result : Message_Digest; + + Cur : Natural := 1; + -- Index in Result where the next character will be placed. + + procedure Convert (X : Unsigned_32); + -- Put the contribution of one of the four words (A, B, C, D) of the + -- Context in Result. Increments Cur. + + ------------- + -- Convert -- + ------------- + + procedure Convert (X : Unsigned_32) is + Y : Unsigned_32 := X; + + begin + for J in 1 .. 4 loop + Result (Cur + 1) := Hex_Digit (Y and Unsigned_32'(16#0F#)); + Y := Shift_Right (Y, 4); + Result (Cur) := Hex_Digit (Y and Unsigned_32'(16#0F#)); + Y := Shift_Right (Y, 4); + Cur := Cur + 2; + end loop; + end Convert; + + -- Start of processing for Digest + + begin + Convert (C.A); + Convert (C.B); + Convert (C.C); + Convert (C.D); + return Result; + end Digest; + + function Digest (S : String) return Message_Digest is + C : Context; + + begin + Update (C, S); + return Digest (C); + end Digest; + + function Digest + (A : Ada.Streams.Stream_Element_Array) + return Message_Digest + is + C : Context; + + begin + Update (C, A); + return Digest (C); + end Digest; + + ------- + -- F -- + ------- + + function F (X, Y, Z : Unsigned_32) return Unsigned_32 is + begin + return (X and Y) or ((not X) and Z); + end F; + + -------- + -- FF -- + -------- + + procedure FF + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive) + is + begin + A := A + F (B, C, D) + X + AC; + A := Rotate_Left (A, S); + A := A + B; + end FF; + + ------- + -- G -- + ------- + + function G (X, Y, Z : Unsigned_32) return Unsigned_32 is + begin + return (X and Z) or (Y and (not Z)); + end G; + + -------- + -- GG -- + -------- + + procedure GG + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive) + is + begin + A := A + G (B, C, D) + X + AC; + A := Rotate_Left (A, S); + A := A + B; + end GG; + + ------- + -- H -- + ------- + + function H (X, Y, Z : Unsigned_32) return Unsigned_32 is + begin + return X xor Y xor Z; + end H; + + -------- + -- HH -- + -------- + + procedure HH + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive) + is + begin + A := A + H (B, C, D) + X + AC; + A := Rotate_Left (A, S); + A := A + B; + end HH; + + ------- + -- I -- + ------- + + function I (X, Y, Z : Unsigned_32) return Unsigned_32 is + begin + return Y xor (X or (not Z)); + end I; + + -------- + -- II -- + -------- + + procedure II + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive) + is + begin + A := A + I (B, C, D) + X + AC; + A := Rotate_Left (A, S); + A := A + B; + end II; + + --------------- + -- Transform -- + --------------- + + procedure Transform + (C : in out Context; + Block : String) + is + X : Sixteen_Words; + + AA : Unsigned_32 := C.A; + BB : Unsigned_32 := C.B; + CC : Unsigned_32 := C.C; + DD : Unsigned_32 := C.D; + + begin + pragma Assert (Block'Length = 64); + + Decode (Block, X); + + -- Round 1 + + FF (AA, BB, CC, DD, X (00), 16#D76aa478#, S11); -- 1 + FF (DD, AA, BB, CC, X (01), 16#E8c7b756#, S12); -- 2 + FF (CC, DD, AA, BB, X (02), 16#242070db#, S13); -- 3 + FF (BB, CC, DD, AA, X (03), 16#C1bdceee#, S14); -- 4 + + FF (AA, BB, CC, DD, X (04), 16#f57c0faf#, S11); -- 5 + FF (DD, AA, BB, CC, X (05), 16#4787c62a#, S12); -- 6 + FF (CC, DD, AA, BB, X (06), 16#a8304613#, S13); -- 7 + FF (BB, CC, DD, AA, X (07), 16#fd469501#, S14); -- 8 + + FF (AA, BB, CC, DD, X (08), 16#698098d8#, S11); -- 9 + FF (DD, AA, BB, CC, X (09), 16#8b44f7af#, S12); -- 10 + FF (CC, DD, AA, BB, X (10), 16#ffff5bb1#, S13); -- 11 + FF (BB, CC, DD, AA, X (11), 16#895cd7be#, S14); -- 12 + + FF (AA, BB, CC, DD, X (12), 16#6b901122#, S11); -- 13 + FF (DD, AA, BB, CC, X (13), 16#fd987193#, S12); -- 14 + FF (CC, DD, AA, BB, X (14), 16#a679438e#, S13); -- 15 + FF (BB, CC, DD, AA, X (15), 16#49b40821#, S14); -- 16 + + -- Round 2 + + GG (AA, BB, CC, DD, X (01), 16#f61e2562#, S21); -- 17 + GG (DD, AA, BB, CC, X (06), 16#c040b340#, S22); -- 18 + GG (CC, DD, AA, BB, X (11), 16#265e5a51#, S23); -- 19 + GG (BB, CC, DD, AA, X (00), 16#e9b6c7aa#, S24); -- 20 + + GG (AA, BB, CC, DD, X (05), 16#d62f105d#, S21); -- 21 + GG (DD, AA, BB, CC, X (10), 16#02441453#, S22); -- 22 + GG (CC, DD, AA, BB, X (15), 16#d8a1e681#, S23); -- 23 + GG (BB, CC, DD, AA, X (04), 16#e7d3fbc8#, S24); -- 24 + + GG (AA, BB, CC, DD, X (09), 16#21e1cde6#, S21); -- 25 + GG (DD, AA, BB, CC, X (14), 16#c33707d6#, S22); -- 26 + GG (CC, DD, AA, BB, X (03), 16#f4d50d87#, S23); -- 27 + GG (BB, CC, DD, AA, X (08), 16#455a14ed#, S24); -- 28 + + GG (AA, BB, CC, DD, X (13), 16#a9e3e905#, S21); -- 29 + GG (DD, AA, BB, CC, X (02), 16#fcefa3f8#, S22); -- 30 + GG (CC, DD, AA, BB, X (07), 16#676f02d9#, S23); -- 31 + GG (BB, CC, DD, AA, X (12), 16#8d2a4c8a#, S24); -- 32 + + -- Round 3 + + HH (AA, BB, CC, DD, X (05), 16#fffa3942#, S31); -- 33 + HH (DD, AA, BB, CC, X (08), 16#8771f681#, S32); -- 34 + HH (CC, DD, AA, BB, X (11), 16#6d9d6122#, S33); -- 35 + HH (BB, CC, DD, AA, X (14), 16#fde5380c#, S34); -- 36 + + HH (AA, BB, CC, DD, X (01), 16#a4beea44#, S31); -- 37 + HH (DD, AA, BB, CC, X (04), 16#4bdecfa9#, S32); -- 38 + HH (CC, DD, AA, BB, X (07), 16#f6bb4b60#, S33); -- 39 + HH (BB, CC, DD, AA, X (10), 16#bebfbc70#, S34); -- 40 + + HH (AA, BB, CC, DD, X (13), 16#289b7ec6#, S31); -- 41 + HH (DD, AA, BB, CC, X (00), 16#eaa127fa#, S32); -- 42 + HH (CC, DD, AA, BB, X (03), 16#d4ef3085#, S33); -- 43 + HH (BB, CC, DD, AA, X (06), 16#04881d05#, S34); -- 44 + + HH (AA, BB, CC, DD, X (09), 16#d9d4d039#, S31); -- 45 + HH (DD, AA, BB, CC, X (12), 16#e6db99e5#, S32); -- 46 + HH (CC, DD, AA, BB, X (15), 16#1fa27cf8#, S33); -- 47 + HH (BB, CC, DD, AA, X (02), 16#c4ac5665#, S34); -- 48 + + -- Round 4 + + II (AA, BB, CC, DD, X (00), 16#f4292244#, S41); -- 49 + II (DD, AA, BB, CC, X (07), 16#432aff97#, S42); -- 50 + II (CC, DD, AA, BB, X (14), 16#ab9423a7#, S43); -- 51 + II (BB, CC, DD, AA, X (05), 16#fc93a039#, S44); -- 52 + + II (AA, BB, CC, DD, X (12), 16#655b59c3#, S41); -- 53 + II (DD, AA, BB, CC, X (03), 16#8f0ccc92#, S42); -- 54 + II (CC, DD, AA, BB, X (10), 16#ffeff47d#, S43); -- 55 + II (BB, CC, DD, AA, X (01), 16#85845dd1#, S44); -- 56 + + II (AA, BB, CC, DD, X (08), 16#6fa87e4f#, S41); -- 57 + II (DD, AA, BB, CC, X (15), 16#fe2ce6e0#, S42); -- 58 + II (CC, DD, AA, BB, X (06), 16#a3014314#, S43); -- 59 + II (BB, CC, DD, AA, X (13), 16#4e0811a1#, S44); -- 60 + + II (AA, BB, CC, DD, X (04), 16#f7537e82#, S41); -- 61 + II (DD, AA, BB, CC, X (11), 16#bd3af235#, S42); -- 62 + II (CC, DD, AA, BB, X (02), 16#2ad7d2bb#, S43); -- 63 + II (BB, CC, DD, AA, X (09), 16#eb86d391#, S44); -- 64 + + C.A := C.A + AA; + C.B := C.B + BB; + C.C := C.C + CC; + C.D := C.D + DD; + + end Transform; + + ------------ + -- Update -- + ------------ + + procedure Update + (C : in out Context; + Input : String) + is + Cur : Positive := Input'First; + Last_Block : String (1 .. 64); + + begin + while Cur + 63 <= Input'Last loop + Transform (C, Input (Cur .. Cur + 63)); + Cur := Cur + 64; + end loop; + + Last_Block (1 .. Input'Last - Cur + 1) := Input (Cur .. Input'Last); + + if Input'Last - Cur + 1 > 56 then + Cur := Input'Last - Cur + 2; + Last_Block (Cur .. 64) := Padding (1 .. 64 - Cur + 1); + Transform (C, Last_Block); + Last_Block := (others => ASCII.NUL); + + else + Cur := Input'Last - Cur + 2; + Last_Block (Cur .. 56) := Padding (1 .. 56 - Cur + 1); + end if; + + -- Add the input length as 8 characters + + Last_Block (57 .. 64) := (others => ASCII.NUL); + + declare + L : Unsigned_64 := Unsigned_64 (Input'Length) * 8; + + begin + Cur := 57; + while L > 0 loop + Last_Block (Cur) := Character'Val (L and 16#Ff#); + L := Shift_Right (L, 8); + Cur := Cur + 1; + end loop; + end; + + Transform (C, Last_Block); + end Update; + + procedure Update + (C : in out Context; + Input : Ada.Streams.Stream_Element_Array) + is + subtype Stream_Array is Ada.Streams.Stream_Element_Array (Input'Range); + subtype Stream_String is + String (1 + Integer (Input'First) .. 1 + Integer (Input'Last)); + + function To_String is new Ada.Unchecked_Conversion + (Stream_Array, Stream_String); + + String_Input : constant String := To_String (Input); + begin + Update (C, String_Input); + end Update; + + ----------------- + -- Wide_Digest -- + ----------------- + + function Wide_Digest (W : Wide_String) return Message_Digest is + C : Context; + + begin + Wide_Update (C, W); + return Digest (C); + end Wide_Digest; + + ----------------- + -- Wide_Update -- + ----------------- + + procedure Wide_Update + (C : in out Context; + Input : Wide_String) + is + + String_Input : String (1 .. 2 * Input'Length); + Cur : Positive := 1; + + begin + for Index in Input'Range loop + String_Input (Cur) := + Character'Val + (Unsigned_32 (Wide_Character'Pos (Input (Index))) and 16#FF#); + Cur := Cur + 1; + String_Input (Cur) := + Character'Val + (Shift_Right (Unsigned_32 (Wide_Character'Pos (Input (Index))), 8) + and 16#FF#); + Cur := Cur + 1; + end loop; + + Update (C, String_Input); + end Wide_Update; + +end GNAT.MD5; diff --git a/gcc/ada/g-md5.ads b/gcc/ada/g-md5.ads new file mode 100644 index 00000000000..c89d2099f41 --- /dev/null +++ b/gcc/ada/g-md5.ads @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . M D 5 -- +-- -- +-- S p e c -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 2002 Ada Core Technologies, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ +-- +-- This package implements the MD5 Message-Digest Algorithm as described in +-- RFC 1321. The complete text of RFC 1321 can be found at: +-- +-- http://www.ietf.org/rfc/rfc1321.txt +-- +-- The implementation is derived from the RSA Data Secutity, Inc. MD5 +-- Message-Digest Algorithm, as described in RFC 1321. + +with Ada.Streams; +with Interfaces; + +package GNAT.MD5 is + + type Context is private; + -- This type is the four-word (16 byte) MD buffer, as described in + -- RFC 1321 (3.3). It initial value is Initial_Context below. + + Initial_Context : constant Context; + -- Initial value of a Context object. May be used to reinitialize + -- a Context value by simple assignment of this value to the object. + + procedure Update + (C : in out Context; + Input : String); + procedure Wide_Update + (C : in out Context; + Input : Wide_String); + procedure Update + (C : in out Context; + Input : Ada.Streams.Stream_Element_Array); + -- Modify the Context C. If C has the initial value Initial_Context, + -- then, after a call to one of these procedures, Digest (C) will return + -- the Message-Digest of Input. + -- + -- These procedures may be called successively with the same context and + -- different inputs. However, several successive calls will not produce + -- the same final context as a call with the concatenation of the inputs. + + subtype Message_Digest is String (1 .. 32); + -- The string type returned by function Digest. + + function Digest (C : Context) return Message_Digest; + -- Extracts the Message-Digest from a context. This function should be + -- used after one or several calls to Update. + + function Digest (S : String) return Message_Digest; + function Wide_Digest (W : Wide_String) return Message_Digest; + function Digest + (A : Ada.Streams.Stream_Element_Array) + return Message_Digest; + -- These functions are equivalent to the corresponding Update (or + -- Wide_Update) on a default initialized Context, followed by Digest + -- on the resulting Context. + +private + + -- Magic numbers + Initial_A : constant := 16#67452301#; + Initial_B : constant := 16#EFCDAB89#; + Initial_C : constant := 16#98BADCFE#; + Initial_D : constant := 16#10325476#; + + type Context is record + A : Interfaces.Unsigned_32 := Initial_A; + B : Interfaces.Unsigned_32 := Initial_B; + C : Interfaces.Unsigned_32 := Initial_C; + D : Interfaces.Unsigned_32 := Initial_D; + end record; + + Initial_Context : constant Context := + (A => Initial_A, B => Initial_B, C => Initial_C, D => Initial_D); + +end GNAT.MD5; diff --git a/gcc/ada/g-os_lib.adb b/gcc/ada/g-os_lib.adb index 3c352366acb..9c5b6f14bd5 100644 --- a/gcc/ada/g-os_lib.adb +++ b/gcc/ada/g-os_lib.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1995-2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 1995-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- -- @@ -58,10 +58,15 @@ package body GNAT.OS_Lib is Result : out Integer; Pid : out Process_Id; Blocking : Boolean); - -- Internal routine to implement the to Spawn (blocking and non blocking) + -- Internal routine to implement the two Spawn (blocking/non blocking) -- routines. If Blocking is set to True then the spawn is blocking -- otherwise it is non blocking. In this latter case the Pid contains -- the process id number. The first three parameters are as in Spawn. + -- Note that Spawn_Internal normalizes the argument list before calling + -- the low level system spawn routines (see Normalize_Arguments). Note + -- that Normalize_Arguments is designed to do nothing if it is called + -- more than once, so calling Normalize_Arguments before calling one + -- of the spawn routines is fine. function To_Path_String_Access (Path_Addr : Address; @@ -103,31 +108,31 @@ package body GNAT.OS_Lib is loop declare - Quoted : Boolean := False; - Backqd : Boolean := False; - Old_Idx : Integer; + Quoted : Boolean := False; + Backqd : Boolean := False; + Old_Idx : Integer; begin Old_Idx := Idx; loop - -- A vanilla space is the end of an argument + -- An unquoted space is the end of an argument - if not Backqd and then not Quoted + if not (Backqd or Quoted) and then Arg_String (Idx) = ' ' then exit; -- Start of a quoted string - elsif not Backqd and then not Quoted + elsif not (Backqd or Quoted) and then Arg_String (Idx) = '"' then Quoted := True; -- End of a quoted string and end of an argument - elsif not Backqd and then Quoted + elsif (Quoted and not Backqd) and then Arg_String (Idx) = '"' then Idx := Idx + 1; @@ -320,6 +325,25 @@ package body GNAT.OS_Lib is return File_Time_Stamp (F_Name'Address); end File_Time_Stamp; + ---------- + -- Free -- + ---------- + + procedure Free (Arg : in out String_List_Access) is + X : String_Access; + + procedure Free_Array is new Unchecked_Deallocation + (Object => String_List, Name => String_List_Access); + + begin + for J in Arg'Range loop + X := Arg (J); + Free (X); + end loop; + + Free_Array (Arg); + end Free; + --------------------------- -- Get_Debuggable_Suffix -- --------------------------- @@ -768,6 +792,82 @@ package body GNAT.OS_Lib is return Pid; end Non_Blocking_Spawn; + ------------------------- + -- Normalize_Arguments -- + ------------------------- + + procedure Normalize_Arguments (Args : in out Argument_List) is + + procedure Quote_Argument (Arg : in out String_Access); + -- Add quote around argument if it contains spaces. + + Argument_Needs_Quote : Boolean; + pragma Import (C, Argument_Needs_Quote, "__gnat_argument_needs_quote"); + + -------------------- + -- Quote_Argument -- + -------------------- + + procedure Quote_Argument (Arg : in out String_Access) is + Res : String (1 .. Arg'Length * 2); + J : Positive := 1; + Quote_Needed : Boolean := False; + + begin + if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then + + -- Starting quote + + Res (J) := '"'; + + for K in Arg'Range loop + + J := J + 1; + + if Arg (K) = '"' then + Res (J) := '\'; + J := J + 1; + Res (J) := '"'; + + elsif Arg (K) = ' ' then + Res (J) := Arg (K); + Quote_Needed := True; + + else + Res (J) := Arg (K); + end if; + + end loop; + + if Quote_Needed then + + -- Ending quote + + J := J + 1; + Res (J) := '"'; + + declare + Old : String_Access := Arg; + + begin + Arg := new String'(Res (1 .. J)); + Free (Old); + end; + end if; + + end if; + end Quote_Argument; + + begin + if Argument_Needs_Quote then + for K in Args'Range loop + if Args (K) /= null then + Quote_Argument (Args (K)); + end if; + end loop; + end if; + end Normalize_Arguments; + ------------------------ -- Normalize_Pathname -- ------------------------ @@ -876,6 +976,10 @@ package body GNAT.OS_Lib is Reference_Dir : constant String := Get_Directory; -- Current directory name specified + ----------------- + -- Final_Value -- + ----------------- + function Final_Value (S : String) return String is begin -- Interix has the non standard notion of disk drive @@ -1280,74 +1384,109 @@ package body GNAT.OS_Lib is Pid : out Process_Id; Blocking : Boolean) is - type Chars is array (Positive range <>) of aliased Character; - type Char_Ptr is access constant Character; - - Command_Len : constant Positive := Program_Name'Length + 1 - + Args_Length (Args); - Command_Last : Natural := 0; - Command : aliased Chars (1 .. Command_Len); - -- Command contains all characters of the Program_Name and Args, - -- all terminated by ASCII.NUL characters - - Arg_List_Len : constant Positive := Args'Length + 2; - Arg_List_Last : Natural := 0; - Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr; - -- List with pointers to NUL-terminated strings of the - -- Program_Name and the Args and terminated with a null pointer. - -- We rely on the default initialization for the last null pointer. - - procedure Add_To_Command (S : String); - -- Add S and a NUL character to Command, updating Last - - function Portable_Spawn (Args : Address) return Integer; - pragma Import (C, Portable_Spawn, "__gnat_portable_spawn"); - - function Portable_No_Block_Spawn (Args : Address) return Process_Id; - pragma Import - (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn"); - -------------------- - -- Add_To_Command -- - -------------------- + procedure Spawn (Args : Argument_List); + -- Call Spawn. - procedure Add_To_Command (S : String) is - First : constant Natural := Command_Last + 1; + N_Args : Argument_List (Args'Range); + -- Normalized arguments - begin - Command_Last := Command_Last + S'Length; + ----------- + -- Spawn -- + ----------- - -- Move characters one at a time, because Command has - -- aliased components. + procedure Spawn (Args : Argument_List) is + type Chars is array (Positive range <>) of aliased Character; + type Char_Ptr is access constant Character; - for J in S'Range loop - Command (First + J - S'First) := S (J); - end loop; + Command_Len : constant Positive := Program_Name'Length + 1 + + Args_Length (Args); + Command_Last : Natural := 0; + Command : aliased Chars (1 .. Command_Len); + -- Command contains all characters of the Program_Name and Args, + -- all terminated by ASCII.NUL characters + + Arg_List_Len : constant Positive := Args'Length + 2; + Arg_List_Last : Natural := 0; + Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr; + -- List with pointers to NUL-terminated strings of the + -- Program_Name and the Args and terminated with a null pointer. + -- We rely on the default initialization for the last null pointer. + + procedure Add_To_Command (S : String); + -- Add S and a NUL character to Command, updating Last + + function Portable_Spawn (Args : Address) return Integer; + pragma Import (C, Portable_Spawn, "__gnat_portable_spawn"); - Command_Last := Command_Last + 1; - Command (Command_Last) := ASCII.NUL; + function Portable_No_Block_Spawn (Args : Address) return Process_Id; + pragma Import + (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn"); - Arg_List_Last := Arg_List_Last + 1; - Arg_List (Arg_List_Last) := Command (First)'Access; - end Add_To_Command; + -------------------- + -- Add_To_Command -- + -------------------- + + procedure Add_To_Command (S : String) is + First : constant Natural := Command_Last + 1; + + begin + Command_Last := Command_Last + S'Length; + + -- Move characters one at a time, because Command has + -- aliased components. + + for J in S'Range loop + Command (First + J - S'First) := S (J); + end loop; + + Command_Last := Command_Last + 1; + Command (Command_Last) := ASCII.NUL; + + Arg_List_Last := Arg_List_Last + 1; + Arg_List (Arg_List_Last) := Command (First)'Access; + end Add_To_Command; + + -- Start of processing for Spawn + + begin + Add_To_Command (Program_Name); + + for J in Args'Range loop + Add_To_Command (Args (J).all); + end loop; + + if Blocking then + Pid := Invalid_Pid; + Result := Portable_Spawn (Arg_List'Address); + else + Pid := Portable_No_Block_Spawn (Arg_List'Address); + Result := Boolean'Pos (Pid /= Invalid_Pid); + end if; + end Spawn; -- Start of processing for Spawn_Internal begin - Add_To_Command (Program_Name); + -- Copy arguments into a local structure - for J in Args'Range loop - Add_To_Command (Args (J).all); + for K in N_Args'Range loop + N_Args (K) := new String'(Args (K).all); end loop; - if Blocking then - Pid := Invalid_Pid; - Result := Portable_Spawn (Arg_List'Address); - else - Pid := Portable_No_Block_Spawn (Arg_List'Address); - Result := Boolean'Pos (Pid /= Invalid_Pid); - end if; + -- Normalize those arguments + + Normalize_Arguments (N_Args); + -- Call spawn using the normalized arguments + + Spawn (N_Args); + + -- Free arguments list + + for K in N_Args'Range loop + Free (N_Args (K)); + end loop; end Spawn_Internal; --------------------------- diff --git a/gcc/ada/g-os_lib.ads b/gcc/ada/g-os_lib.ads index 761e01904de..a878f90e74b 100644 --- a/gcc/ada/g-os_lib.ads +++ b/gcc/ada/g-os_lib.ads @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1995-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1995-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- -- @@ -42,9 +42,7 @@ -- This package tends to use fairly low-level Ada in order to not bring -- in large portions of the RTL. For example, functions return access --- to string as part of avoiding functions returning unconstrained types; --- types related to dates are defined here instead of using the types --- from Calendar, since use of Calendar forces linking in of tasking code. +-- to string as part of avoiding functions returning unconstrained types. -- Except where specifically noted, these routines are portable across -- all GNAT implementations on all supported operating systems. @@ -56,15 +54,25 @@ package GNAT.OS_Lib is pragma Elaborate_Body (OS_Lib); type String_Access is access all String; - -- General purpose string access type + -- General purpose string access type. Some of the functions in this + -- package allocate string results on the heap, and return a value of + -- this type. Note that the caller is responsible for freeing this + -- String to avoid memory leaks. procedure Free is new Unchecked_Deallocation (Object => String, Name => String_Access); + -- This procedure is provided for freeing returned values of type + -- String_Access type String_List is array (Positive range <>) of String_Access; type String_List_Access is access all String_List; -- General purpose array and pointer for list of string accesses + procedure Free (Arg : in out String_List_Access); + -- Frees the given array and all strings that its elements reference, + -- and then sets the argument to null. Provided for freeing returned + -- values of this type (including Argument_List_Access). + --------------------- -- Time/Date Stuff -- --------------------- @@ -200,7 +208,7 @@ pragma Elaborate_Body (OS_Lib); (Old_Name : String; New_Name : String; Success : out Boolean); - -- Rename a file. Successis set True or False indicating if the rename is + -- Rename a file. Success is set True or False indicating if the rename is -- successful. function Read @@ -316,22 +324,18 @@ pragma Elaborate_Body (OS_Lib); function Get_Debuggable_Suffix return String_Access; -- Return the debuggable suffix convention. Usually this is the same as - -- the convention for Get_Executable_Suffix. - -- - -- Note that this function allocates some memory for the returned value. - -- This memory needs to be deallocated after use. + -- the convention for Get_Executable_Suffix. The result is allocated on + -- the heap and should be freed when no longer needed to avoid storage + -- leaks. function Get_Executable_Suffix return String_Access; - -- Return the executable suffix convention. - -- - -- Note that this function allocates some memory for the returned value. - -- This memory needs to be deallocated after use. + -- Return the executable suffix convention. The result is allocated on + -- the heap and should be freed when no longer needed to avoid storage + -- leaks. function Get_Object_Suffix return String_Access; - -- Return the object suffix convention. - -- - -- Note that this function allocates some memory for the returned value. - -- This memory needs to be deallocated after use. + -- Return the object suffix convention. The result is allocated on the + -- heap and should be freed when no longer needed to avoid storage leaks. -- The following section contains low-level routines using addresses to -- pass file name and executable name. In each routine the name must be @@ -392,8 +396,21 @@ pragma Elaborate_Body (OS_Lib); -- the number of arguments. subtype Argument_List_Access is String_List_Access; - -- Type used to return an Argument_List without dragging in secondary - -- stack. + -- Type used to return Argument_List without dragging in secondary stack. + -- Note that there is a Free procedure declared for this subtype which + -- frees the array and all referenced strings. + + procedure Normalize_Arguments (Args : in out Argument_List); + -- Normalize all arguments in the list. This ensure that the argument list + -- is compatible with the running OS and will works fine with Spawn and + -- Non_Blocking_Spawn for example. If Normalize_Arguments is called twice + -- on the same list it will do nothing the second time. Note that Spawn + -- and Non_Blocking_Spawn call Normalize_Arguments automatically, but + -- since there is a guarantee that a second call does nothing, this + -- internal call with have no effect if Normalize_Arguments is called + -- before calling Spawn. The call to Normalize_Arguments assumes that + -- the individual referenced arguments in Argument_List are on the heap, + -- and may free them and reallocate if they are modified. procedure Spawn (Program_Name : String; @@ -408,15 +425,31 @@ pragma Elaborate_Body (OS_Lib); -- argument. On some systems (notably Unix systems) a simple file -- name may also work (if the executable can be located in the path). -- - -- Note: Arguments that contain spaces and/or quotes such as - -- "--GCC=gcc -v" or "--GCC=""gcc-v""" are not portable - -- across OSes. They may or may not have the desired effect. + -- Note: Arguments in Args that contain spaces and/or quotes such as + -- "--GCC=gcc -v" or "--GCC=""gcc -v""" are not portable across all + -- operating systems, and would not have the desired effect if they + -- were passed directly to the operating system. To avoid this problem, + -- Spawn makes an internal call to Normalize_Arguments, which ensures + -- that such arguments are modified in a manner that ensures that the + -- desired effect is obtained on all operating systems. The caller may + -- call Normalize_Arguments explicitly before the call (e.g. to print + -- out the exact form of arguments passed to the operating system). In + -- this case the guarantee a second call to Normalize_Arguments has no + -- effect ensures that the internal call will not affect the result. + -- Note that the implicit call to Normalize_Arguments may free and + -- reallocate some of the individual arguments. + -- + -- This function will always set Success to False under VxWorks and + -- other similar operating systems which have no notion of the concept + -- of a dynamically executable file. function Spawn (Program_Name : String; Args : Argument_List) return Integer; - -- Like above, but as function returning the exact exit status + -- Similar to the above procedure, but returns the actual status returned + -- by the operating system, or -1 under VxWorks and any other similar + -- operating systems which have no notion of separately spawnable programs. type Process_Id is private; -- A private type used to identify a process activated by the following @@ -433,6 +466,9 @@ pragma Elaborate_Body (OS_Lib); -- This is a non blocking call. The Process_Id of the spawned process -- is returned. Parameters are to be used as in Spawn. If Invalid_Id -- is returned the program could not be spawned. + -- + -- This function will always return Invalid_Id under VxWorks, since + -- there is no notion of executables under this OS. procedure Wait_Process (Pid : out Process_Id; Success : out Boolean); -- Wait for the completion of any of the processes created by previous @@ -444,12 +480,17 @@ pragma Elaborate_Body (OS_Lib); -- has terminated (matching the value returned from Non_Blocking_Spawn). -- Success is set to True if this sub-process terminated successfully. -- If Pid = Invalid_Id, there were no subprocesses left to wait on. + -- + -- This function will always set success to False under VxWorks, since + -- there is no notion of executables under this OS. function Argument_String_To_List (Arg_String : String) return Argument_List_Access; -- Take a string that is a program and it's arguments and parse it into - -- an Argument_List. + -- an Argument_List. Note that the result is allocated on the heap, and + -- must be freed by the programmer (when it is no longer needed) to avoid + -- memory leaks. ------------------- -- Miscellaneous -- @@ -460,7 +501,9 @@ pragma Elaborate_Body (OS_Lib); -- to the empty string if the environment variable does not exist -- or has an explicit null value (in some operating systems these -- are distinct cases, in others they are not; this interface - -- abstracts away that difference. + -- abstracts away that difference. The argument is allocated on + -- the heap (even in the null case), and needs to be freed explicitly + -- when no longer needed to avoid memory leaks. procedure Setenv (Name : String; Value : String); -- Set the value of the environment variable Name to Value. This call @@ -476,10 +519,12 @@ pragma Elaborate_Body (OS_Lib); procedure OS_Exit (Status : Integer); pragma Import (C, OS_Exit, "__gnat_os_exit"); + pragma No_Return (OS_Exit); -- Exit to OS with given status code (program is terminated) procedure OS_Abort; pragma Import (C, OS_Abort, "abort"); + pragma No_Return (OS_Abort); -- Exit to OS signalling an abort (traceback or other appropriate -- diagnostic information should be given if possible, or entry made -- to the debugger if that is possible). diff --git a/gcc/ada/g-regexp.adb b/gcc/ada/g-regexp.adb index 5a5e39b110b..66d56674009 100644 --- a/gcc/ada/g-regexp.adb +++ b/gcc/ada/g-regexp.adb @@ -1092,6 +1092,8 @@ package body GNAT.Regexp is End_State : State_Index) return Regexp is + pragma Warnings (Off, Num_States); + Last_Index : constant State_Index := First_Table'Last (1); type Meta_State is array (1 .. Last_Index) of Boolean; diff --git a/gcc/ada/g-regpat.adb b/gcc/ada/g-regpat.adb index da4748c30ea..561dca3ed66 100644 --- a/gcc/ada/g-regpat.adb +++ b/gcc/ada/g-regpat.adb @@ -9,7 +9,7 @@ -- $Revision$ -- -- -- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1996-2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 1996-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- -- @@ -253,8 +253,6 @@ package body GNAT.Regpat is -- Local Subprograms -- ----------------------- - function "+" (Left : Opcode; Right : Integer) return Opcode; - function "-" (Left : Opcode; Right : Opcode) return Integer; function "=" (Left : Character; Right : Opcode) return Boolean; function Is_Alnum (C : Character) return Boolean; @@ -307,8 +305,6 @@ package body GNAT.Regpat is -- All of the subprograms above are tiny and should be inlined - pragma Inline ("+"); - pragma Inline ("-"); pragma Inline ("="); pragma Inline (Is_Alnum); pragma Inline (Is_Space); @@ -329,24 +325,6 @@ package body GNAT.Regpat is -- Worst case --------- - -- "+" -- - --------- - - function "+" (Left : Opcode; Right : Integer) return Opcode is - begin - return Opcode'Val (Opcode'Pos (Left) + Right); - end "+"; - - --------- - -- "-" -- - --------- - - function "-" (Left : Opcode; Right : Opcode) return Integer is - begin - return Opcode'Pos (Left) - Opcode'Pos (Right); - end "-"; - - --------- -- "=" -- --------- @@ -482,6 +460,7 @@ package body GNAT.Regpat is -- Dig the "next" pointer out of a node procedure Fail (M : in String); + pragma No_Return (Fail); -- Fail with a diagnostic message, if possible function Is_Curly_Operator (IP : Natural) return Boolean; @@ -612,6 +591,8 @@ package body GNAT.Regpat is Max : out Natural; Greedy : out Boolean) is + pragma Warnings (Off, IP); + Save_Pos : Natural := Parse_Pos + 1; begin @@ -896,6 +877,7 @@ package body GNAT.Regpat is else IP := 0; + Par_No := 0; end if; -- Pick up the branches, linking them together @@ -1030,6 +1012,7 @@ package body GNAT.Regpat is else IP := Emit_Node (ANY); end if; + Expr_Flags.Has_Width := True; Expr_Flags.Simple := True; @@ -1133,7 +1116,8 @@ package body GNAT.Regpat is Parse_Literal (Expr_Flags, IP); end case; - when others => Parse_Literal (Expr_Flags, IP); + when others => + Parse_Literal (Expr_Flags, IP); end case; end Parse_Atom; @@ -2936,9 +2920,12 @@ package body GNAT.Regpat is -- parent's current state that we can try again after backing off. function Match_Whilem (IP : Pointer) return Boolean is + pragma Warnings (Off, IP); + Cc : Current_Curly_Access := Current_Curly; - N : Natural := Cc.Cur + 1; - Ln : Natural; + N : Natural := Cc.Cur + 1; + Ln : Natural := 0; + Lastloc : Natural := Cc.Lastloc; -- Detection of 0-len. diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 3b794b72930..5ff59835247 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -8,7 +8,7 @@ -- -- -- $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- -- @@ -112,7 +112,7 @@ package body GNAT.Sockets is function Resolve_Error (Error_Value : Integer; From_Errno : Boolean := True) - return Error_Type; + return Error_Type; -- Associate an enumeration value (error_type) to en error value -- (errno). From_Errno prevents from mixing h_errno with errno. @@ -207,16 +207,14 @@ package body GNAT.Sockets is -------------------- procedure Abort_Selector (Selector : Selector_Type) is + Buf : Character; + Res : C.int; + begin -- Send an empty array to unblock C select system call if Selector.In_Progress then - declare - Buf : Character; - Res : C.int; - begin - Res := C_Write (C.int (Selector.W_Sig_Socket), Buf'Address, 0); - end; + Res := C_Write (C.int (Selector.W_Sig_Socket), Buf'Address, 1); end if; end Abort_Selector; @@ -235,6 +233,7 @@ package body GNAT.Sockets is begin Res := C_Accept (C.int (Server), Sin'Address, Len'Access); + if Res = Failure then Raise_Socket_Error (Socket_Errno); end if; @@ -364,6 +363,7 @@ package body GNAT.Sockets is else WSet := Fd_Set (W_Socket_Set.all); end if; + Len := C.int'Max (Max (RSet) + 1, Len); Selector.In_Progress := True; @@ -384,7 +384,7 @@ package body GNAT.Sockets is declare Buf : Character; begin - Res := C_Read (C.int (Selector.R_Sig_Socket), Buf'Address, 0); + Res := C_Read (C.int (Selector.R_Sig_Socket), Buf'Address, 1); end; -- Select was resumed because of read signalling socket, but @@ -568,6 +568,7 @@ package body GNAT.Sockets is -- Get the port used by the socket Res := C_Getsockname (S0, Sin'Address, Len'Access); + if Res = Failure then Err := Socket_Errno; Res := C_Close (S0); @@ -575,6 +576,7 @@ package body GNAT.Sockets is end if; Res := C_Listen (S0, 2); + if Res = Failure then Err := Socket_Errno; Res := C_Close (S0); @@ -582,6 +584,7 @@ package body GNAT.Sockets is end if; S1 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0); + if S1 = Failure then Err := Socket_Errno; Res := C_Close (S0); @@ -598,6 +601,7 @@ package body GNAT.Sockets is -- Do a connect and accept the connection Res := C_Connect (S1, Sin'Address, Len); + if Res = Failure then Err := Socket_Errno; Res := C_Close (S0); @@ -606,6 +610,7 @@ package body GNAT.Sockets is end if; S2 := C_Accept (S0, Sin'Address, Len'Access); + if S2 = Failure then Err := Socket_Errno; Res := C_Close (S0); @@ -614,6 +619,7 @@ package body GNAT.Sockets is end if; Res := C_Close (S0); + if Res = Failure then Raise_Socket_Error (Socket_Errno); end if; @@ -694,6 +700,8 @@ package body GNAT.Sockets is Family : Family_Type := Family_Inet) return Host_Entry_Type is + pragma Unreferenced (Family); + HA : aliased In_Addr := To_In_Addr (Address); Res : Hostent_Access; Err : Integer; @@ -849,11 +857,12 @@ package body GNAT.Sockets is end case; - Res := C_Getsockopt - (C.int (Socket), - Levels (Level), - Options (Name), - Add, Len'Unchecked_Access); + Res := + C_Getsockopt + (C.int (Socket), + Levels (Level), + Options (Name), + Add, Len'Unchecked_Access); if Res = Failure then Raise_Socket_Error (Socket_Errno); @@ -1229,7 +1238,7 @@ package body GNAT.Sockets is function Resolve_Error (Error_Value : Integer; From_Errno : Boolean := True) - return Error_Type + return Error_Type is use GNAT.Sockets.Constants; @@ -1243,6 +1252,7 @@ package body GNAT.Sockets is when others => return Cannot_Resolve_Error; end case; end if; + case Error_Value is when EACCES => return Permission_Denied; when EADDRINUSE => return Address_Already_In_Use; @@ -1537,6 +1547,7 @@ package body GNAT.Sockets is begin Res := C_Shutdown (C.int (Socket), Shutmodes (How)); + if Res = Failure then Raise_Socket_Error (Socket_Errno); end if; @@ -1554,7 +1565,7 @@ package body GNAT.Sockets is S : Datagram_Socket_Stream_Access; begin - S := new Datagram_Socket_Stream_Type; + S := new Datagram_Socket_Stream_Type; S.Socket := Socket; S.To := Send_To; S.From := Get_Socket_Name (Socket); @@ -1567,7 +1578,7 @@ package body GNAT.Sockets is function Stream (Socket : Socket_Type) - return Stream_Access + return Stream_Access is S : Stream_Socket_Stream_Access; @@ -1608,7 +1619,7 @@ package body GNAT.Sockets is In_Addr_Access_Pointers.Value (Host.H_Addr_List); -- H_Addr_List points to a list of binary addresses (in network -- byte order). The list is terminated by a NULL pointer. - + -- -- H_Length is not used because it is currently only set to 4. -- H_Addrtype is always AF_INET diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index 2ed95ed9bce..2e207b25077 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -8,7 +8,7 @@ -- -- -- $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- -- @@ -34,8 +34,9 @@ -- This package provides an interface to the sockets communication facility -- provided on many operating systems. Currently this is implemented on all --- native GNAT ports except for VMS. It is not yet implemented for any of --- the cross-ports (e.g. it is not available for VxWorks or LynxOS). +-- native GNAT ports except for VMS. It is not yet implemented on the Lynx +-- cross-ports. + -- Another restriction is that there is no multicast support under Windows -- or under any system on which the multicast support is not available or -- installed. @@ -45,11 +46,12 @@ with Ada.Streams; package GNAT.Sockets is - -- Sockets are designed to provide a consistent communication - -- facility between applications. This package provides an - -- Ada-like interface similar to the one proposed as part of the - -- BSD socket layer. This is a system independent thick binding. - -- Here is a typical example of what you can do. + -- Sockets are designed to provide a consistent communication facility + -- between applications. This package provides an Ada-like intrerface + -- similar to that proposed as part of the BSD socket layer. This is a + -- system independent thick binding. + + -- Here is a typical example of what you can do: -- with GNAT.Sockets; use GNAT.Sockets; -- @@ -75,19 +77,19 @@ package GNAT.Sockets is -- begin -- accept Start; -- - -- -- Get an Internet address of a host (here "localhost"). + -- -- Get an Internet address of a host (here the local host name). -- -- Note that a host can have several addresses. Here we get -- -- the first one which is supposed to be the official one. -- - -- Address.Addr := Addresses (Get_Host_By_Name ("localhost"), 1); + -- Address.Addr := Addresses (Get_Host_By_Name (Host_Name), 1); -- -- -- Get a socket address that is an Internet address and a port -- -- Address.Port := 5432; -- -- -- The first step is to create a socket. Once created, this - -- -- socket must be associated to with an address. Usually only a - -- -- server (Pong here) needs to bind an address explicitly. + -- -- socket must be associated to with an address. Usually only + -- -- a server (Pong here) needs to bind an address explicitly. -- -- Most of the time clients can skip this step because the -- -- socket routines will bind an arbitrary address to an unbound -- -- socket. @@ -234,7 +236,7 @@ package GNAT.Sockets is -- -- -- See comments in Ping section for the first steps. -- - -- Address.Addr := Addresses (Get_Host_By_Name ("localhost"), 1); + -- Address.Addr := Addresses (Get_Host_By_Name (Host_Name), 1); -- Address.Port := 5432; -- Create_Socket (Socket); -- @@ -481,8 +483,9 @@ package GNAT.Sockets is -- Errors are described by an enumeration type. There is only one -- exception Socket_Error in this package to deal with an error -- during a socket routine. Once raised, its message contains the - -- error code between brackets and a string describing the error - -- code. + -- error code between brackets and a string describing the error code. + + -- The name of the enumeration constant documents the error condition. type Error_Type is (Permission_Denied, @@ -813,7 +816,7 @@ package GNAT.Sockets is -- data. In these cases Status is set to Completed and sockets -- that are ready are set in R_Socket_Set or W_Socket_Set. Status -- is set to Expired if no socket was ready after a Timeout - -- expiration. Status is set to Aborted if an abort signal as been + -- expiration. Status is set to Aborted if an abort signal has been -- received while checking socket status. As this procedure -- returns when Timeout occurs, it is a design choice to keep this -- procedure process blocking. Note that a Timeout of 0.0 returns diff --git a/gcc/ada/g-spipat.adb b/gcc/ada/g-spipat.adb index 767d4a11e22..469ac056b37 100644 --- a/gcc/ada/g-spipat.adb +++ b/gcc/ada/g-spipat.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- --- Copyright (C) 1998-2001, Ada Core Technologies, Inc. -- +-- Copyright (C) 1998-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- -- @@ -77,7 +77,6 @@ package body GNAT.Spitbol.Patterns is subtype String_Ptr is Ada.Strings.Unbounded.String_Access; subtype File_Ptr is Ada.Text_IO.File_Access; - function To_PE_Ptr is new Unchecked_Conversion (Address, PE_Ptr); function To_Address is new Unchecked_Conversion (PE_Ptr, Address); -- Used only for debugging output purposes @@ -86,7 +85,6 @@ package body GNAT.Spitbol.Patterns is N : constant PE_Ptr := null; -- Shorthand used to initialize Copy fields to null - type Character_Ptr is access all Character; type Natural_Ptr is access all Natural; type Pattern_Ptr is access all Pattern; @@ -1229,10 +1227,6 @@ package body GNAT.Spitbol.Patterns is -- in the left operand, it represents the additional stack space -- required by the right operand. - function "&" (L, R : PE_Ptr) return PE_Ptr; - pragma Inline ("&"); - -- Equivalent to Concat (L, R, 0) - function C_To_PE (C : PChar) return PE_Ptr; -- Given a character, constructs a pattern element that matches -- the single character. @@ -1347,11 +1341,6 @@ package body GNAT.Spitbol.Patterns is return (AFC with L.Stk + R.Stk, Concat (Copy (L.P), Copy (R.P), R.Stk)); end "&"; - function "&" (L, R : PE_Ptr) return PE_Ptr is - begin - return Concat (L, R, 0); - end "&"; - --------- -- "*" -- --------- diff --git a/gcc/ada/g-table.adb b/gcc/ada/g-table.adb index 086f1de7970..82411ba69b2 100644 --- a/gcc/ada/g-table.adb +++ b/gcc/ada/g-table.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.8 $ +-- $Revision$ -- -- -- Copyright (C) 1998-2001 Ada Core Technologies, Inc. -- -- -- @@ -32,7 +32,9 @@ -- -- ------------------------------------------------------------------------------ -with System; use System; +with System; use System; +with System.Memory; use System.Memory; +with System.Address_To_Access_Conversions; package body GNAT.Table is @@ -49,8 +51,6 @@ package body GNAT.Table is Last_Val : Integer; -- Current value of Last. - type size_t is new Integer; - ----------------------- -- Local Subprograms -- ----------------------- @@ -60,6 +60,18 @@ package body GNAT.Table is -- in Max. Works correctly to do an initial allocation if the table -- is currently null. + package Table_Conversions is + new System.Address_To_Access_Conversions (Big_Table_Type); + -- Address and Access conversions for a Table object. + + function To_Address (Table : Table_Ptr) return Address; + pragma Inline (To_Address); + -- Returns the Address for the Table object. + + function To_Pointer (Table : Address) return Table_Ptr; + pragma Inline (To_Pointer); + -- Returns the Access pointer for the Table object. + -------------- -- Allocate -- -------------- @@ -101,11 +113,8 @@ package body GNAT.Table is ---------- procedure Free is - procedure free (T : Table_Ptr); - pragma Import (C, free); - begin - free (Table); + Free (To_Address (Table)); Table := null; Length := 0; end Free; @@ -166,18 +175,6 @@ package body GNAT.Table is ---------------- procedure Reallocate is - - function realloc - (memblock : Table_Ptr; - size : size_t) - return Table_Ptr; - pragma Import (C, realloc); - - function malloc - (size : size_t) - return Table_Ptr; - pragma Import (C, malloc); - New_Size : size_t; begin @@ -202,13 +199,12 @@ package body GNAT.Table is (Table_Type'Component_Size / Storage_Unit)); if Table = null then - Table := malloc (New_Size); + Table := To_Pointer (Alloc (New_Size)); elsif New_Size > 0 then Table := - realloc - (memblock => Table, - size => New_Size); + To_Pointer (Realloc (Ptr => To_Address (Table), + Size => New_Size)); end if; if Length /= 0 and then Table = null then @@ -261,6 +257,25 @@ package body GNAT.Table is end if; end Set_Last; + ---------------- + -- To_Address -- + ---------------- + + function To_Address (Table : Table_Ptr) return Address is + begin + return Table_Conversions.To_Address + (Table_Conversions.Object_Pointer (Table)); + end To_Address; + + ---------------- + -- To_Pointer -- + ---------------- + + function To_Pointer (Table : Address) return Table_Ptr is + begin + return Table_Ptr (Table_Conversions.To_Pointer (Table)); + end To_Pointer; + begin Init; end GNAT.Table; diff --git a/gcc/ada/g-trasym.adb b/gcc/ada/g-trasym.adb index 65ffe0feb0e..71bc5a59da8 100644 --- a/gcc/ada/g-trasym.adb +++ b/gcc/ada/g-trasym.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.6 $ +-- $Revision$ -- -- --- Copyright (C) 1999 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- -- diff --git a/gcc/ada/g-trasym.ads b/gcc/ada/g-trasym.ads index cd72be42ac3..47ce3b367de 100644 --- a/gcc/ada/g-trasym.ads +++ b/gcc/ada/g-trasym.ads @@ -8,7 +8,7 @@ -- -- -- $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- -- @@ -35,11 +35,22 @@ -- Run-time symbolic traceback support -- Note: this is only available on selected targets. Currently it is --- supported on Sparc/Solaris, GNU/Linux, Windows NT, HP-UX, IRIX and Tru64. +-- supported on Sparc/Solaris, GNU/Linux, Windows NT, HP-UX and Tru64. -- The routines provided in this package assume that your application has -- been compiled with debugging information turned on, since this information -- is used to build a symbolic traceback. +-- +-- In order to retrieve symbolic information, functions in this package will +-- read on disk all the debug information of the current executable and load +-- them in memory, causing a significant cpu and memory overhead. +-- +-- This package is not intended to be used within a shared library, +-- symbolic tracebacks are only supported for the main executable +-- and not for shared libraries. +-- +-- You should consider using off-line symbolic traceback instead, using +-- addr2line or gdb. with Ada.Exceptions; use Ada.Exceptions; diff --git a/gcc/ada/gigi.h b/gcc/ada/gigi.h index 15d3b65871f..7c8541a8184 100644 --- a/gcc/ada/gigi.h +++ b/gcc/ada/gigi.h @@ -6,9 +6,9 @@ * * * C Header File * * * - * $Revision: 1.2 $ + * $Revision$ * * - * Copyright (C) 1992-2001 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- * @@ -60,18 +60,15 @@ extern void update_setjmp_buf PARAMS ((tree)); default. */ extern int default_pass_by_ref PARAMS ((tree)); -/* GNU_TYPE is the type of a subprogram parameter. Determine from the type if - it should be passed by reference. */ +/* GNU_TYPE is the type of a subprogram parameter. Determine from the type + if it should be passed by reference. */ extern int must_pass_by_ref PARAMS ((tree)); -/* Elaboration routines for the front end */ -extern void elab_all_gnat PARAMS ((void)); +/* This function returns the version of GCC being used. Here it's GCC 3. */ +extern int gcc_version PARAMS ((void)); -/* Emit a label UNITNAME_LABEL and specify that it is part of source - file FILENAME. If this is being written for SGI's Workshop - debugger, and we are writing Dwarf2 debugging information, add - additional debug info. */ -extern void emit_unit_label PARAMS ((char *, char *)); +/* Elaboration routines for the front end. */ +extern void elab_all_gnat PARAMS ((void)); /* Initialize DUMMY_NODE_TABLE. */ extern void init_dummy_type PARAMS ((void)); @@ -235,9 +232,8 @@ extern void post_error_ne_tree_2 PARAMS ((const char *, Node_Id, Entity_Id, /* Set the node for a second '&' in the error message. */ extern void set_second_error_entity PARAMS ((Entity_Id)); -/* Surround EXP with a SAVE_EXPR, but handle unconstrained objects specially - since it doesn't make any sense to put them in a SAVE_EXPR. */ -extern tree make_save_expr PARAMS ((tree)); +/* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */ +extern tree protect_multiple_eval PARAMS ((tree)); /* Signal abort, with "Gigi abort" as the error label, and error_gnat_node as the relevant node that provides the location info for the error. @@ -355,12 +351,10 @@ enum standard_datatypes ADT_setjmp_decl, ADT_longjmp_decl, ADT_raise_nodefer_decl, - ADT_raise_constraint_error_decl, - ADT_raise_program_error_decl, - ADT_raise_storage_error_decl, ADT_LAST}; extern tree gnat_std_decls[(int) ADT_LAST]; +extern tree gnat_raise_decls[(int) LAST_REASON_CODE + 1]; #define longest_float_type_node gnat_std_decls[(int) ADT_longest_float_type] #define void_type_decl_node gnat_std_decls[(int) ADT_void_type_decl] @@ -378,12 +372,6 @@ extern tree gnat_std_decls[(int) ADT_LAST]; #define setjmp_decl gnat_std_decls[(int) ADT_setjmp_decl] #define longjmp_decl gnat_std_decls[(int) ADT_longjmp_decl] #define raise_nodefer_decl gnat_std_decls[(int) ADT_raise_nodefer_decl] -#define raise_constraint_error_decl \ - gnat_std_decls[(int) ADT_raise_constraint_error_decl] -#define raise_program_error_decl \ - gnat_std_decls[(int) ADT_raise_program_error_decl] -#define raise_storage_error_decl \ - gnat_std_decls[(int) ADT_raise_storage_error_decl] /* Routines expected by the gcc back-end. They must have exactly the same prototype and names as below. */ @@ -435,6 +423,7 @@ extern tree pushdecl PARAMS ((tree)); in the gcc back-end and initialize the global binding level. */ extern void gnat_init_decl_processing PARAMS ((void)); extern void init_gigi_decls PARAMS ((tree, tree)); +extern void gnat_init_gcc_eh PARAMS ((void)); /* Return an integer type with the number of bits of precision given by PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise @@ -645,8 +634,10 @@ extern void update_pointer_to PARAMS ((tree, tree)); extern tree max_size PARAMS ((tree, int)); /* Remove all conversions that are done in EXP. This includes converting - from a padded type or converting to a left-justified modular type. */ -extern tree remove_conversions PARAMS ((tree)); + from a padded type or to a left-justified modular type. If TRUE_ADDRESS + is nonzero, always return the address of the containing object even if + the address is not bit-aligned. */ +extern tree remove_conversions PARAMS ((tree, int)); /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P, @@ -705,9 +696,9 @@ extern tree build_call_2_expr PARAMS((tree, tree, tree)); /* Likewise to call FUNDECL with no arguments. */ extern tree build_call_0_expr PARAMS((tree)); -/* Call a function FCN that raises an exception and pass the line - number and file name, if requested. */ -extern tree build_call_raise PARAMS((tree)); +/* Call a function that raises an exception and pass the line number and file + name, if requested. MSG says which exception function to call. */ +extern tree build_call_raise PARAMS((int)); /* Return a CONSTRUCTOR of TYPE whose list is LIST. */ extern tree build_constructor PARAMS((tree, tree)); diff --git a/gcc/ada/gmem.c b/gcc/ada/gmem.c index 772667b6295..cc1bea203c1 100644 --- a/gcc/ada/gmem.c +++ b/gcc/ada/gmem.c @@ -69,7 +69,7 @@ static FILE *gmemfile; /* tb_len is the number of call level supported by this module */ #define TB_LEN 200 -static char *tracebk [TB_LEN]; +static char *tracebk[TB_LEN]; static int cur_tb_len, cur_tb_pos; extern void convert_addresses PARAMS ((char *[], int, void *, @@ -123,10 +123,10 @@ __gnat_gmem_a2l_initialize (exename) char *exename; { extern char **gnat_argv; - char s [100]; + char s[100]; int l; - gnat_argv [0] = exename; + gnat_argv[0] = exename; convert_addresses (tracebk, 1, s, &l); } @@ -201,8 +201,8 @@ __gnat_gmem_read_bt_frame (buf) if (cur_tb_pos >= cur_tb_len) { - buf [0] = ' '; - buf [1] = '\0'; + buf[0] = ' '; + buf[1] = '\0'; return; } diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index ddcc1e7f220..72679d5233a 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -90,12 +90,15 @@ begin -- nested blocks, so that the outer one handles unrecoverable error. begin - Osint.Initialize (Compiler); + -- Lib.Initialize need to be called before Scan_Compiler_Arguments, + -- because it initialize a table that is filled by + -- Scan_Compiler_Arguments. + + Lib.Initialize; Scan_Compiler_Arguments; Osint.Add_Default_Search_Dirs; Sinput.Initialize; - Lib.Initialize; Sem.Initialize; Csets.Initialize; Uintp.Initialize; @@ -107,6 +110,14 @@ begin Inline.Initialize; Sem_Ch13.Initialize; + -- Acquire target parameters and perform required setup + + Targparm.Get_Target_Parameters; + + if Targparm.High_Integrity_Mode_On_Target then + Set_No_Run_Time_Mode; + end if; + -- Output copyright notice if full list mode if (Verbose_Mode or Full_List) @@ -114,17 +125,14 @@ begin then Write_Eol; Write_Str ("GNAT "); - Write_Str (Gnat_Version_String); - Write_Str (" Copyright 1992-2001 Free Software Foundation, Inc."); - Write_Eol; - end if; - - -- Acquire target parameters and perform required setup - Targparm.Get_Target_Parameters; + if Targparm.High_Integrity_Mode_On_Target then + Write_Str ("Pro High Integrity "); + end if; - if Targparm.High_Integrity_Mode_On_Target then - Set_No_Run_Time_Mode; + Write_Str (Gnat_Version_String); + Write_Str (" Copyright 1992-2002 Free Software Foundation, Inc."); + Write_Eol; end if; -- Before we do anything else, adjust certain global values for @@ -173,6 +181,23 @@ begin end if; end if; + -- Set proper status for overflow checks. We turn on overflow checks + -- if -gnatp was not specified, and either -gnato is set or the back + -- end takes care of overflow checks. Otherwise we suppress overflow + -- checks by default (since front end checks are expensive). + + if not Opt.Suppress_Checks + and then (Opt.Enable_Overflow_Checks + or else + (Targparm.Backend_Divide_Checks_On_Target + and + Targparm.Backend_Overflow_Checks_On_Target)) + then + Suppress_Options.Overflow_Checks := False; + else + Suppress_Options.Overflow_Checks := True; + end if; + -- Check we have exactly one source file, this happens only in -- the case where the driver is called directly, it cannot happen -- when gnat1 is invoked from gcc in the normal case. diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 49890a046da..d66df981c0b 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -39,8 +39,11 @@ with Gnatvsn; use Gnatvsn; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; +with Osint.B; use Osint.B; with Output; use Output; with Switch; use Switch; +with Switch.B; use Switch.B; +with Targparm; use Targparm; with Types; use Types; procedure Gnatbind is @@ -86,9 +89,7 @@ procedure Gnatbind is Output_File_Name_Seen := True; if Argv'Length = 0 - or else (Argv'Length >= 1 - and then (Argv (1) = Switch_Character - or else Argv (1) = '-')) + or else (Argv'Length >= 1 and then Argv (1) = '-') then Fail ("output File_Name missing after -o"); @@ -96,10 +97,8 @@ procedure Gnatbind is Output_File_Name := new String'(Argv); end if; - elsif Argv'Length >= 2 - and then (Argv (1) = Switch_Character - or else Argv (1) = '-') - then + elsif Argv'Length >= 2 and then Argv (1) = '-' then + -- -I- if Argv (2 .. Argv'Last) = "I-" then @@ -227,9 +226,9 @@ procedure Gnatbind is if Argv'Length > 4 and then Argv (Argv'Last - 3 .. Argv'Last) = ".ali" then - Set_Main_File_Name (Argv); + Add_File (Argv); else - Set_Main_File_Name (Argv & ".ali"); + Add_File (Argv & ".ali"); end if; end if; end Scan_Bind_Arg; @@ -237,7 +236,6 @@ procedure Gnatbind is -- Start of processing for Gnatbind begin - Osint.Initialize (Binder); -- Set default for Shared_Libgnat option @@ -315,10 +313,18 @@ begin Osint.Add_Default_Search_Dirs; if Verbose_Mode then + Namet.Initialize; + Targparm.Get_Target_Parameters; + Write_Eol; Write_Str ("GNATBIND "); + + if Targparm.High_Integrity_Mode_On_Target then + Write_Str ("Pro High Integrity "); + end if; + Write_Str (Gnat_Version_String); - Write_Str (" Copyright 1995-2001 Free Software Foundation, Inc."); + Write_Str (" Copyright 1995-2002 Free Software Foundation, Inc."); Write_Eol; end if; diff --git a/gcc/ada/gnatbl.c b/gcc/ada/gnatbl.c index 18529a272b7..f1810582127 100644 --- a/gcc/ada/gnatbl.c +++ b/gcc/ada/gnatbl.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * $Revision: 1.65 $ + * $Revision$ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * @@ -89,7 +89,7 @@ addarg (str) = (char **) xcalloc (link_arg_max + 1000, sizeof (char *)); for (i = 0; i <= link_arg_max; i++) - new_link_args [i] = link_args [i]; + new_link_args[i] = link_args[i]; if (link_args) free (link_args); @@ -98,7 +98,7 @@ addarg (str) link_args = new_link_args; } - link_args [link_arg_index] = str; + link_args[link_arg_index] = str; } static void @@ -124,24 +124,24 @@ process_args (p_argc, argv) } /* -B is passed on to gcc */ - if (! strncmp (argv [i], "-B", 2)) + if (! strncmp (argv[i], "-B", 2)) gcc_B_arg = argv[i]; /* -v turns on verbose option here and is passed on to gcc */ - if (! strcmp (argv [i], "-v")) + if (! strcmp (argv[i], "-v")) verbose = 1; - if (! strcmp (argv [i], "-o")) + if (! strcmp (argv[i], "-o")) { o_present = 1; - exec_file_name = argv [i + 1]; + exec_file_name = argv[i + 1]; } - if (! strcmp (argv [i], "-g")) + if (! strcmp (argv[i], "-g")) g_present = 1; - if (! strcmp (argv [i], "-gnatbind")) + if (! strcmp (argv[i], "-gnatbind")) { /* Explicit naming of binder. Grab the value then remove the two arguments from the argument list. */ @@ -151,52 +151,52 @@ process_args (p_argc, argv) exit (1); } - binder_path = __gnat_locate_exec (argv [i + 1], (char *) "."); + binder_path = __gnat_locate_exec (argv[i + 1], (char *) "."); if (!binder_path) { - fprintf (stderr, "Could not locate binder: %s\n", argv [i + 1]); + fprintf (stderr, "Could not locate binder: %s\n", argv[i + 1]); exit (1); } for (j = i + 2; j < *p_argc; j++) - argv [j - 2] = argv [j]; + argv[j - 2] = argv[j]; (*p_argc) -= 2; i--; } - else if (! strcmp (argv [i], "-linkonly")) + else if (! strcmp (argv[i], "-linkonly")) { /* Don't call the binder. Set the flag and then remove the argument from the argument list. */ linkonly = 1; for (j = i + 1; j < *p_argc; j++) - argv [j - 1] = argv [j]; + argv[j - 1] = argv[j]; - (*p_argc) -= 1; + *p_argc -= 1; i--; } - else if (! strcmp (argv [i], "-gnatlink")) + else if (! strcmp (argv[i], "-gnatlink")) { /* Explicit naming of binder. Grab the value then remove the two arguments from the argument list. */ if (i + 1 >= *p_argc) - { - fprintf (stderr, "Missing argument for -gnatlink\n"); - exit (1); - } + { + fprintf (stderr, "Missing argument for -gnatlink\n"); + exit (1); + } - linker_path = __gnat_locate_exec (argv [i + 1], (char *) "."); + linker_path = __gnat_locate_exec (argv[i + 1], (char *) "."); if (!linker_path) { - fprintf (stderr, "Could not locate linker: %s\n", argv [i + 1]); + fprintf (stderr, "Could not locate linker: %s\n", argv[i + 1]); exit (1); } for (j = i + 2; j < *p_argc; j++) - argv [j - 2] = argv [j]; - (*p_argc) -= 2; + argv[j - 2] = argv[j]; + *p_argc -= 2; i--; } } @@ -214,11 +214,11 @@ main (argc, argv) #ifdef VMS /* Warning: getenv only retrieves the first directory in VAXC$PATH */ char *pathval = - strdup (__gnat_to_canonical_dir_spec (getenv ("VAXC$PATH"), 0)); + xstrdup (__gnat_to_canonical_dir_spec (getenv ("VAXC$PATH"), 0)); #else char *pathval = getenv ("PATH"); #endif - char *spawn_args [5]; + char *spawn_args[5]; int spawn_index = 0; #if defined (__EMX__) || defined(MSDOS) @@ -290,9 +290,9 @@ main (argc, argv) for (i = 1; i < argc; i++) { - int arg_len = strlen (argv [i]); + int arg_len = strlen (argv[i]); - if (arg_len > 4 && ! strcmp (&argv [i][arg_len - 4], ".ali")) + if (arg_len > 4 && ! strcmp (&argv[i][arg_len - 4], ".ali")) { if (done_an_ali) { @@ -303,24 +303,24 @@ main (argc, argv) done_an_ali = 1; - if (__gnat_is_regular_file (argv [i])) + if (__gnat_is_regular_file (argv[i])) { ali_file_name = argv[i]; if (!linkonly) { /* Run gnatbind */ spawn_index = 0; - spawn_args [spawn_index++] = binder_path; - spawn_args [spawn_index++] = ali_file_name; + spawn_args[spawn_index++] = binder_path; + spawn_args[spawn_index++] = ali_file_name; for (j = 0 ; j <= bind_arg_index ; j++ ) - spawn_args [spawn_index++] = bind_args [j]; - spawn_args [spawn_index] = 0; + spawn_args[spawn_index++] = bind_args[j]; + spawn_args[spawn_index] = 0; if (verbose) { int i; for (i = 0; i < 2; i++) - printf ("%s ", spawn_args [i]); + printf ("%s ", spawn_args[i]); putchar ('\n'); } @@ -331,19 +331,19 @@ main (argc, argv) } } else - addarg (argv [i]); + addarg (argv[i]); } #ifdef MSDOS - else if (!strcmp (argv [i], "-o")) + else if (!strcmp (argv[i], "-o")) { - addarg (argv [i]); + addarg (argv[i]); if (i < argc) i++; { char *ptr = strstr (argv[i], ".exe"); - arg_len = strlen (argv [i]); + arg_len = strlen (argv[i]); coff2exe_args[1] = malloc (arg_len + 1); strcpy (coff2exe_args[1], argv[i]); if (ptr != NULL && strlen (ptr) == 4) @@ -354,7 +354,7 @@ main (argc, argv) } #endif else - addarg (argv [i]); + addarg (argv[i]); } if (! done_an_ali) @@ -371,7 +371,7 @@ main (argc, argv) int i; for (i = 0; i < link_arg_index; i++) - printf ("%s ", link_args [i]); + printf ("%s ", link_args[i]); putchar ('\n'); } diff --git a/gcc/ada/gnatchop.adb b/gcc/ada/gnatchop.adb index 9eae58f4c84..725ff4ac4b2 100644 --- a/gcc/ada/gnatchop.adb +++ b/gcc/ada/gnatchop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.3 $ +-- $Revision$ -- -- -- Copyright (C) 1998-2001 Ada Core Technologies, Inc. -- -- -- @@ -49,6 +49,12 @@ procedure Gnatchop is Config_File_Name : constant String_Access := new String'("gnat.adc"); -- The name of the file holding the GNAT configuration pragmas + Gcc : String_Access := new String'("gcc"); + -- May be modified by switch --GCC= + + Gcc_Set : Boolean := False; + -- True if a switch --GCC= is used + Gnat_Cmd : String_Access; -- Command to execute the GNAT compiler @@ -223,9 +229,12 @@ procedure Gnatchop is Integer'Image (Maximum_File_Name_Length); - function Locate_Executable (Program_Name : String) return String_Access; + function Locate_Executable + (Program_Name : String; + Look_For_Prefix : Boolean := True) + return String_Access; -- Locate executable for given program name. This takes into account - -- the target-prefix of the current command. + -- the target-prefix of the current command, if Look_For_Prefix is True. subtype EOL_Length is Natural range 0 .. 2; -- Possible lengths of end of line sequence @@ -492,35 +501,42 @@ procedure Gnatchop is -- Locate_Executable -- ----------------------- - function Locate_Executable (Program_Name : String) return String_Access is + function Locate_Executable + (Program_Name : String; + Look_For_Prefix : Boolean := True) + return String_Access + is Current_Command : constant String := Command_Name; - End_Of_Prefix : Natural; + End_Of_Prefix : Natural := Current_Command'First - 1; Start_Of_Prefix : Positive := Current_Command'First; Result : String_Access; begin - -- Find Start_Of_Prefix - for J in reverse Current_Command'Range loop - if Current_Command (J) = '/' or - Current_Command (J) = Directory_Separator or - Current_Command (J) = ':' - then - Start_Of_Prefix := J + 1; - exit; - end if; - end loop; + if Look_For_Prefix then + -- Find Start_Of_Prefix + + for J in reverse Current_Command'Range loop + if Current_Command (J) = '/' or + Current_Command (J) = Directory_Separator or + Current_Command (J) = ':' + then + Start_Of_Prefix := J + 1; + exit; + end if; + end loop; - -- Find End_Of_Prefix + -- Find End_Of_Prefix - End_Of_Prefix := Start_Of_Prefix - 1; + End_Of_Prefix := Start_Of_Prefix - 1; - for J in reverse Start_Of_Prefix .. Current_Command'Last loop - if Current_Command (J) = '-' then - End_Of_Prefix := J; - exit; - end if; - end loop; + for J in reverse Start_Of_Prefix .. Current_Command'Last loop + if Current_Command (J) = '-' then + End_Of_Prefix := J; + exit; + end if; + end loop; + end if; declare Command : constant String := @@ -1058,10 +1074,14 @@ procedure Gnatchop is -- Scan options first loop - case Getopt ("c gnat? h k? p q r v w x") is + case Getopt ("c gnat? h k? p q r v w x -GCC=!") is when ASCII.NUL => exit; + when '-' => + Gcc := new String'(Parameter); + Gcc_Set := True; + when 'c' => Compilation_Mode := True; @@ -1300,7 +1320,7 @@ procedure Gnatchop is begin Put_Line ("Usage: gnatchop [-c] [-h] [-k#] " & - "[-r] [-p] [-q] [-v] [-w] [-x] file [file ...] [dir]"); + "[-r] [-p] [-q] [-v] [-w] [-x] [--GCC=xx] file [file ...] [dir]"); New_Line; Put_Line @@ -1343,6 +1363,9 @@ procedure Gnatchop is Put_Line (" -x exit on error"); + Put_Line + (" --GCC=xx specify the path of the gnat parser to be used"); + New_Line; Put_Line (" file... list of source files to be chopped"); @@ -1638,14 +1661,6 @@ procedure Gnatchop is -- Start of processing for gnatchop begin - -- Check presence of required executables - - Gnat_Cmd := Locate_Executable ("gcc"); - - if Gnat_Cmd = null then - goto No_Files_Written; - end if; - -- Process command line options and initialize global variables if not Scan_Arguments then @@ -1653,6 +1668,14 @@ begin return; end if; + -- Check presence of required executables + + Gnat_Cmd := Locate_Executable (Gcc.all, not Gcc_Set); + + if Gnat_Cmd = null then + goto No_Files_Written; + end if; + -- First parse all files and read offset information for Num in 1 .. File.Last loop diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 8f7b2e25985..090bf426ce5 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -8,7 +8,7 @@ -- -- -- $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- -- @@ -26,15 +26,32 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Text_IO; use Ada.Text_IO; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with Csets; +with MLib.Tgt; +with MLib.Utl; +with Namet; use Namet; +with Opt; with Osint; use Osint; +with Output; +with Prj; use Prj; +with Prj.Env; +with Prj.Ext; use Prj.Ext; +with Prj.Pars; +with Prj.Util; use Prj.Util; with Sdefault; use Sdefault; +with Snames; use Snames; +with Stringt; use Stringt; +with Table; +with Types; use Types; with Hostparm; use Hostparm; -- Used to determine if we are in VMS or not for error message purposes +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; + with Gnatvsn; with GNAT.OS_Lib; use GNAT.OS_Lib; @@ -43,6 +60,40 @@ with Table; procedure GNATCmd is pragma Ident (Gnatvsn.Gnat_Version_String); + Ada_Include_Path : constant String := "ADA_INCLUDE_PATH"; + Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH"; + + Project_File : String_Access; + Project : Prj.Project_Id; + Current_Verbosity : Prj.Verbosity := Prj.Default; + Tool_Package_Name : Name_Id := No_Name; + + -- This flag indicates a switch -p (for gnatxref and gnatfind) for + -- an old fashioned project file. -p cannot be used in conjonction + -- with -P. + + Old_Project_File_Used : Boolean := False; + + -- A table to keep the switches on the command line + + package Last_Switches is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatcmd.Last_Switches"); + + -- A table to keep the switches from the project file + + package First_Switches is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatcmd.First_Switches"); + ------------------ -- SWITCH TABLE -- ------------------ @@ -56,6 +107,7 @@ procedure GNATCmd is -- DIRECT_TRANSLATION -- | DIRECTORIES_TRANSLATION -- | FILE_TRANSLATION + -- | NO_SPACE_FILE_TRANSL -- | NUMERIC_TRANSLATION -- | STRING_TRANSLATION -- | OPTIONS_TRANSLATION @@ -67,6 +119,7 @@ procedure GNATCmd is -- DIRECTORIES_TRANSLATION ::= =* UNIX_SWITCH * -- DIRECTORY_TRANSLATION ::= =% UNIX_SWITCH % -- FILE_TRANSLATION ::= =@ UNIX_SWITCH @ + -- NO_SPACE_FILE_TRANSL ::= =< UNIX_SWITCH > -- NUMERIC_TRANSLATION ::= =# UNIX_SWITCH # | # number # -- STRING_TRANSLATION ::= =" UNIX_SWITCH " -- OPTIONS_TRANSLATION ::= =OPTION {space OPTION} @@ -106,6 +159,9 @@ procedure GNATCmd is -- file is allowed, not a list of files, and only one unix switch is -- generated as a result. + -- the NO_SPACE_FILE_TRANSL is similar to FILE_TRANSLATION, except that + -- no space is inserted between the switch and the file name. + -- The NUMERIC_TRANSLATION format is similar to the FILE_TRANSLATION case -- except that the parameter is a decimal integer in the range 0 to 999. @@ -169,8 +225,8 @@ procedure GNATCmd is S_Ext_Ref : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & "-X" & '"'; - S_Project_File : aliased constant S := "/PROJECT_FILE=*" & - "-P*"; + S_Project_File : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; S_Project_Verb : aliased constant S := "/PROJECT_FILE_VERBOSITY=" & "DEFAULT " & "-vP0 " & @@ -220,12 +276,26 @@ procedure GNATCmd is S_Bind_Error : aliased constant S := "/ERROR_LIMIT=#" & "-m#"; + S_Bind_Help : aliased constant S := "/HELP " & + "-h"; + + S_Bind_Init : aliased constant S := "/INITIALIZE_SCALARS=" & + "INVALID " & + "-Sin " & + "LOW " & + "-Slo " & + "HIGH " & + "-Shi"; + S_Bind_Library : aliased constant S := "/LIBRARY_SEARCH=*" & "-aO*"; S_Bind_Linker : aliased constant S := "/LINKER_OPTION_LIST " & "-K"; + S_Bind_List : aliased constant S := "/LIST_RESTRICTIONS " & + "-r"; + S_Bind_Main : aliased constant S := "/MAIN " & "!-n"; @@ -235,6 +305,9 @@ procedure GNATCmd is S_Bind_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & "-nostdlib"; + S_Bind_No_Time : aliased constant S := "/NO_TIME_STAMP_CHECK " & + "-t"; + S_Bind_Object : aliased constant S := "/OBJECT_LIST " & "-O"; @@ -261,8 +334,8 @@ procedure GNATCmd is S_Bind_ReadX : aliased constant S := "/NOREAD_SOURCES " & "-x"; - S_Bind_Rename : aliased constant S := "/RENAME_MAIN " & - "-r"; + S_Bind_Rename : aliased constant S := "/RENAME_MAIN=<" & + "-M>"; S_Bind_Report : aliased constant S := "/REPORT_ERRORS=" & "VERBOSE " & @@ -275,11 +348,20 @@ procedure GNATCmd is S_Bind_ReportX : aliased constant S := "/NOREPORT_ERRORS " & "!-b,!-v"; + S_Bind_Restr : aliased constant S := "/RESTRICTION_LIST " & + "-r"; + + S_Bind_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" & + "--RTS=|"; + S_Bind_Search : aliased constant S := "/SEARCH=*" & "-I*"; S_Bind_Shared : aliased constant S := "/SHARED " & - "-shared"; + "-shared"; + + S_Bind_Slice : aliased constant S := "/TIME_SLICE=#" & + "-T#"; S_Bind_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; @@ -299,41 +381,48 @@ procedure GNATCmd is "-we"; S_Bind_WarnX : aliased constant S := "/NOWARNINGS " & - "-ws"; - - Bind_Switches : aliased constant Switches := ( - S_Bind_Bind 'Access, - S_Bind_Build 'Access, - S_Bind_Current 'Access, - S_Bind_Debug 'Access, - S_Bind_DebugX 'Access, - S_Bind_Elab 'Access, - S_Bind_Error 'Access, - S_Ext_Ref 'Access, - S_Bind_Library 'Access, - S_Bind_Linker 'Access, - S_Bind_Main 'Access, - S_Bind_Nostinc 'Access, - S_Bind_Nostlib 'Access, - S_Bind_Object 'Access, - S_Bind_Order 'Access, - S_Bind_Output 'Access, - S_Bind_OutputX 'Access, - S_Bind_Pess 'Access, - S_Project_File 'Access, - S_Project_Verb 'Access, - S_Bind_Read 'Access, - S_Bind_ReadX 'Access, - S_Bind_Rename 'Access, - S_Bind_Report 'Access, - S_Bind_ReportX 'Access, - S_Bind_Search 'Access, - S_Bind_Shared 'Access, - S_Bind_Source 'Access, - S_Bind_Time 'Access, - S_Bind_Verbose 'Access, - S_Bind_Warn 'Access, - S_Bind_WarnX 'Access); + "-ws"; + + Bind_Switches : aliased constant Switches := + (S_Bind_Bind 'Access, + S_Bind_Build 'Access, + S_Bind_Current 'Access, + S_Bind_Debug 'Access, + S_Bind_DebugX 'Access, + S_Bind_Elab 'Access, + S_Bind_Error 'Access, + S_Ext_Ref 'Access, + S_Bind_Help 'Access, + S_Bind_Init 'Access, + S_Bind_Library 'Access, + S_Bind_Linker 'Access, + S_Bind_List 'Access, + S_Bind_Main 'Access, + S_Bind_Nostinc 'Access, + S_Bind_Nostlib 'Access, + S_Bind_No_Time 'Access, + S_Bind_Object 'Access, + S_Bind_Order 'Access, + S_Bind_Output 'Access, + S_Bind_OutputX 'Access, + S_Bind_Pess 'Access, + S_Project_File 'Access, + S_Project_Verb 'Access, + S_Bind_Read 'Access, + S_Bind_ReadX 'Access, + S_Bind_Rename 'Access, + S_Bind_Report 'Access, + S_Bind_ReportX 'Access, + S_Bind_Restr 'Access, + S_Bind_RTS 'Access, + S_Bind_Search 'Access, + S_Bind_Shared 'Access, + S_Bind_Slice 'Access, + S_Bind_Source 'Access, + S_Bind_Time 'Access, + S_Bind_Verbose 'Access, + S_Bind_Warn 'Access, + S_Bind_WarnX 'Access); ---------------------------- -- Switches for GNAT CHOP -- @@ -363,28 +452,28 @@ procedure GNATCmd is S_Chop_Verb : aliased constant S := "/VERBOSE " & "-v"; - Chop_Switches : aliased constant Switches := ( - S_Chop_Comp 'Access, - S_Chop_File 'Access, - S_Chop_Help 'Access, - S_Chop_Over 'Access, - S_Chop_Pres 'Access, - S_Chop_Quiet 'Access, - S_Chop_Ref 'Access, - S_Chop_Verb 'Access); + Chop_Switches : aliased constant Switches := + (S_Chop_Comp 'Access, + S_Chop_File 'Access, + S_Chop_Help 'Access, + S_Chop_Over 'Access, + S_Chop_Pres 'Access, + S_Chop_Quiet 'Access, + S_Chop_Ref 'Access, + S_Chop_Verb 'Access); ------------------------------- -- Switches for GNAT COMPILE -- ------------------------------- S_GCC_Ada_83 : aliased constant S := "/83 " & - "-gnat83"; + "-gnat83"; S_GCC_Ada_95 : aliased constant S := "/95 " & - "!-gnat83"; + "!-gnat83"; S_GCC_Asm : aliased constant S := "/ASM " & - "-S,!-c"; + "-S,!-c"; S_GCC_Checks : aliased constant S := "/CHECKS=" & "FULL " & @@ -404,10 +493,13 @@ procedure GNATCmd is "-gnatp,!-gnato,!-gnatE"; S_GCC_Compres : aliased constant S := "/COMPRESS_NAMES " & - "-gnatC"; + "-gnatC"; + + S_GCC_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" & + "-gnatec>"; S_GCC_Current : aliased constant S := "/CURRENT_DIRECTORY " & - "!-I-"; + "!-I-"; S_GCC_Debug : aliased constant S := "/DEBUG=" & "SYMBOLS " & @@ -424,13 +516,13 @@ procedure GNATCmd is "-g0"; S_GCC_DebugX : aliased constant S := "/NODEBUG " & - "!-g"; + "!-g"; S_GCC_Dist : aliased constant S := "/DISTRIBUTION_STUBS=" & "RECEIVER " & "-gnatzr " & "CALLER " & - "-gnatzc"; + "-gnatzc"; S_GCC_DistX : aliased constant S := "/NODISTRIBUTION_STUBS " & "!-gnatzr,!-gnatzc"; @@ -453,6 +545,9 @@ procedure GNATCmd is S_GCC_Force : aliased constant S := "/FORCE_ALI " & "-gnatQ"; + S_GCC_Help : aliased constant S := "/HELP " & + "-gnath"; + S_GCC_Ident : aliased constant S := "/IDENTIFIER_CHARACTER_SET=" & "DEFAULT " & "-gnati1 " & @@ -480,23 +575,37 @@ procedure GNATCmd is S_GCC_IdentX : aliased constant S := "/NOIDENTIFIER_CHARACTER_SET " & "-gnati1"; + S_GCC_Immed : aliased constant S := "/IMMEDIATE_ERRORS " & + "-gnatdO"; + S_GCC_Inline : aliased constant S := "/INLINE=" & "PRAGMA " & "-gnatn " & + "FULL " & + "-gnatN " & "SUPPRESS " & - "-fno-inline"; + "-fno-inline"; S_GCC_InlineX : aliased constant S := "/NOINLINE " & - "!-gnatn"; + "!-gnatn"; + + S_GCC_Jumps : aliased constant S := "/LONGJMP_SETJMP " & + "-gnatL"; + + S_GCC_Length : aliased constant S := "/MAX_LINE_LENGTH=#" & + "-gnatyM#"; S_GCC_List : aliased constant S := "/LIST " & - "-gnatl"; + "-gnatl"; + + S_GCC_Noadc : aliased constant S := "/NO_GNAT_ADC " & + "-gnatA"; S_GCC_Noload : aliased constant S := "/NOLOAD " & - "-gnatc"; + "-gnatc"; S_GCC_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & - "-nostdinc"; + "-nostdinc"; S_GCC_Opt : aliased constant S := "/OPTIMIZE=" & "ALL " & @@ -515,6 +624,9 @@ procedure GNATCmd is S_GCC_OptX : aliased constant S := "/NOOPTIMIZE " & "-O0,!-O1,!-O2,!-O3"; + S_GCC_Polling : aliased constant S := "/POLLING " & + "-gnatP"; + S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" & "VERBOSE " & "-gnatv " & @@ -532,15 +644,15 @@ procedure GNATCmd is S_GCC_Repinfo : aliased constant S := "/REPRESENTATION_INFO=" & "ARRAYS " & - "-gnatR1 " & + "-gnatR1 " & "NONE " & - "-gnatR0 " & + "-gnatR0 " & "OBJECTS " & - "-gnatR2 " & + "-gnatR2 " & "SYMBOLIC " & - "-gnatR3 " & + "-gnatR3 " & "DEFAULT " & - "-gnatR"; + "-gnatR"; S_GCC_RepinfX : aliased constant S := "/NOREPRESENTATION_INFO " & "!-gnatR"; @@ -599,7 +711,7 @@ procedure GNATCmd is "!-gnatg,!-gnatr " & "PRAGMA " & "-gnatyp " & - "REFERENCES " & + "RM_COLUMN_LAYOUT " & "-gnatr " & "SPECS " & "-gnatys " & @@ -632,45 +744,45 @@ procedure GNATCmd is S_GCC_Valid : aliased constant S := "/VALIDITY_CHECKING=" & "DEFAULT " & - "-gnatVd " & + "-gnatVd " & "NODEFAULT " & - "-gnatVD " & + "-gnatVD " & "COPIES " & - "-gnatVc " & + "-gnatVc " & "NOCOPIES " & - "-gnatVC " & + "-gnatVC " & "FLOATS " & - "-gnatVf " & + "-gnatVf " & "NOFLOATS " & - "-gnatVF " & + "-gnatVF " & "IN_PARAMS " & - "-gnatVi " & + "-gnatVi " & "NOIN_PARAMS " & - "-gnatVI " & + "-gnatVI " & "MOD_PARAMS " & - "-gnatVm " & + "-gnatVm " & "NOMOD_PARAMS " & - "-gnatVM " & + "-gnatVM " & "OPERANDS " & - "-gnatVo " & + "-gnatVo " & "NOOPERANDS " & - "-gnatVO " & + "-gnatVO " & "RETURNS " & - "-gnatVr " & + "-gnatVr " & "NORETURNS " & - "-gnatVR " & + "-gnatVR " & "SUBSCRIPTS " & - "-gnatVs " & + "-gnatVs " & "NOSUBSCRIPTS " & - "-gnatVS " & + "-gnatVS " & "TESTS " & - "-gnatVt " & + "-gnatVt " & "NOTESTS " & - "-gnatVT " & + "-gnatVT " & "ALL " & - "-gnatVa " & + "-gnatVa " & "NONE " & - "-gnatVn"; + "-gnatVn"; S_GCC_Verbose : aliased constant S := "/VERBOSE " & "-v"; @@ -680,10 +792,18 @@ procedure GNATCmd is "!-gnatws,!-gnatwe " & "ALL_GCC " & "-Wall " & + "BIASED_ROUNDING " & + "-gnatwb " & + "NOBIASED_ROUNDING " & + "-gnatwB " & "CONDITIONALS " & "-gnatwc " & "NOCONDITIONALS " & "-gnatwC " & + "IMPLICIT_DEREFERENCE " & + "-gnatwd " & + "NO_IMPLICIT_DEREFERENCE " & + "-gnatwD " & "ELABORATION " & "-gnatwl " & "NOELABORATION " & @@ -698,6 +818,10 @@ procedure GNATCmd is "-gnatwi " & "NOIMPLEMENTATION " & "-gnatwI " & + "INEFFECTIVE_INLINE " & + "-gnatwp " & + "NOINEFFECTIVE_INLINE " & + "-gnatwP " & "OPTIONAL " & "-gnatwa " & "NOOPTIONAL " & @@ -714,6 +838,10 @@ procedure GNATCmd is "-gnatws " & "UNINITIALIZED " & "-Wuninitialized " & + "UNREFERENCED_FORMALS " & + "-gnatwf " & + "NOUNREFERENCED_FORMALS " & + "-gnatwF " & "UNUSED " & "-gnatwu " & "NOUNUSED " & @@ -739,66 +867,76 @@ procedure GNATCmd is "-gnatWe"; S_GCC_WideX : aliased constant S := "/NOWIDE_CHARACTER_ENCODING " & - "-gnatWn"; + "-gnatWn"; S_GCC_Xdebug : aliased constant S := "/XDEBUG " & - "-gnatD"; + "-gnatD"; S_GCC_Xref : aliased constant S := "/XREF=" & "GENERATE " & - "!-gnatx " & + "!-gnatx " & "SUPPRESS " & - "-gnatx"; - - GCC_Switches : aliased constant Switches := ( - S_GCC_Ada_83 'Access, - S_GCC_Ada_95 'Access, - S_GCC_Asm 'Access, - S_GCC_Checks 'Access, - S_GCC_ChecksX 'Access, - S_GCC_Compres 'Access, - S_GCC_Current 'Access, - S_GCC_Debug 'Access, - S_GCC_DebugX 'Access, - S_GCC_Dist 'Access, - S_GCC_DistX 'Access, - S_GCC_Error 'Access, - S_GCC_ErrorX 'Access, - S_GCC_Expand 'Access, - S_GCC_Extend 'Access, - S_GCC_File 'Access, - S_GCC_Force 'Access, - S_GCC_Ident 'Access, - S_GCC_IdentX 'Access, - S_GCC_Inline 'Access, - S_GCC_InlineX 'Access, - S_GCC_List 'Access, - S_GCC_Noload 'Access, - S_GCC_Nostinc 'Access, - S_GCC_Opt 'Access, - S_GCC_OptX 'Access, - S_GCC_Report 'Access, - S_GCC_ReportX 'Access, - S_GCC_Repinfo 'Access, - S_GCC_RepinfX 'Access, - S_GCC_Search 'Access, - S_GCC_Style 'Access, - S_GCC_StyleX 'Access, - S_GCC_Syntax 'Access, - S_GCC_Trace 'Access, - S_GCC_Tree 'Access, - S_GCC_Trys 'Access, - S_GCC_Units 'Access, - S_GCC_Unique 'Access, - S_GCC_Upcase 'Access, - S_GCC_Valid 'Access, - S_GCC_Verbose 'Access, - S_GCC_Warn 'Access, - S_GCC_WarnX 'Access, - S_GCC_Wide 'Access, - S_GCC_WideX 'Access, - S_GCC_Xdebug 'Access, - S_GCC_Xref 'Access); + "-gnatx"; + + GCC_Switches : aliased constant Switches := + (S_GCC_Ada_83 'Access, + S_GCC_Ada_95 'Access, + S_GCC_Asm 'Access, + S_GCC_Checks 'Access, + S_GCC_ChecksX 'Access, + S_GCC_Compres 'Access, + S_GCC_Config 'Access, + S_GCC_Current 'Access, + S_GCC_Debug 'Access, + S_GCC_DebugX 'Access, + S_GCC_Dist 'Access, + S_GCC_DistX 'Access, + S_GCC_Error 'Access, + S_GCC_ErrorX 'Access, + S_GCC_Expand 'Access, + S_GCC_Extend 'Access, + S_Ext_Ref 'Access, + S_GCC_File 'Access, + S_GCC_Force 'Access, + S_GCC_Help 'Access, + S_GCC_Ident 'Access, + S_GCC_IdentX 'Access, + S_GCC_Immed 'Access, + S_GCC_Inline 'Access, + S_GCC_InlineX 'Access, + S_GCC_Jumps 'Access, + S_GCC_Length 'Access, + S_GCC_List 'Access, + S_GCC_Noadc 'Access, + S_GCC_Noload 'Access, + S_GCC_Nostinc 'Access, + S_GCC_Opt 'Access, + S_GCC_OptX 'Access, + S_GCC_Polling 'Access, + S_Project_File'Access, + S_Project_Verb'Access, + S_GCC_Report 'Access, + S_GCC_ReportX 'Access, + S_GCC_Repinfo 'Access, + S_GCC_RepinfX 'Access, + S_GCC_Search 'Access, + S_GCC_Style 'Access, + S_GCC_StyleX 'Access, + S_GCC_Syntax 'Access, + S_GCC_Trace 'Access, + S_GCC_Tree 'Access, + S_GCC_Trys 'Access, + S_GCC_Units 'Access, + S_GCC_Unique 'Access, + S_GCC_Upcase 'Access, + S_GCC_Valid 'Access, + S_GCC_Verbose 'Access, + S_GCC_Warn 'Access, + S_GCC_WarnX 'Access, + S_GCC_Wide 'Access, + S_GCC_WideX 'Access, + S_GCC_Xdebug 'Access, + S_GCC_Xref 'Access); ---------------------------- -- Switches for GNAT ELIM -- @@ -807,16 +945,28 @@ procedure GNATCmd is S_Elim_All : aliased constant S := "/ALL " & "-a"; + S_Elim_Bind : aliased constant S := "/BIND_FILE=<" & + "-b>"; + S_Elim_Miss : aliased constant S := "/MISSED " & "-m"; + S_Elim_Quiet : aliased constant S := "/QUIET " & + "-q"; + + S_Elim_Tree : aliased constant S := "/TREE_DIRS=*" & + "-T*"; + S_Elim_Verb : aliased constant S := "/VERBOSE " & "-v"; - Elim_Switches : aliased constant Switches := ( - S_Elim_All 'Access, - S_Elim_Miss 'Access, - S_Elim_Verb 'Access); + Elim_Switches : aliased constant Switches := + (S_Elim_All 'Access, + S_Elim_Bind 'Access, + S_Elim_Miss 'Access, + S_Elim_Quiet 'Access, + S_Elim_Tree 'Access, + S_Elim_Verb 'Access); ---------------------------- -- Switches for GNAT FIND -- @@ -825,6 +975,9 @@ procedure GNATCmd is S_Find_All : aliased constant S := "/ALL_FILES " & "-a"; + S_Find_Deriv : aliased constant S := "/DERIVED_TYPE_INFORMATION " & + "-d"; + S_Find_Expr : aliased constant S := "/EXPRESSIONS " & "-e"; @@ -834,6 +987,12 @@ procedure GNATCmd is S_Find_Ignore : aliased constant S := "/IGNORE_LOCALS " & "-g"; + S_Find_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + + S_Find_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & + "-nostdlib"; + S_Find_Object : aliased constant S := "/OBJECT_SEARCH=*" & "-aO*"; @@ -852,12 +1011,18 @@ procedure GNATCmd is S_Find_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; - Find_Switches : aliased constant Switches := ( - S_Find_All 'Access, + S_Find_Types : aliased constant S := "/TYPE_HIERARCHY " & + "-t"; + + Find_Switches : aliased constant Switches := + (S_Find_All 'Access, + S_Find_Deriv 'Access, S_Find_Expr 'Access, S_Ext_Ref 'Access, S_Find_Full 'Access, S_Find_Ignore 'Access, + S_Find_Nostinc 'Access, + S_Find_Nostlib 'Access, S_Find_Object 'Access, S_Find_Print 'Access, S_Find_Project 'Access, @@ -865,7 +1030,8 @@ procedure GNATCmd is S_Project_Verb 'Access, S_Find_Ref 'Access, S_Find_Search 'Access, - S_Find_Source 'Access); + S_Find_Source 'Access, + S_Find_Types 'Access); ------------------------------ -- Switches for GNAT KRUNCH -- @@ -874,8 +1040,8 @@ procedure GNATCmd is S_Krunch_Count : aliased constant S := "/COUNT=#" & "`#"; - Krunch_Switches : aliased constant Switches := (1 .. 1 => - S_Krunch_Count 'Access); + Krunch_Switches : aliased constant Switches := + (1 .. 1 => S_Krunch_Count 'Access); ------------------------------- -- Switches for GNAT LIBRARY -- @@ -885,19 +1051,19 @@ procedure GNATCmd is "--config=@"; S_Lbr_Create : aliased constant S := "/CREATE=%" & - "--create=%"; + "--create=%"; S_Lbr_Delete : aliased constant S := "/DELETE=%" & - "--delete=%"; + "--delete=%"; S_Lbr_Set : aliased constant S := "/SET=%" & - "--set=%"; + "--set=%"; - Lbr_Switches : aliased constant Switches := ( - S_Lbr_Config 'Access, - S_Lbr_Create 'Access, - S_Lbr_Delete 'Access, - S_Lbr_Set 'Access); + Lbr_Switches : aliased constant Switches := + (S_Lbr_Config 'Access, + S_Lbr_Create 'Access, + S_Lbr_Delete 'Access, + S_Lbr_Set 'Access); ---------------------------- -- Switches for GNAT LINK -- @@ -922,6 +1088,9 @@ procedure GNATCmd is S_Link_Execut : aliased constant S := "/EXECUTABLE=@" & "-o@"; + S_Link_Force : aliased constant S := "/FORCE_OBJECT_FILE_LIST " & + "-f"; + S_Link_Ident : aliased constant S := "/IDENTIFICATION=" & '"' & "--for-linker=IDENT=" & '"'; @@ -944,11 +1113,12 @@ procedure GNATCmd is S_Link_ZZZZZ : aliased constant S := "/<other> " & "--for-linker="; - Link_Switches : aliased constant Switches := ( - S_Link_Bind 'Access, + Link_Switches : aliased constant Switches := + (S_Link_Bind 'Access, S_Link_Debug 'Access, S_Link_Execut 'Access, S_Ext_Ref 'Access, + S_Link_Force 'Access, S_Link_Ident 'Access, S_Link_Nocomp 'Access, S_Link_Nofiles 'Access, @@ -969,9 +1139,6 @@ procedure GNATCmd is S_List_Current : aliased constant S := "/CURRENT_DIRECTORY " & "!-I-"; - S_List_Depend : aliased constant S := "/DEPENDENCIES " & - "-d"; - S_List_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & "-nostdinc"; @@ -981,6 +1148,8 @@ procedure GNATCmd is S_List_Output : aliased constant S := "/OUTPUT=" & "SOURCES " & "-s " & + "DEPEND " & + "-d " & "OBJECTS " & "-o " & "UNITS " & @@ -996,18 +1165,17 @@ procedure GNATCmd is S_List_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; - List_Switches : aliased constant Switches := ( - S_List_All 'Access, - S_List_Current 'Access, - S_List_Depend 'Access, - S_Ext_Ref 'Access, - S_List_Nostinc 'Access, - S_List_Object 'Access, - S_List_Output 'Access, - S_Project_File 'Access, - S_Project_Verb 'Access, - S_List_Search 'Access, - S_List_Source 'Access); + List_Switches : aliased constant Switches := + (S_List_All 'Access, + S_List_Current 'Access, + S_Ext_Ref 'Access, + S_List_Nostinc 'Access, + S_List_Object 'Access, + S_List_Output 'Access, + S_Project_File 'Access, + S_Project_Verb 'Access, + S_List_Search 'Access, + S_List_Source 'Access); ---------------------------- -- Switches for GNAT MAKE -- @@ -1015,11 +1183,11 @@ procedure GNATCmd is S_Make_Actions : aliased constant S := "/ACTIONS=" & "COMPILE " & - "-c " & + "-c " & "BIND " & - "-b " & + "-b " & "LINK " & - "-l "; + "-l "; S_Make_All : aliased constant S := "/ALL_FILES " & "-a"; @@ -1052,7 +1220,7 @@ procedure GNATCmd is "-f"; S_Make_Inplace : aliased constant S := "/IN_PLACE " & - "-i"; + "-i"; S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" & "-L*"; @@ -1060,12 +1228,18 @@ procedure GNATCmd is S_Make_Link : aliased constant S := "/LINKER_QUALIFIERS=?" & "-largs LINK"; + S_Make_Mapping : aliased constant S := "/MAPPING " & + "-C"; + S_Make_Minimal : aliased constant S := "/MINIMAL_RECOMPILATION " & - "-m"; + "-m"; S_Make_Nolink : aliased constant S := "/NOLINK " & "-c"; + S_Make_Nomain : aliased constant S := "/NOMAIN " & + "-z"; + S_Make_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & "-nostdinc"; @@ -1087,6 +1261,9 @@ procedure GNATCmd is S_Make_Reason : aliased constant S := "/REASONS " & "-v"; + S_Make_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" & + "--RTS=|"; + S_Make_Search : aliased constant S := "/SEARCH=*" & "-I*"; @@ -1096,45 +1273,89 @@ procedure GNATCmd is S_Make_Source : aliased constant S := "/SOURCE_SEARCH=*" & "-aI*"; + S_Make_Switch : aliased constant S := "/SWITCH_CHECK " & + "-s"; + + S_Make_Unique : aliased constant S := "/UNIQUE " & + "-u"; + S_Make_Verbose : aliased constant S := "/VERBOSE " & "-v"; - Make_Switches : aliased constant Switches := ( - S_Make_Actions 'Access, - S_Make_All 'Access, - S_Make_Bind 'Access, - S_Make_Comp 'Access, - S_Make_Cond 'Access, - S_Make_Cont 'Access, - S_Make_Current 'Access, - S_Make_Dep 'Access, - S_Make_Doobj 'Access, - S_Make_Execut 'Access, - S_Ext_Ref 'Access, - S_Make_Force 'Access, - S_Make_Inplace 'Access, - S_Make_Library 'Access, - S_Make_Link 'Access, - S_Make_Minimal 'Access, - S_Make_Nolink 'Access, - S_Make_Nostinc 'Access, - S_Make_Nostlib 'Access, - S_Make_Object 'Access, - S_Make_Proc 'Access, - S_Project_File 'Access, - S_Project_Verb 'Access, - S_Make_Nojobs 'Access, - S_Make_Quiet 'Access, - S_Make_Reason 'Access, - S_Make_Search 'Access, - S_Make_Skip 'Access, - S_Make_Source 'Access, - S_Make_Verbose 'Access); + Make_Switches : aliased constant Switches := + (S_Make_Actions 'Access, + S_Make_All 'Access, + S_Make_Bind 'Access, + S_Make_Comp 'Access, + S_Make_Cond 'Access, + S_Make_Cont 'Access, + S_Make_Current 'Access, + S_Make_Dep 'Access, + S_Make_Doobj 'Access, + S_Make_Execut 'Access, + S_Ext_Ref 'Access, + S_Make_Force 'Access, + S_Make_Inplace 'Access, + S_Make_Library 'Access, + S_Make_Link 'Access, + S_Make_Mapping 'Access, + S_Make_Minimal 'Access, + S_Make_Nolink 'Access, + S_Make_Nomain 'Access, + S_Make_Nostinc 'Access, + S_Make_Nostlib 'Access, + S_Make_Object 'Access, + S_Make_Proc 'Access, + S_Project_File 'Access, + S_Project_Verb 'Access, + S_Make_Nojobs 'Access, + S_Make_Quiet 'Access, + S_Make_Reason 'Access, + S_Make_RTS 'Access, + S_Make_Search 'Access, + S_Make_Skip 'Access, + S_Make_Source 'Access, + S_Make_Switch 'Access, + S_Make_Unique 'Access, + S_Make_Verbose 'Access); + + ---------------------------- + -- Switches for GNAT Name -- + ---------------------------- + + S_Name_Conf : aliased constant S := "/CONFIG_FILE=<" & + "-c>"; + + S_Name_Dirs : aliased constant S := "/SOURCE_DIRS=*" & + "-d*"; + + S_Name_Dfile : aliased constant S := "/DIRS_FILE=<" & + "-D>"; + + S_Name_Help : aliased constant S := "/HELP" & + " -h"; + + S_Name_Proj : aliased constant S := "/PROJECT_FILE=<" & + "-P>"; + + S_Name_Verbose : aliased constant S := "/VERBOSE" & + " -v"; + + Name_Switches : aliased constant Switches := + (S_Name_Conf 'Access, + S_Name_Dirs 'Access, + S_Name_Dfile 'Access, + S_Name_Help 'Access, + S_Name_Proj 'Access, + S_Name_Verbose 'Access); ---------------------------------- -- Switches for GNAT PREPROCESS -- ---------------------------------- + S_Prep_Assoc : aliased constant S := "/ASSOCIATE=" & '"' & + "-D" & '"'; + S_Prep_Blank : aliased constant S := "/BLANK_LINES " & "-b"; @@ -1153,21 +1374,14 @@ procedure GNATCmd is S_Prep_Undef : aliased constant S := "/UNDEFINED " & "-u"; - S_Prep_Verbose : aliased constant S := "/VERBOSE " & - "-v"; - - S_Prep_Version : aliased constant S := "/VERSION " & - "-v"; - - Prep_Switches : aliased constant Switches := ( - S_Prep_Blank 'Access, - S_Prep_Com 'Access, - S_Prep_Ref 'Access, - S_Prep_Remove 'Access, - S_Prep_Symbols 'Access, - S_Prep_Undef 'Access, - S_Prep_Verbose 'Access, - S_Prep_Version 'Access); + Prep_Switches : aliased constant Switches := + (S_Prep_Assoc 'Access, + S_Prep_Blank 'Access, + S_Prep_Com 'Access, + S_Prep_Ref 'Access, + S_Prep_Remove 'Access, + S_Prep_Symbols 'Access, + S_Prep_Undef 'Access); ------------------------------ -- Switches for GNAT SHARED -- @@ -1202,8 +1416,8 @@ procedure GNATCmd is S_Shared_ZZZZZ : aliased constant S := "/<other> " & "--for-linker="; - Shared_Switches : aliased constant Switches := ( - S_Shared_Debug 'Access, + Shared_Switches : aliased constant Switches := + (S_Shared_Debug 'Access, S_Shared_Image 'Access, S_Shared_Ident 'Access, S_Shared_Nofiles 'Access, @@ -1256,22 +1470,16 @@ procedure GNATCmd is S_Stub_Verbose : aliased constant S := "/VERBOSE " & "-v"; - Stub_Switches : aliased constant Switches := ( - S_Stub_Current 'Access, - S_Stub_Full 'Access, - S_Stub_Header 'Access, - S_Stub_Indent 'Access, - S_Stub_Length 'Access, - S_Stub_Quiet 'Access, - S_Stub_Search 'Access, - S_Stub_Tree 'Access, - S_Stub_Verbose 'Access); - - ------------------------------ - -- Switches for GNAT SYSTEM -- - ------------------------------ - - System_Switches : aliased constant Switches := (1 .. 0 => null); + Stub_Switches : aliased constant Switches := + (S_Stub_Current 'Access, + S_Stub_Full 'Access, + S_Stub_Header 'Access, + S_Stub_Indent 'Access, + S_Stub_Length 'Access, + S_Stub_Quiet 'Access, + S_Stub_Search 'Access, + S_Stub_Tree 'Access, + S_Stub_Verbose 'Access); ---------------------------- -- Switches for GNAT XREF -- @@ -1280,12 +1488,21 @@ procedure GNATCmd is S_Xref_All : aliased constant S := "/ALL_FILES " & "-a"; + S_Xref_Deriv : aliased constant S := "/DERIVED_TYPES " & + "-d"; + S_Xref_Full : aliased constant S := "/FULL_PATHNAME " & "-f"; S_Xref_Global : aliased constant S := "/IGNORE_LOCALS " & "-g"; + S_Xref_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & + "-nostdinc"; + + S_Xref_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & + "-nostdlib"; + S_Xref_Object : aliased constant S := "/OBJECT_SEARCH=*" & "-aO*"; @@ -1301,18 +1518,25 @@ procedure GNATCmd is S_Xref_Output : aliased constant S := "/UNUSED " & "-u"; - Xref_Switches : aliased constant Switches := ( - S_Xref_All 'Access, + S_Xref_Tags : aliased constant S := "/TAGS " & + "-v"; + + Xref_Switches : aliased constant Switches := + (S_Xref_All 'Access, + S_Xref_Deriv 'Access, S_Ext_Ref 'Access, S_Xref_Full 'Access, S_Xref_Global 'Access, + S_Xref_Nostinc 'Access, + S_Xref_Nostlib 'Access, S_Xref_Object 'Access, S_Xref_Project 'Access, S_Project_File 'Access, S_Project_Verb 'Access, S_Xref_Search 'Access, S_Xref_Source 'Access, - S_Xref_Output 'Access); + S_Xref_Output 'Access, + S_Xref_Tags 'Access); ------------------- -- COMMAND TABLE -- @@ -1334,9 +1558,13 @@ procedure GNATCmd is -- A parameter that's passed through as is (not canonicalized) Unlimited_Files, - -- An unlimited number of writespace separate file or directory + -- An unlimited number of whitespace separate file or directory -- parameters including wildcard specifications. + Unlimited_As_Is, + -- Un unlimited number of whitespace separated paameters that are + -- passed through as is (not canonicalized). + Files_Or_Wildcard); -- A comma separated list of files and/or wildcard file specifications. -- A comma preceded by or followed by whitespace is considered as a @@ -1345,6 +1573,23 @@ procedure GNATCmd is type Parameter_Array is array (Natural range <>) of Parameter_Type; type Parameter_Ref is access all Parameter_Array; + type Command_Type is + (Bind, Chop, Compile, Elim, Find, Krunch, Library, Link, List, + Make, Name, Preprocess, Shared, Standard, Stub, Xref, Undefined); + + type Alternate_Command is (Comp, Ls, Kr, Prep, Psta); + -- Alternate command libel for non VMS system + + Corresponding_To : constant array (Alternate_Command) of Command_Type := + (Comp => Compile, + Ls => List, + Kr => Krunch, + Prep => Preprocess, + Psta => Standard); + -- Mapping of alternate commands to commands + + subtype Real_Command_Type is Command_Type range Bind .. Xref; + type Command_Entry is record Cname : String_Ptr; -- Command name for GNAT xxx command @@ -1352,9 +1597,15 @@ procedure GNATCmd is Usage : String_Ptr; -- A usage string, used for error messages - Unixcmd : String_Ptr; + Unixcmd : String_Ptr; -- Corresponding Unix command + Unixsws : Argument_List_Access; + -- Switches for the Unix command + + VMS_Only : Boolean; + -- When True, the command can only be used on VMS + Switches : Switches_Ptr; -- Pointer to array of switch strings @@ -1398,9 +1649,13 @@ procedure GNATCmd is -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB] T_File, - -- A quailifier followed by a filename + -- A qualifier followed by a filename -- Example: GNAT LINK /EXECUTABLE=FOO.EXE + T_No_Space_File, + -- A qualifier followed by a filename + -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR + T_Numeric, -- A qualifier followed by a numeric value. -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39 @@ -1429,7 +1684,7 @@ procedure GNATCmd is -- A qualifier followed by a legal linker symbol prefix. Only used -- for BIND /BUILD_LIBRARY (gnatbind -Lxyz). -- Example: GNAT BIND /BUILD_LIBRARY=foobar - ); + ); type Item (Id : Item_Id); type Item_Ptr is access all Item; @@ -1441,7 +1696,9 @@ procedure GNATCmd is Next : Item_Ptr; -- Pointer to next item on list, always has the same Id value - Unix_String : String_Ptr; + Command : Command_Type := Undefined; + + Unix_String : String_Ptr := null; -- Corresponding Unix string. For a command, this is the unix command -- name and possible default switches. For a switch or option it is -- the unix switch string. @@ -1511,6 +1768,8 @@ procedure GNATCmd is Errors : Natural := 0; -- Count errors detected + Command_Arg : Positive := 1; + Command : Item_Ptr; -- Pointer to command item for current command @@ -1521,13 +1780,13 @@ procedure GNATCmd is My_Exit_Status : Exit_Status := Success; - package Buffer is new Table.Table ( - Table_Component_Type => Character, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 4096, - Table_Increment => 2, - Table_Name => "Buffer"); + package Buffer is new Table.Table + (Table_Component_Type => Character, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 4096, + Table_Increment => 2, + Table_Name => "Buffer"); Param_Count : Natural := 0; -- Number of parameter arguments so far @@ -1536,13 +1795,20 @@ procedure GNATCmd is -- Argument number Display_Command : Boolean := False; - -- Set true if /? switch causes display of generated command + -- Set true if /? switch causes display of generated command (on VMS) + + The_Command : Command_Type; + -- The command used ----------------------- -- Local Subprograms -- ----------------------- - function Init_Object_Dirs return String_Ptr; + function Index (Char : Character; Str : String) return Natural; + -- Returns the first occurrence of Char in Str. + -- Returns 0 if Char is not in Str. + + function Init_Object_Dirs return Argument_List; function Invert_Sense (S : String) return String_Ptr; -- Given a unix switch string S, computes the inverse (adding or @@ -1575,6 +1841,9 @@ procedure GNATCmd is -- error message is generated in a not found situation (null is still -- returned to indicate the not-found situation). + procedure Non_VMS_Usage; + -- Display usage for platforms other than VMS + function OK_Alphanumerplus (S : String) return Boolean; -- Checks that S is a string of alphanumeric characters, -- returning True if all alphanumeric characters, @@ -1584,6 +1853,9 @@ procedure GNATCmd is -- Checks that S is a string of digits, returning True if all digits, -- False if empty or a non-digit is present. + procedure Output_Version; + -- Output the version of this program + procedure Place (C : Character); -- Place a single character in the buffer, updating Ptr @@ -1598,6 +1870,17 @@ procedure GNATCmd is -- updating Ptr appropriatelly. Note that in the case of use of ! the -- result may be to remove a previously placed switch. + procedure Set_Library_For + (Project : Project_Id; + There_Are_Libraries : in out Boolean); + -- If Project is a library project, add the correct + -- -L and -l switches to the linker invocation. + + procedure Set_Libraries is + new For_Every_Project_Imported (Boolean, Set_Library_For); + -- Add the -L and -l switches to the linker for all + -- of the library projects. + procedure Validate_Command_Or_Option (N : String_Ptr); -- Check that N is a valid command or option name, i.e. that it is of the -- form of an Ada identifier with upper case letters and underscores. @@ -1606,13 +1889,31 @@ procedure GNATCmd is -- Check that S is a valid switch string as described in the syntax for -- the switch table item UNIX_SWITCH or else begins with a backquote. + procedure VMS_Conversion (The_Command : out Command_Type); + -- Converts VMS command line to equivalent Unix command line + + ----------- + -- Index -- + ----------- + + function Index (Char : Character; Str : String) return Natural is + begin + for Index in Str'Range loop + if Str (Index) = Char then + return Index; + end if; + end loop; + + return 0; + end Index; + ---------------------- -- Init_Object_Dirs -- ---------------------- - function Init_Object_Dirs return String_Ptr is + function Init_Object_Dirs return Argument_List is Object_Dirs : Integer; - Object_Dir : array (Integer range 1 .. 256) of String_Access; + Object_Dir : Argument_List (1 .. 256); Object_Dir_Name : String_Access; begin @@ -1627,66 +1928,24 @@ procedure GNATCmd is begin exit when Dir = null; Object_Dirs := Object_Dirs + 1; - Object_Dir (Object_Dirs) - := String_Access (Normalize_Directory_Name (Dir.all)); + Object_Dir (Object_Dirs) := + new String'("-L" & + To_Canonical_Dir_Spec + (To_Host_Dir_Spec + (Normalize_Directory_Name (Dir.all).all, + True).all, True).all); end; end loop; - for Dirs in 1 .. Object_Dirs loop - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := '-'; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := 'L'; - Object_Dir_Name := new String'( - To_Canonical_Dir_Spec - (To_Host_Dir_Spec (Object_Dir (Dirs).all, True).all, True).all); - - for J in Object_Dir_Name'Range loop - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := Object_Dir_Name (J); - end loop; - - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := ' '; - end loop; - - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := '-'; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := 'l'; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := 'g'; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := 'n'; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := 'a'; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := 't'; + Object_Dirs := Object_Dirs + 1; + Object_Dir (Object_Dirs) := new String'("-lgnat"); if Hostparm.OpenVMS then - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := ' '; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := '-'; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := 'l'; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := 'd'; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := 'e'; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := 'c'; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := 'g'; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := 'n'; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := 'a'; - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := 't'; + Object_Dirs := Object_Dirs + 1; + Object_Dir (Object_Dirs) := new String'("-ldecgnat"); end if; - return new String'(String (Buffer.Table (1 .. Buffer.Last))); + return Object_Dir (1 .. Object_Dirs); end Init_Object_Dirs; ------------------ @@ -1781,7 +2040,7 @@ procedure GNATCmd is (S : String; Itm : Item_Ptr; Quiet : Boolean := False) - return Item_Ptr + return Item_Ptr is P1, P2 : Item_Ptr; @@ -1789,6 +2048,10 @@ procedure GNATCmd is -- Little procedure to output command/qualifier/option as appropriate -- and bump error count. + --------- + -- Err -- + --------- + procedure Err is begin if Quiet then @@ -1820,7 +2083,6 @@ procedure GNATCmd is Put (Standard_Error, ": "); Put (Standard_Error, S); - end Err; -- Start of processing for Matching_Name @@ -1937,6 +2199,17 @@ procedure GNATCmd is end if; end OK_Integer; + -------------------- + -- Output_Version -- + -------------------- + + procedure Output_Version is + begin + Put ("GNAT "); + Put (Gnatvsn.Gnat_Version_String); + Put_Line (" Copyright 1996-2002 Free Software Foundation, Inc."); + end Output_Version; + ----------- -- Place -- ----------- @@ -1945,6 +2218,11 @@ procedure GNATCmd is begin Buffer.Increment_Last; Buffer.Table (Buffer.Last) := C; + + -- Do not put a space as the first character in the buffer + if C = ' ' and then Buffer.Last = 1 then + Buffer.Decrement_Last; + end if; end Place; procedure Place (S : String) is @@ -1999,8 +2277,8 @@ procedure GNATCmd is P3 := 2; while P3 <= Buffer.Last - Slen loop if Buffer.Table (P3) = ' ' - and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) - = S (P1 .. P2) + and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) = + S (P1 .. P2) and then (P3 + Slen = Buffer.Last or else Buffer.Table (P3 + Slen + 1) = ' ') @@ -2028,6 +2306,59 @@ procedure GNATCmd is end loop; end Place_Unix_Switches; + --------------------- + -- Set_Library_For -- + --------------------- + + procedure Set_Library_For + (Project : Project_Id; + There_Are_Libraries : in out Boolean) + is + begin + -- Case of library project + + if Projects.Table (Project).Library then + There_Are_Libraries := True; + + -- Add the -L switch + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-L" & + Get_Name_String + (Projects.Table (Project).Library_Dir)); + + -- Add the -l switch + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-l" & + Get_Name_String + (Projects.Table (Project).Library_Name)); + + -- Add the Wl,-rpath switch if library non static + + if Projects.Table (Project).Library_Kind /= Static then + declare + Option : constant String_Access := + MLib.Tgt.Linker_Library_Path_Option + (Get_Name_String + (Projects.Table (Project).Library_Dir)); + + begin + if Option /= null then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + Option; + end if; + + end; + + end if; + + end if; + end Set_Library_For; + -------------------------------- -- Validate_Command_Or_Option -- -------------------------------- @@ -2073,720 +2404,744 @@ procedure GNATCmd is -- List of Commands -- ---------------------- - -- Note that we put this after all the local bodies to avoid - -- some access before elaboration problems. - - Command_List : array (Natural range <>) of Command_Entry := ( - - (Cname => new S'("BIND"), - Usage => new S'("GNAT BIND file[.ali] /qualifiers"), - Unixcmd => new S'("gnatbind"), - Switches => Bind_Switches'Access, - Params => new Parameter_Array'(1 => File), - Defext => "ali"), - - (Cname => new S'("CHOP"), - Usage => new S'("GNAT CHOP file [directory] /qualifiers"), - Unixcmd => new S'("gnatchop"), - Switches => Chop_Switches'Access, - Params => new Parameter_Array'(1 => File, 2 => Optional_File), - Defext => " "), - - (Cname => new S'("COMPILE"), - Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"), - Unixcmd => new S'("gcc -c -x ada"), - Switches => GCC_Switches'Access, - Params => new Parameter_Array'(1 => Files_Or_Wildcard), - Defext => " "), - - (Cname => new S'("ELIM"), - Usage => new S'("GNAT ELIM name /qualifiers"), - Unixcmd => new S'("gnatelim"), - Switches => Elim_Switches'Access, - Params => new Parameter_Array'(1 => Other_As_Is), - Defext => "ali"), - - (Cname => new S'("FIND"), - Usage => new S'("GNAT FIND pattern[:sourcefile[:line[:column]]]" & - " filespec[,...] /qualifiers"), - Unixcmd => new S'("gnatfind"), - Switches => Find_Switches'Access, - Params => new Parameter_Array'(1 => Other_As_Is, - 2 => Files_Or_Wildcard), - Defext => "ali"), - - (Cname => new S'("KRUNCH"), - Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"), - Unixcmd => new S'("gnatkr"), - Switches => Krunch_Switches'Access, - Params => new Parameter_Array'(1 => File), - Defext => " "), - - (Cname => new S'("LIBRARY"), - Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]=directory" - & " [/CONFIG=file]"), - Unixcmd => new S'("gnatlbr"), - Switches => Lbr_Switches'Access, - Params => new Parameter_Array'(1 .. 0 => File), - Defext => " "), - - (Cname => new S'("LINK"), - Usage => new S'("GNAT LINK file[.ali]" - & " [extra obj_&_lib_&_exe_&_opt files]" - & " /qualifiers"), - Unixcmd => new S'("gnatlink"), - Switches => Link_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_Files), - Defext => "ali"), - - (Cname => new S'("LIST"), - Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"), - Unixcmd => new S'("gnatls"), - Switches => List_Switches'Access, - Params => new Parameter_Array'(1 => File), - Defext => "ali"), - - (Cname => new S'("MAKE"), - Usage => - new S'("GNAT MAKE file /qualifiers (includes COMPILE /qualifiers)"), - Unixcmd => new S'("gnatmake"), - Switches => Make_Switches'Access, - Params => new Parameter_Array'(1 => File), - Defext => " "), - - (Cname => new S'("PREPROCESS"), - Usage => new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"), - Unixcmd => new S'("gnatprep"), - Switches => Prep_Switches'Access, - Params => new Parameter_Array'(1 .. 3 => File), - Defext => " "), - - (Cname => new S'("SHARED"), - Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt files]" - & " /qualifiers"), - Unixcmd => new S'("gcc -shared " & Init_Object_Dirs.all), - Switches => Shared_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_Files), - Defext => " "), - - (Cname => new S'("STANDARD"), - Usage => new S'("GNAT STANDARD"), - Unixcmd => new S'("gnatpsta"), - Switches => Standard_Switches'Access, - Params => new Parameter_Array'(1 .. 0 => File), - Defext => " "), - - (Cname => new S'("STUB"), - Usage => new S'("GNAT STUB file [directory] /qualifiers"), - Unixcmd => new S'("gnatstub"), - Switches => Stub_Switches'Access, - Params => new Parameter_Array'(1 => File, 2 => Optional_File), - Defext => " "), - - (Cname => new S'("SYSTEM"), - Usage => new S'("GNAT SYSTEM"), - Unixcmd => new S'("gnatpsys"), - Switches => System_Switches'Access, - Params => new Parameter_Array'(1 .. 0 => File), - Defext => " "), - - (Cname => new S'("XREF"), - Usage => new S'("GNAT XREF filespec[,...] /qualifiers"), - Unixcmd => new S'("gnatxref"), - Switches => Xref_Switches'Access, - Params => new Parameter_Array'(1 => Files_Or_Wildcard), - Defext => "ali") - ); - -------------------------------------- --- Start of processing for GNATCmd -- -------------------------------------- + -- Note that we put this after all the local bodies (except Non_VMS_Usage + -- and VMS_Conversion that use Command_List) to avoid some access before + -- elaboration problems. + + Command_List : constant array (Real_Command_Type) of Command_Entry := + (Bind => + (Cname => new S'("BIND"), + Usage => new S'("GNAT BIND file[.ali] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatbind"), + Unixsws => null, + Switches => Bind_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => "ali"), + + Chop => + (Cname => new S'("CHOP"), + Usage => new S'("GNAT CHOP file [directory] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatchop"), + Unixsws => null, + Switches => Chop_Switches'Access, + Params => new Parameter_Array'(1 => File, 2 => Optional_File), + Defext => " "), + + Compile => + (Cname => new S'("COMPILE"), + Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatmake"), + Unixsws => new Argument_List' (1 => new String'("-f"), + 2 => new String'("-u"), + 3 => new String'("-c")), + Switches => GCC_Switches'Access, + Params => new Parameter_Array'(1 => Files_Or_Wildcard), + Defext => " "), + + Elim => + (Cname => new S'("ELIM"), + Usage => new S'("GNAT ELIM name /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatelim"), + Unixsws => null, + Switches => Elim_Switches'Access, + Params => new Parameter_Array'(1 => Other_As_Is), + Defext => "ali"), + + Find => + (Cname => new S'("FIND"), + Usage => new S'("GNAT FIND pattern[:sourcefile[:line" + & "[:column]]] filespec[,...] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatfind"), + Unixsws => null, + Switches => Find_Switches'Access, + Params => new Parameter_Array'(1 => Other_As_Is, + 2 => Files_Or_Wildcard), + Defext => "ali"), + + Krunch => + (Cname => new S'("KRUNCH"), + Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"), + VMS_Only => False, + Unixcmd => new S'("gnatkr"), + Unixsws => null, + Switches => Krunch_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => " "), + + Library => + (Cname => new S'("LIBRARY"), + Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]" + & "=directory [/CONFIG=file]"), + VMS_Only => True, + Unixcmd => new S'("gnatlbr"), + Unixsws => null, + Switches => Lbr_Switches'Access, + Params => new Parameter_Array'(1 .. 0 => File), + Defext => " "), + + Link => + (Cname => new S'("LINK"), + Usage => new S'("GNAT LINK file[.ali]" + & " [extra obj_&_lib_&_exe_&_opt files]" + & " /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatlink"), + Unixsws => null, + Switches => Link_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => "ali"), + + List => + (Cname => new S'("LIST"), + Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"), + VMS_Only => False, + Unixcmd => new S'("gnatls"), + Unixsws => null, + Switches => List_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => "ali"), + + Make => + (Cname => new S'("MAKE"), + Usage => new S'("GNAT MAKE file /qualifiers (includes " + & "COMPILE /qualifiers)"), + VMS_Only => False, + Unixcmd => new S'("gnatmake"), + Unixsws => null, + Switches => Make_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => " "), + + Name => + (Cname => new S'("NAME"), + Usage => new S'("GNAT NAME /qualifiers naming-pattern " + & "[naming-patterns]"), + VMS_Only => False, + Unixcmd => new S'("gnatname"), + Unixsws => null, + Switches => Name_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_As_Is), + Defext => " "), + + Preprocess => + (Cname => new S'("PREPROCESS"), + Usage => new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatprep"), + Unixsws => null, + Switches => Prep_Switches'Access, + Params => new Parameter_Array'(1 .. 3 => File), + Defext => " "), + + Shared => + (Cname => new S'("SHARED"), + Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt" + & "files] /qualifiers"), + VMS_Only => True, + Unixcmd => new S'("gcc"), + Unixsws => new Argument_List'(new String'("-shared") + & Init_Object_Dirs), + Switches => Shared_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => " "), + + Standard => + (Cname => new S'("STANDARD"), + Usage => new S'("GNAT STANDARD"), + VMS_Only => False, + Unixcmd => new S'("gnatpsta"), + Unixsws => null, + Switches => Standard_Switches'Access, + Params => new Parameter_Array'(1 .. 0 => File), + Defext => " "), + + Stub => + (Cname => new S'("STUB"), + Usage => new S'("GNAT STUB file [directory]/qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatstub"), + Unixsws => null, + Switches => Stub_Switches'Access, + Params => new Parameter_Array'(1 => File, 2 => Optional_File), + Defext => " "), + + Xref => + (Cname => new S'("XREF"), + Usage => new S'("GNAT XREF filespec[,...] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatxref"), + Unixsws => null, + Switches => Xref_Switches'Access, + Params => new Parameter_Array'(1 => Files_Or_Wildcard), + Defext => "ali") + ); -begin - Buffer.Init; + ------------------- + -- Non_VMS_Usage -- + ------------------- - -- First we must preprocess the string form of the command and options - -- list into the internal form that we use. + procedure Non_VMS_Usage is + begin + Output_Version; + New_Line; + Put_Line ("List of available commands"); + New_Line; - for C in Command_List'Range loop + for C in Command_List'Range loop + if not Command_List (C).VMS_Only then + Put ("GNAT " & Command_List (C).Cname.all); + Set_Col (25); + Put (Command_List (C).Unixcmd.all); - declare - Command : Item_Ptr := new Command_Item; + declare + Sws : Argument_List_Access renames Command_List (C).Unixsws; + begin + if Sws /= null then + for J in Sws'Range loop + Put (' '); + Put (Sws (J).all); + end loop; + end if; + end; - Last_Switch : Item_Ptr; - -- Last switch in list + New_Line; + end if; + end loop; - begin - -- Link new command item into list of commands + New_Line; + Put_Line ("Commands FIND, LIST and XREF accept project file " & + "switches -vPx, -Pprj and -Xnam=val"); + New_Line; + end Non_VMS_Usage; - if Last_Command = null then - Commands := Command; - else - Last_Command.Next := Command; - end if; + -------------------- + -- VMS_Conversion -- + -------------------- - Last_Command := Command; + procedure VMS_Conversion (The_Command : out Command_Type) is + begin + Buffer.Init; - -- Fill in fields of new command item + -- First we must preprocess the string form of the command and options + -- list into the internal form that we use. - Command.Name := Command_List (C).Cname; - Command.Usage := Command_List (C).Usage; - Command.Unix_String := Command_List (C).Unixcmd; - Command.Params := Command_List (C).Params; - Command.Defext := Command_List (C).Defext; + for C in Real_Command_Type loop - Validate_Command_Or_Option (Command.Name); + declare + Command : Item_Ptr := new Command_Item; - -- Process the switch list + Last_Switch : Item_Ptr; + -- Last switch in list - for S in Command_List (C).Switches'Range loop - declare - SS : constant String_Ptr := Command_List (C).Switches (S); + begin + -- Link new command item into list of commands - P : Natural := SS'First; - Sw : Item_Ptr := new Switch_Item; + if Last_Command = null then + Commands := Command; + else + Last_Command.Next := Command; + end if; - Last_Opt : Item_Ptr; - -- Pointer to last option + Last_Command := Command; - begin - -- Link new switch item into list of switches + -- Fill in fields of new command item - if Last_Switch = null then - Command.Switches := Sw; - else - Last_Switch.Next := Sw; - end if; + Command.Name := Command_List (C).Cname; + Command.Usage := Command_List (C).Usage; + Command.Command := C; - Last_Switch := Sw; + if Command_List (C).Unixsws = null then + Command.Unix_String := Command_List (C).Unixcmd; + else + declare + Cmd : String (1 .. 5_000); + Last : Natural := 0; + Sws : Argument_List_Access := Command_List (C).Unixsws; + + begin + Cmd (1 .. Command_List (C).Unixcmd'Length) := + Command_List (C).Unixcmd.all; + Last := Command_List (C).Unixcmd'Length; + + for J in Sws'Range loop + Last := Last + 1; + Cmd (Last) := ' '; + Cmd (Last + 1 .. Last + Sws (J)'Length) := + Sws (J).all; + Last := Last + Sws (J)'Length; + end loop; - -- Process switch string, first get name + Command.Unix_String := new String'(Cmd (1 .. Last)); + end; + end if; - while SS (P) /= ' ' and SS (P) /= '=' loop - P := P + 1; - end loop; + Command.Params := Command_List (C).Params; + Command.Defext := Command_List (C).Defext; - Sw.Name := new String'(SS (SS'First .. P - 1)); + Validate_Command_Or_Option (Command.Name); - -- Direct translation case + -- Process the switch list - if SS (P) = ' ' then - Sw.Translation := T_Direct; - Sw.Unix_String := new String'(SS (P + 1 .. SS'Last)); - Validate_Unix_Switch (Sw.Unix_String); + for S in Command_List (C).Switches'Range loop + declare + SS : constant String_Ptr := Command_List (C).Switches (S); - if SS (P - 1) = '>' then - Sw.Translation := T_Other; + P : Natural := SS'First; + Sw : Item_Ptr := new Switch_Item; - elsif SS (P + 1) = '`' then - null; + Last_Opt : Item_Ptr; + -- Pointer to last option - -- Create the inverted case (/NO ..) + begin + -- Link new switch item into list of switches - elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then - Sw := new Switch_Item; + if Last_Switch = null then + Command.Switches := Sw; + else Last_Switch.Next := Sw; - Last_Switch := Sw; + end if; - Sw.Name := - new String'("/NO" & SS (SS'First + 1 .. P - 1)); + Last_Switch := Sw; + + -- Process switch string, first get name + + while SS (P) /= ' ' and SS (P) /= '=' loop + P := P + 1; + end loop; + + Sw.Name := new String'(SS (SS'First .. P - 1)); + + -- Direct translation case + + if SS (P) = ' ' then Sw.Translation := T_Direct; - Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last)); + Sw.Unix_String := new String'(SS (P + 1 .. SS'Last)); Validate_Unix_Switch (Sw.Unix_String); - end if; - -- Directories translation case + if SS (P - 1) = '>' then + Sw.Translation := T_Other; - elsif SS (P + 1) = '*' then - pragma Assert (SS (SS'Last) = '*'); - Sw.Translation := T_Directories; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); - Validate_Unix_Switch (Sw.Unix_String); + elsif SS (P + 1) = '`' then + null; - -- Directory translation case + -- Create the inverted case (/NO ..) - elsif SS (P + 1) = '%' then - pragma Assert (SS (SS'Last) = '%'); - Sw.Translation := T_Directory; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); - Validate_Unix_Switch (Sw.Unix_String); + elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then + Sw := new Switch_Item; + Last_Switch.Next := Sw; + Last_Switch := Sw; - -- File translation case + Sw.Name := + new String'("/NO" & SS (SS'First + 1 .. P - 1)); + Sw.Translation := T_Direct; + Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last)); + Validate_Unix_Switch (Sw.Unix_String); + end if; - elsif SS (P + 1) = '@' then - pragma Assert (SS (SS'Last) = '@'); - Sw.Translation := T_File; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); - Validate_Unix_Switch (Sw.Unix_String); + -- Directories translation case - -- Numeric translation case + elsif SS (P + 1) = '*' then + pragma Assert (SS (SS'Last) = '*'); + Sw.Translation := T_Directories; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); - elsif SS (P + 1) = '#' then - pragma Assert (SS (SS'Last) = '#'); - Sw.Translation := T_Numeric; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); - Validate_Unix_Switch (Sw.Unix_String); + -- Directory translation case - -- Alphanumerplus translation case + elsif SS (P + 1) = '%' then + pragma Assert (SS (SS'Last) = '%'); + Sw.Translation := T_Directory; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); - elsif SS (P + 1) = '|' then - pragma Assert (SS (SS'Last) = '|'); - Sw.Translation := T_Alphanumplus; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); - Validate_Unix_Switch (Sw.Unix_String); + -- File translation case - -- String translation case + elsif SS (P + 1) = '@' then + pragma Assert (SS (SS'Last) = '@'); + Sw.Translation := T_File; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); - elsif SS (P + 1) = '"' then - pragma Assert (SS (SS'Last) = '"'); - Sw.Translation := T_String; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); - Validate_Unix_Switch (Sw.Unix_String); + -- No space file translation case - -- Commands translation case + elsif SS (P + 1) = '<' then + pragma Assert (SS (SS'Last) = '>'); + Sw.Translation := T_No_Space_File; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); - elsif SS (P + 1) = '?' then - Sw.Translation := T_Commands; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last)); + -- Numeric translation case - -- Options translation case + elsif SS (P + 1) = '#' then + pragma Assert (SS (SS'Last) = '#'); + Sw.Translation := T_Numeric; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); - else - Sw.Translation := T_Options; - Sw.Unix_String := new String'(""); + -- Alphanumerplus translation case - P := P + 1; -- bump past = - while P <= SS'Last loop - declare - Opt : Item_Ptr := new Option_Item; - Q : Natural; + elsif SS (P + 1) = '|' then + pragma Assert (SS (SS'Last) = '|'); + Sw.Translation := T_Alphanumplus; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); - begin - -- Link new option item into options list + -- String translation case - if Last_Opt = null then - Sw.Options := Opt; - else - Last_Opt.Next := Opt; - end if; + elsif SS (P + 1) = '"' then + pragma Assert (SS (SS'Last) = '"'); + Sw.Translation := T_String; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); - Last_Opt := Opt; + -- Commands translation case - -- Fill in fields of new option item + elsif SS (P + 1) = '?' then + Sw.Translation := T_Commands; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last)); - Q := P; - while SS (Q) /= ' ' loop - Q := Q + 1; - end loop; + -- Options translation case - Opt.Name := new String'(SS (P .. Q - 1)); - Validate_Command_Or_Option (Opt.Name); + else + Sw.Translation := T_Options; + Sw.Unix_String := new String'(""); - P := Q + 1; - Q := P; + P := P + 1; -- bump past = + while P <= SS'Last loop + declare + Opt : Item_Ptr := new Option_Item; + Q : Natural; - while Q <= SS'Last and then SS (Q) /= ' ' loop - Q := Q + 1; - end loop; + begin + -- Link new option item into options list - Opt.Unix_String := new String'(SS (P .. Q - 1)); - Validate_Unix_Switch (Opt.Unix_String); - P := Q + 1; - end; - end loop; - end if; - end; - end loop; - end; - end loop; + if Last_Opt = null then + Sw.Options := Opt; + else + Last_Opt.Next := Opt; + end if; - -- If no parameters, give complete list of commands + Last_Opt := Opt; - if Argument_Count = 0 then - Put_Line ("List of available commands"); - New_Line; + -- Fill in fields of new option item - while Commands /= null loop - Put (Commands.Usage.all); - Set_Col (53); - Put_Line (Commands.Unix_String.all); - Commands := Commands.Next; - end loop; + Q := P; + while SS (Q) /= ' ' loop + Q := Q + 1; + end loop; - raise Normal_Exit; - end if; + Opt.Name := new String'(SS (P .. Q - 1)); + Validate_Command_Or_Option (Opt.Name); - Arg_Num := 1; + P := Q + 1; + Q := P; - loop - exit when Arg_Num > Argument_Count; + while Q <= SS'Last and then SS (Q) /= ' ' loop + Q := Q + 1; + end loop; - declare - Argv : String_Access; - Arg_Idx : Integer; - - function Get_Arg_End - (Argv : String; - Arg_Idx : Integer) - return Integer; - -- Begins looking at Arg_Idx + 1 and returns the index of the - -- last character before a slash or else the index of the last - -- character in the string Argv. - - function Get_Arg_End - (Argv : String; - Arg_Idx : Integer) - return Integer - is - begin - for J in Arg_Idx + 1 .. Argv'Last loop - if Argv (J) = '/' then - return J - 1; - end if; + Opt.Unix_String := new String'(SS (P .. Q - 1)); + Validate_Unix_Switch (Opt.Unix_String); + P := Q + 1; + end; + end loop; + end if; + end; end loop; + end; + end loop; - return Argv'Last; - end Get_Arg_End; + -- If no parameters, give complete list of commands - begin - Argv := new String'(Argument (Arg_Num)); - Arg_Idx := Argv'First; + if Argument_Count = 0 then + Output_Version; + New_Line; + Put_Line ("List of available commands"); + New_Line; - <<Tryagain_After_Coalesce>> - loop - declare - Next_Arg_Idx : Integer; - Arg : String_Access; + while Commands /= null loop + Put (Commands.Usage.all); + Set_Col (53); + Put_Line (Commands.Unix_String.all); + Commands := Commands.Next; + end loop; - begin - Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); - Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); + raise Normal_Exit; + end if; + + Arg_Num := 1; + + -- Loop through arguments - -- The first one must be a command name + while Arg_Num <= Argument_Count loop - if Arg_Num = 1 and then Arg_Idx = Argv'First then + Process_Argument : declare + Argv : String_Access; + Arg_Idx : Integer; - Command := Matching_Name (Arg.all, Commands); + function Get_Arg_End + (Argv : String; + Arg_Idx : Integer) + return Integer; + -- Begins looking at Arg_Idx + 1 and returns the index of the + -- last character before a slash or else the index of the last + -- character in the string Argv. - if Command = null then - raise Error_Exit; + ----------------- + -- Get_Arg_End -- + ----------------- + + function Get_Arg_End + (Argv : String; + Arg_Idx : Integer) + return Integer + is + begin + for J in Arg_Idx + 1 .. Argv'Last loop + if Argv (J) = '/' then + return J - 1; end if; + end loop; - -- Give usage information if only command given + return Argv'Last; + end Get_Arg_End; - if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last - and then - not (Command.Name.all = "SYSTEM" - or else Command.Name.all = "STANDARD") - then - Put_Line ("List of available qualifiers and options"); - New_Line; + -- Start of processing for Process_Argument - Put (Command.Usage.all); - Set_Col (53); - Put_Line (Command.Unix_String.all); + begin + Argv := new String'(Argument (Arg_Num)); + Arg_Idx := Argv'First; - declare - Sw : Item_Ptr := Command.Switches; + <<Tryagain_After_Coalesce>> + loop + declare + Next_Arg_Idx : Integer; + Arg : String_Access; - begin - while Sw /= null loop - Put (" "); - Put (Sw.Name.all); - - case Sw.Translation is - - when T_Other => - Set_Col (53); - Put_Line (Sw.Unix_String.all & "/<other>"); - - when T_Direct => - Set_Col (53); - Put_Line (Sw.Unix_String.all); - - when T_Directories => - Put ("=(direc,direc,..direc)"); - Set_Col (53); - Put (Sw.Unix_String.all); - Put (" direc "); - Put (Sw.Unix_String.all); - Put_Line (" direc ..."); - - when T_Directory => - Put ("=directory"); - Set_Col (53); - Put (Sw.Unix_String.all); - - if Sw.Unix_String (Sw.Unix_String'Last) - /= '=' - then - Put (' '); - end if; - - Put_Line ("directory "); - - when T_File => - Put ("=file"); - Set_Col (53); - Put (Sw.Unix_String.all); - - if Sw.Unix_String (Sw.Unix_String'Last) - /= '=' - then - Put (' '); - end if; - - Put_Line ("file "); - - when T_Numeric => - Put ("=nnn"); - Set_Col (53); - - if Sw.Unix_String (Sw.Unix_String'First) - = '`' - then - Put (Sw.Unix_String - (Sw.Unix_String'First + 1 - .. Sw.Unix_String'Last)); - else - Put (Sw.Unix_String.all); - end if; - - Put_Line ("nnn"); - - when T_Alphanumplus => - Put ("=xyz"); - Set_Col (53); - - if Sw.Unix_String (Sw.Unix_String'First) - = '`' - then - Put (Sw.Unix_String - (Sw.Unix_String'First + 1 - .. Sw.Unix_String'Last)); - else - Put (Sw.Unix_String.all); - end if; - - Put_Line ("xyz"); - - when T_String => - Put ("="); - Put ('"'); - Put ("<string>"); - Put ('"'); - Set_Col (53); - - Put (Sw.Unix_String.all); - - if Sw.Unix_String (Sw.Unix_String'Last) - /= '=' - then - Put (' '); - end if; - - Put ("<string>"); - New_Line; - - when T_Commands => - Put (" (switches for "); - Put (Sw.Unix_String ( - Sw.Unix_String'First + 7 - .. Sw.Unix_String'Last)); - Put (')'); - Set_Col (53); - Put (Sw.Unix_String ( - Sw.Unix_String'First - .. Sw.Unix_String'First + 5)); - Put_Line (" switches"); - - when T_Options => - declare - Opt : Item_Ptr := Sw.Options; + begin + Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); - begin - Put_Line ("=(option,option..)"); + -- The first one must be a command name + + if Arg_Num = 1 and then Arg_Idx = Argv'First then + + Command := Matching_Name (Arg.all, Commands); + + if Command = null then + raise Error_Exit; + end if; + + The_Command := Command.Command; + + -- Give usage information if only command given + + if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last + and then Command.Command /= Standard + then + Output_Version; + New_Line; + Put_Line + ("List of available qualifiers and options"); + New_Line; + + Put (Command.Usage.all); + Set_Col (53); + Put_Line (Command.Unix_String.all); + + declare + Sw : Item_Ptr := Command.Switches; + + begin + while Sw /= null loop + Put (" "); + Put (Sw.Name.all); + + case Sw.Translation is + + when T_Other => + Set_Col (53); + Put_Line (Sw.Unix_String.all & + "/<other>"); + + when T_Direct => + Set_Col (53); + Put_Line (Sw.Unix_String.all); + + when T_Directories => + Put ("=(direc,direc,..direc)"); + Set_Col (53); + Put (Sw.Unix_String.all); + Put (" direc "); + Put (Sw.Unix_String.all); + Put_Line (" direc ..."); - while Opt /= null loop - Put (" "); - Put (Opt.Name.all); + when T_Directory => + Put ("=directory"); + Set_Col (53); + Put (Sw.Unix_String.all); - if Opt = Sw.Options then - Put (" (D)"); + if Sw.Unix_String (Sw.Unix_String'Last) + /= '=' + then + Put (' '); end if; + Put_Line ("directory "); + + when T_File | T_No_Space_File => + Put ("=file"); Set_Col (53); - Put_Line (Opt.Unix_String.all); - Opt := Opt.Next; - end loop; - end; + Put (Sw.Unix_String.all); - end case; + if Sw.Translation = T_File + and then Sw.Unix_String + (Sw.Unix_String'Last) + /= '=' + then + Put (' '); + end if; - Sw := Sw.Next; - end loop; - end; + Put_Line ("file "); - raise Normal_Exit; - end if; + when T_Numeric => + Put ("=nnn"); + Set_Col (53); - Place (Command.Unix_String.all); + if Sw.Unix_String (Sw.Unix_String'First) + = '`' + then + Put (Sw.Unix_String + (Sw.Unix_String'First + 1 + .. Sw.Unix_String'Last)); + else + Put (Sw.Unix_String.all); + end if; - -- Special handling for internal debugging switch /? + Put_Line ("nnn"); - elsif Arg.all = "/?" then - Display_Command := True; + when T_Alphanumplus => + Put ("=xyz"); + Set_Col (53); - -- Copy -switch unchanged + if Sw.Unix_String (Sw.Unix_String'First) + = '`' + then + Put (Sw.Unix_String + (Sw.Unix_String'First + 1 + .. Sw.Unix_String'Last)); + else + Put (Sw.Unix_String.all); + end if; - elsif Arg (Arg'First) = '-' then - Place (' '); - Place (Arg.all); + Put_Line ("xyz"); - -- Copy quoted switch with quotes stripped + when T_String => + Put ("="); + Put ('"'); + Put ("<string>"); + Put ('"'); + Set_Col (53); - elsif Arg (Arg'First) = '"' then - if Arg (Arg'Last) /= '"' then - Put (Standard_Error, "misquoted argument: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + Put (Sw.Unix_String.all); - else - Put (Arg (Arg'First + 1 .. Arg'Last - 1)); - end if; + if Sw.Unix_String (Sw.Unix_String'Last) + /= '=' + then + Put (' '); + end if; - -- Parameter Argument + Put ("<string>"); + New_Line; - elsif Arg (Arg'First) /= '/' - and then Make_Commands_Active = null - then - Param_Count := Param_Count + 1; + when T_Commands => + Put (" (switches for "); + Put (Sw.Unix_String + (Sw.Unix_String'First + 7 + .. Sw.Unix_String'Last)); + Put (')'); + Set_Col (53); + Put (Sw.Unix_String + (Sw.Unix_String'First + .. Sw.Unix_String'First + 5)); + Put_Line (" switches"); - if Param_Count <= Command.Params'Length then + when T_Options => + declare + Opt : Item_Ptr := Sw.Options; - case Command.Params (Param_Count) is + begin + Put_Line ("=(option,option..)"); - when File | Optional_File => - declare - Normal_File : String_Access - := To_Canonical_File_Spec (Arg.all); - begin - Place (' '); - Place_Lower (Normal_File.all); + while Opt /= null loop + Put (" "); + Put (Opt.Name.all); - if Is_Extensionless (Normal_File.all) - and then Command.Defext /= " " - then - Place ('.'); - Place (Command.Defext); - end if; - end; + if Opt = Sw.Options then + Put (" (D)"); + end if; - when Unlimited_Files => - declare - Normal_File : String_Access - := To_Canonical_File_Spec (Arg.all); + Set_Col (53); + Put_Line (Opt.Unix_String.all); + Opt := Opt.Next; + end loop; + end; - File_Is_Wild : Boolean := False; - File_List : String_Access_List_Access; - begin - for I in Arg'Range loop - if Arg (I) = '*' - or else Arg (I) = '%' - then - File_Is_Wild := True; - end if; + end case; + + Sw := Sw.Next; end loop; + end; - if File_Is_Wild then - File_List := To_Canonical_File_List - (Arg.all, False); + raise Normal_Exit; + end if; - for I in File_List.all'Range loop - Place (' '); - Place_Lower (File_List.all (I).all); - end loop; - else - Place (' '); - Place_Lower (Normal_File.all); - - if Is_Extensionless (Normal_File.all) - and then Command.Defext /= " " - then - Place ('.'); - Place (Command.Defext); - end if; - end if; + -- Place (Command.Unix_String.all); - Param_Count := Param_Count - 1; - end; + -- Special handling for internal debugging switch /? - when Other_As_Is => - Place (' '); - Place (Arg.all); + elsif Arg.all = "/?" then + Display_Command := True; - when Files_Or_Wildcard => + -- Copy -switch unchanged - -- Remove spaces from a comma separated list - -- of file names and adjust control variables - -- accordingly. + elsif Arg (Arg'First) = '-' then + Place (' '); + Place (Arg.all); - while Arg_Num < Argument_Count and then - (Argv (Argv'Last) = ',' xor - Argument (Arg_Num + 1) - (Argument (Arg_Num + 1)'First) = ',') - loop - Argv := new String'(Argv.all - & Argument (Arg_Num + 1)); - Arg_Num := Arg_Num + 1; - Arg_Idx := Argv'First; - Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); - Arg := - new String'(Argv (Arg_Idx .. Next_Arg_Idx)); - end loop; + -- Copy quoted switch with quotes stripped - -- Parse the comma separated list of VMS filenames - -- and place them on the command line as space - -- separated Unix style filenames. Lower case and - -- add default extension as appropriate. + elsif Arg (Arg'First) = '"' then + if Arg (Arg'Last) /= '"' then + Put (Standard_Error, "misquoted argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; - declare - Arg1_Idx : Integer := Arg'First; - - function Get_Arg1_End - (Arg : String; Arg_Idx : Integer) - return Integer; - -- Begins looking at Arg_Idx + 1 and - -- returns the index of the last character - -- before a comma or else the index of the - -- last character in the string Arg. - - function Get_Arg1_End - (Arg : String; Arg_Idx : Integer) - return Integer - is - begin - for I in Arg_Idx + 1 .. Arg'Last loop - if Arg (I) = ',' then - return I - 1; - end if; - end loop; + else + Place (' '); + Place (Arg (Arg'First + 1 .. Arg'Last - 1)); + end if; - return Arg'Last; - end Get_Arg1_End; + -- Parameter Argument - begin - loop - declare - Next_Arg1_Idx : Integer - := Get_Arg1_End (Arg.all, Arg1_Idx); + elsif Arg (Arg'First) /= '/' + and then Make_Commands_Active = null + then + Param_Count := Param_Count + 1; - Arg1 : String - := Arg (Arg1_Idx .. Next_Arg1_Idx); + if Param_Count <= Command.Params'Length then - Normal_File : String_Access - := To_Canonical_File_Spec (Arg1); + case Command.Params (Param_Count) is + when File | Optional_File => + declare + Normal_File : String_Access + := To_Canonical_File_Spec (Arg.all); begin Place (' '); Place_Lower (Normal_File.all); @@ -2797,517 +3152,1109 @@ begin Place ('.'); Place (Command.Defext); end if; - - Arg1_Idx := Next_Arg1_Idx + 1; end; - exit when Arg1_Idx > Arg'Last; + when Unlimited_Files => + declare + Normal_File : String_Access + := To_Canonical_File_Spec (Arg.all); - -- Don't allow two or more commas in a row + File_Is_Wild : Boolean := False; + File_List : String_Access_List_Access; + begin + for I in Arg'Range loop + if Arg (I) = '*' + or else Arg (I) = '%' + then + File_Is_Wild := True; + end if; + end loop; - if Arg (Arg1_Idx) = ',' then - Arg1_Idx := Arg1_Idx + 1; - if Arg1_Idx > Arg'Last or else - Arg (Arg1_Idx) = ',' - then - Put_Line (Standard_Error, - "Malformed Parameter: " & Arg.all); - Put (Standard_Error, "usage: "); - Put_Line (Standard_Error, - Command.Usage.all); - raise Error_Exit; + if File_Is_Wild then + File_List := To_Canonical_File_List + (Arg.all, False); + + for I in File_List.all'Range loop + Place (' '); + Place_Lower (File_List.all (I).all); + end loop; + else + Place (' '); + Place_Lower (Normal_File.all); + + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + then + Place ('.'); + Place (Command.Defext); + end if; end if; - end if; - end loop; - end; - end case; - end if; + Param_Count := Param_Count - 1; + end; - -- Qualifier argument + when Other_As_Is => + Place (' '); + Place (Arg.all); - else - declare - Sw : Item_Ptr; - SwP : Natural; - P2 : Natural; - Endp : Natural := 0; -- avoid warning! - Opt : Item_Ptr; + when Unlimited_As_Is => + Place (' '); + Place (Arg.all); + Param_Count := Param_Count - 1; - begin - SwP := Arg'First; - while SwP < Arg'Last and then Arg (SwP + 1) /= '=' loop - SwP := SwP + 1; - end loop; + when Files_Or_Wildcard => - -- At this point, the switch name is in - -- Arg (Arg'First..SwP) and if that is not the whole - -- switch, then there is an equal sign at - -- Arg (SwP + 1) and the rest of Arg is what comes - -- after the equal sign. + -- Remove spaces from a comma separated list + -- of file names and adjust control variables + -- accordingly. - -- If make commands are active, see if we have another - -- COMMANDS_TRANSLATION switch belonging to gnatmake. + while Arg_Num < Argument_Count and then + (Argv (Argv'Last) = ',' xor + Argument (Arg_Num + 1) + (Argument (Arg_Num + 1)'First) = ',') + loop + Argv := new String' + (Argv.all & Argument (Arg_Num + 1)); + Arg_Num := Arg_Num + 1; + Arg_Idx := Argv'First; + Next_Arg_Idx := + Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); + end loop; - if Make_Commands_Active /= null then - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Command.Switches, - Quiet => True); + -- Parse the comma separated list of VMS + -- filenames and place them on the command + -- line as space separated Unix style + -- filenames. Lower case and add default + -- extension as appropriate. - if Sw /= null and then Sw.Translation = T_Commands then - null; + declare + Arg1_Idx : Integer := Arg'First; + + function Get_Arg1_End + (Arg : String; Arg_Idx : Integer) + return Integer; + -- Begins looking at Arg_Idx + 1 and + -- returns the index of the last character + -- before a comma or else the index of the + -- last character in the string Arg. + + function Get_Arg1_End + (Arg : String; Arg_Idx : Integer) + return Integer + is + begin + for I in Arg_Idx + 1 .. Arg'Last loop + if Arg (I) = ',' then + return I - 1; + end if; + end loop; - else - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Make_Commands_Active.Switches, - Quiet => False); - end if; + return Arg'Last; + end Get_Arg1_End; - -- For case of GNAT MAKE or CHOP, if we cannot find the - -- switch, then see if it is a recognized compiler switch - -- instead, and if so process the compiler switch. - - elsif Command.Name.all = "MAKE" - or else Command.Name.all = "CHOP" then - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Command.Switches, - Quiet => True); - - if Sw = null then - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Matching_Name ("COMPILE", Commands).Switches, - Quiet => False); + begin + loop + declare + Next_Arg1_Idx : Integer := + Get_Arg1_End (Arg.all, Arg1_Idx); + + Arg1 : String := + Arg (Arg1_Idx .. Next_Arg1_Idx); + + Normal_File : String_Access := + To_Canonical_File_Spec (Arg1); + + begin + Place (' '); + Place_Lower (Normal_File.all); + + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + then + Place ('.'); + Place (Command.Defext); + end if; + + Arg1_Idx := Next_Arg1_Idx + 1; + end; + + exit when Arg1_Idx > Arg'Last; + + -- Don't allow two or more commas in + -- a row + + if Arg (Arg1_Idx) = ',' then + Arg1_Idx := Arg1_Idx + 1; + if Arg1_Idx > Arg'Last or else + Arg (Arg1_Idx) = ',' + then + Put_Line + (Standard_Error, + "Malformed Parameter: " & + Arg.all); + Put (Standard_Error, "usage: "); + Put_Line (Standard_Error, + Command.Usage.all); + raise Error_Exit; + end if; + end if; + + end loop; + end; + end case; end if; - -- For all other cases, just search the relevant command + -- Qualifier argument else - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Command.Switches, - Quiet => False); - end if; + declare + Sw : Item_Ptr; + SwP : Natural; + P2 : Natural; + Endp : Natural := 0; -- avoid warning! + Opt : Item_Ptr; + + begin + SwP := Arg'First; + while SwP < Arg'Last + and then Arg (SwP + 1) /= '=' + loop + SwP := SwP + 1; + end loop; - if Sw /= null then - case Sw.Translation is + -- At this point, the switch name is in + -- Arg (Arg'First..SwP) and if that is not the + -- whole switch, then there is an equal sign at + -- Arg (SwP + 1) and the rest of Arg is what comes + -- after the equal sign. - when T_Direct => - Place_Unix_Switches (Sw.Unix_String); - if Arg (SwP + 1) = '=' then - Put (Standard_Error, - "qualifier options ignored: "); - Put_Line (Standard_Error, Arg.all); + -- If make commands are active, see if we have + -- another COMMANDS_TRANSLATION switch belonging + -- to gnatmake. + + if Make_Commands_Active /= null then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => True); + + if Sw /= null + and then Sw.Translation = T_Commands + then + null; + + else + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Make_Commands_Active.Switches, + Quiet => False); end if; - when T_Directories => - if SwP + 1 > Arg'Last then - Put (Standard_Error, - "missing directories for: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + -- For case of GNAT MAKE or CHOP, if we cannot + -- find the switch, then see if it is a + -- recognized compiler switch instead, and if + -- so process the compiler switch. - elsif Arg (SwP + 2) /= '(' then - SwP := SwP + 2; - Endp := Arg'Last; + elsif Command.Name.all = "MAKE" + or else Command.Name.all = "CHOP" then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => True); + + if Sw = null then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Matching_Name + ("COMPILE", Commands).Switches, + Quiet => False); + end if; - elsif Arg (Arg'Last) /= ')' then + -- For all other cases, just search the relevant + -- command. - -- Remove spaces from a comma separated list - -- of file names and adjust control - -- variables accordingly. + else + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => False); + end if; + + if Sw /= null then + case Sw.Translation is + + when T_Direct => + Place_Unix_Switches (Sw.Unix_String); + if SwP < Arg'Last + and then Arg (SwP + 1) = '=' + then + Put (Standard_Error, + "qualifier options ignored: "); + Put_Line (Standard_Error, Arg.all); + end if; - if Arg_Num < Argument_Count and then - (Argv (Argv'Last) = ',' xor - Argument (Arg_Num + 1) - (Argument (Arg_Num + 1)'First) = ',') - then - Argv := new String'(Argv.all - & Argument (Arg_Num + 1)); - Arg_Num := Arg_Num + 1; - Arg_Idx := Argv'First; - Next_Arg_Idx - := Get_Arg_End (Argv.all, Arg_Idx); - Arg := new String' - (Argv (Arg_Idx .. Next_Arg_Idx)); - goto Tryagain_After_Coalesce; - end if; + when T_Directories => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing directories for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; - Put (Standard_Error, - "incorrectly parenthesized " & - "or malformed argument: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + elsif Arg (SwP + 2) /= '(' then + SwP := SwP + 2; + Endp := Arg'Last; - else - SwP := SwP + 3; - Endp := Arg'Last - 1; - end if; + elsif Arg (Arg'Last) /= ')' then - while SwP <= Endp loop - declare - Dir_Is_Wild : Boolean := False; - Dir_Maybe_Is_Wild : Boolean := False; - Dir_List : String_Access_List_Access; - begin - P2 := SwP; + -- Remove spaces from a comma separated + -- list of file names and adjust + -- control variables accordingly. - while P2 < Endp - and then Arg (P2 + 1) /= ',' - loop + if Arg_Num < Argument_Count and then + (Argv (Argv'Last) = ',' xor + Argument (Arg_Num + 1) + (Argument (Arg_Num + 1)'First) = ',') + then + Argv := + new String'(Argv.all + & Argument + (Arg_Num + 1)); + Arg_Num := Arg_Num + 1; + Arg_Idx := Argv'First; + Next_Arg_Idx + := Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); + goto Tryagain_After_Coalesce; + end if; - -- A wildcard directory spec on VMS - -- will contain either * or % or ... + Put (Standard_Error, + "incorrectly parenthesized " & + "or malformed argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; - if Arg (P2) = '*' then - Dir_Is_Wild := True; + else + SwP := SwP + 3; + Endp := Arg'Last - 1; + end if; - elsif Arg (P2) = '%' then - Dir_Is_Wild := True; + while SwP <= Endp loop + declare + Dir_Is_Wild : Boolean := False; + Dir_Maybe_Is_Wild : Boolean := False; + Dir_List : String_Access_List_Access; + begin + P2 := SwP; + + while P2 < Endp + and then Arg (P2 + 1) /= ',' + loop + + -- A wildcard directory spec on + -- VMS will contain either * or + -- % or ... + + if Arg (P2) = '*' then + Dir_Is_Wild := True; + + elsif Arg (P2) = '%' then + Dir_Is_Wild := True; + + elsif Dir_Maybe_Is_Wild + and then Arg (P2) = '.' + and then Arg (P2 + 1) = '.' + then + Dir_Is_Wild := True; + Dir_Maybe_Is_Wild := False; + + elsif Dir_Maybe_Is_Wild then + Dir_Maybe_Is_Wild := False; + + elsif Arg (P2) = '.' + and then Arg (P2 + 1) = '.' + then + Dir_Maybe_Is_Wild := True; + + end if; + + P2 := P2 + 1; + end loop; + + if (Dir_Is_Wild) then + Dir_List := To_Canonical_File_List + (Arg (SwP .. P2), True); + + for I in Dir_List.all'Range loop + Place_Unix_Switches + (Sw.Unix_String); + Place_Lower + (Dir_List.all (I).all); + end loop; + else + Place_Unix_Switches + (Sw.Unix_String); + Place_Lower + (To_Canonical_Dir_Spec + (Arg (SwP .. P2), False).all); + end if; + + SwP := P2 + 2; + end; + end loop; - elsif Dir_Maybe_Is_Wild - and then Arg (P2) = '.' - and then Arg (P2 + 1) = '.' - then - Dir_Is_Wild := True; - Dir_Maybe_Is_Wild := False; + when T_Directory => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing directory for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + Place_Unix_Switches (Sw.Unix_String); - elsif Dir_Maybe_Is_Wild then - Dir_Maybe_Is_Wild := False; + -- Some switches end in "=". No space + -- here - elsif Arg (P2) = '.' - and then Arg (P2 + 1) = '.' + if Sw.Unix_String + (Sw.Unix_String'Last) /= '=' then - Dir_Maybe_Is_Wild := True; - + Place (' '); end if; - P2 := P2 + 1; - end loop; + Place_Lower + (To_Canonical_Dir_Spec + (Arg (SwP + 2 .. Arg'Last), + False).all); + end if; - if (Dir_Is_Wild) then - Dir_List := To_Canonical_File_List - (Arg (SwP .. P2), True); + when T_File | T_No_Space_File => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing file for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; - for I in Dir_List.all'Range loop - Place_Unix_Switches (Sw.Unix_String); - Place_Lower (Dir_List.all (I).all); - end loop; else Place_Unix_Switches (Sw.Unix_String); - Place_Lower (To_Canonical_Dir_Spec - (Arg (SwP .. P2), False).all); + + -- Some switches end in "=". No space + -- here. + + if Sw.Translation = T_File + and then Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Place (' '); + end if; + + Place_Lower + (To_Canonical_File_Spec + (Arg (SwP + 2 .. Arg'Last)).all); end if; - SwP := P2 + 2; - end; - end loop; + when T_Numeric => + if + OK_Integer (Arg (SwP + 2 .. Arg'Last)) + then + Place_Unix_Switches (Sw.Unix_String); + Place (Arg (SwP + 2 .. Arg'Last)); - when T_Directory => - if SwP + 1 > Arg'Last then - Put (Standard_Error, - "missing directory for: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + else + Put (Standard_Error, "argument for "); + Put (Standard_Error, Sw.Name.all); + Put_Line + (Standard_Error, " must be numeric"); + Errors := Errors + 1; + end if; - else - Place_Unix_Switches (Sw.Unix_String); + when T_Alphanumplus => + if + OK_Alphanumerplus + (Arg (SwP + 2 .. Arg'Last)) + then + Place_Unix_Switches (Sw.Unix_String); + Place (Arg (SwP + 2 .. Arg'Last)); - -- Some switches end in "=". No space here + else + Put (Standard_Error, "argument for "); + Put (Standard_Error, Sw.Name.all); + Put_Line (Standard_Error, + " must be alphanumeric"); + Errors := Errors + 1; + end if; + + when T_String => + + -- A String value must be extended to the + -- end of the Argv, otherwise strings like + -- "foo/bar" get split at the slash. + -- + -- The begining and ending of the string + -- are flagged with embedded nulls which + -- are removed when building the Spawn + -- call. Nulls are use because they won't + -- show up in a /? output. Quotes aren't + -- used because that would make it + -- difficult to embed them. + + Place_Unix_Switches (Sw.Unix_String); + if Next_Arg_Idx /= Argv'Last then + Next_Arg_Idx := Argv'Last; + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); + + SwP := Arg'First; + while SwP < Arg'Last and then + Arg (SwP + 1) /= '=' loop + SwP := SwP + 1; + end loop; + end if; + Place (ASCII.NUL); + Place (Arg (SwP + 2 .. Arg'Last)); + Place (ASCII.NUL); + + when T_Commands => + + -- Output -largs/-bargs/-cargs - if Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then Place (' '); - end if; + Place (Sw.Unix_String + (Sw.Unix_String'First .. + Sw.Unix_String'First + 5)); + + -- Set source of new commands, also + -- setting this non-null indicates that + -- we are in the special commands mode + -- for processing the -xargs case. + + Make_Commands_Active := + Matching_Name + (Sw.Unix_String + (Sw.Unix_String'First + 7 .. + Sw.Unix_String'Last), + Commands); + + when T_Options => + if SwP + 1 > Arg'Last then + Place_Unix_Switches + (Sw.Options.Unix_String); + SwP := Endp + 1; + + elsif Arg (SwP + 2) /= '(' then + SwP := SwP + 2; + Endp := Arg'Last; + + elsif Arg (Arg'Last) /= ')' then + Put + (Standard_Error, + "incorrectly parenthesized " & + "argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + SwP := Endp + 1; - Place_Lower (To_Canonical_Dir_Spec - (Arg (SwP + 2 .. Arg'Last), False).all); - end if; + else + SwP := SwP + 3; + Endp := Arg'Last - 1; + end if; - when T_File => - if SwP + 1 > Arg'Last then - Put (Standard_Error, "missing file for: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + while SwP <= Endp loop + P2 := SwP; - else - Place_Unix_Switches (Sw.Unix_String); + while P2 < Endp + and then Arg (P2 + 1) /= ',' + loop + P2 := P2 + 1; + end loop; - -- Some switches end in "=". No space here + -- Option name is in Arg (SwP .. P2) - if Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then - Place (' '); - end if; + Opt := Matching_Name (Arg (SwP .. P2), + Sw.Options); - Place_Lower (To_Canonical_File_Spec - (Arg (SwP + 2 .. Arg'Last)).all); - end if; + if Opt /= null then + Place_Unix_Switches + (Opt.Unix_String); + end if; - when T_Numeric => - if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then - Place_Unix_Switches (Sw.Unix_String); - Place (Arg (SwP + 2 .. Arg'Last)); + SwP := P2 + 2; + end loop; - else - Put (Standard_Error, "argument for "); - Put (Standard_Error, Sw.Name.all); - Put_Line (Standard_Error, " must be numeric"); - Errors := Errors + 1; - end if; + when T_Other => + Place_Unix_Switches + (new String'(Sw.Unix_String.all & + Arg.all)); - when T_Alphanumplus => - if - OK_Alphanumerplus (Arg (SwP + 2 .. Arg'Last)) - then - Place_Unix_Switches (Sw.Unix_String); - Place (Arg (SwP + 2 .. Arg'Last)); + end case; + end if; + end; + end if; - else - Put (Standard_Error, "argument for "); - Put (Standard_Error, Sw.Name.all); - Put_Line (Standard_Error, - " must be alphanumeric"); - Errors := Errors + 1; - end if; + Arg_Idx := Next_Arg_Idx + 1; + end; - when T_String => - - -- A String value must be extended to the - -- end of the Argv, otherwise strings like - -- "foo/bar" get split at the slash. - -- - -- The begining and ending of the string - -- are flagged with embedded nulls which - -- are removed when building the Spawn - -- call. Nulls are use because they won't - -- show up in a /? output. Quotes aren't - -- used because that would make it difficult - -- to embed them. - - Place_Unix_Switches (Sw.Unix_String); - if Next_Arg_Idx /= Argv'Last then - Next_Arg_Idx := Argv'Last; - Arg := new String' - (Argv (Arg_Idx .. Next_Arg_Idx)); - - SwP := Arg'First; - while SwP < Arg'Last and then - Arg (SwP + 1) /= '=' loop - SwP := SwP + 1; - end loop; - end if; - Place (ASCII.NUL); - Place (Arg (SwP + 2 .. Arg'Last)); - Place (ASCII.NUL); + exit when Arg_Idx > Argv'Last; - when T_Commands => + end loop; + end Process_Argument; - -- Output -largs/-bargs/-cargs + Arg_Num := Arg_Num + 1; + end loop; - Place (' '); - Place (Sw.Unix_String - (Sw.Unix_String'First .. - Sw.Unix_String'First + 5)); + if Display_Command then + Put (Standard_Error, "generated command -->"); + Put (Standard_Error, Command_List (The_Command).Unixcmd.all); - -- Set source of new commands, also setting this - -- non-null indicates that we are in the special - -- commands mode for processing the -xargs case. + if Command_List (The_Command).Unixsws /= null then + for J in Command_List (The_Command).Unixsws'Range loop + Put (Standard_Error, " "); + Put (Standard_Error, + Command_List (The_Command).Unixsws (J).all); + end loop; + end if; - Make_Commands_Active := - Matching_Name - (Sw.Unix_String - (Sw.Unix_String'First + 7 .. - Sw.Unix_String'Last), - Commands); - - when T_Options => - if SwP + 1 > Arg'Last then - Place_Unix_Switches (Sw.Options.Unix_String); - SwP := Endp + 1; - - elsif Arg (SwP + 2) /= '(' then - SwP := SwP + 2; - Endp := Arg'Last; - - elsif Arg (Arg'Last) /= ')' then - Put (Standard_Error, - "incorrectly parenthesized argument: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; - SwP := Endp + 1; + Put (Standard_Error, " "); + Put (Standard_Error, String (Buffer.Table (1 .. Buffer.Last))); + Put (Standard_Error, "<--"); + New_Line (Standard_Error); + raise Normal_Exit; + end if; - else - SwP := SwP + 3; - Endp := Arg'Last - 1; - end if; + -- Gross error checking that the number of parameters is correct. + -- Not applicable to Unlimited_Files parameters. - while SwP <= Endp loop - P2 := SwP; + if (Param_Count = Command.Params'Length - 1 + and then Command.Params (Param_Count + 1) = Unlimited_Files) + or else Param_Count <= Command.Params'Length + then + null; - while P2 < Endp - and then Arg (P2 + 1) /= ',' - loop - P2 := P2 + 1; - end loop; + else + Put_Line (Standard_Error, + "Parameter count of " + & Integer'Image (Param_Count) + & " not equal to expected " + & Integer'Image (Command.Params'Length)); + Put (Standard_Error, "usage: "); + Put_Line (Standard_Error, Command.Usage.all); + Errors := Errors + 1; + end if; - -- Option name is in Arg (SwP .. P2) + if Errors > 0 then + raise Error_Exit; + else + -- Prepare arguments for a call to spawn, filtering out + -- embedded nulls place there to delineate strings. - Opt := Matching_Name (Arg (SwP .. P2), - Sw.Options); + declare + P1, P2 : Natural; + Inside_Nul : Boolean := False; + Arg : String (1 .. 1024); + Arg_Ctr : Natural; - if Opt /= null then - Place_Unix_Switches (Opt.Unix_String); - end if; + begin + P1 := 1; - SwP := P2 + 2; - end loop; + while P1 <= Buffer.Last and then Buffer.Table (P1) = ' ' loop + P1 := P1 + 1; + end loop; + + Arg_Ctr := 1; + Arg (Arg_Ctr) := Buffer.Table (P1); + + while P1 <= Buffer.Last loop - when T_Other => - Place_Unix_Switches - (new String'(Sw.Unix_String.all & Arg.all)); + if Buffer.Table (P1) = ASCII.NUL then + if Inside_Nul then + Inside_Nul := False; + else + Inside_Nul := True; + end if; + end if; + + if Buffer.Table (P1) = ' ' and then not Inside_Nul then + P1 := P1 + 1; + Arg_Ctr := Arg_Ctr + 1; + Arg (Arg_Ctr) := Buffer.Table (P1); - end case; + else + Last_Switches.Increment_Last; + P2 := P1; + + while P2 < Buffer.Last + and then (Buffer.Table (P2 + 1) /= ' ' or else + Inside_Nul) + loop + P2 := P2 + 1; + Arg_Ctr := Arg_Ctr + 1; + Arg (Arg_Ctr) := Buffer.Table (P2); + if Buffer.Table (P2) = ASCII.NUL then + Arg_Ctr := Arg_Ctr - 1; + if Inside_Nul then + Inside_Nul := False; + else + Inside_Nul := True; + end if; end if; - end; + end loop; + + Last_Switches.Table (Last_Switches.Last) := + new String'(String (Arg (1 .. Arg_Ctr))); + P1 := P2 + 2; + Arg_Ctr := 1; + Arg (Arg_Ctr) := Buffer.Table (P1); end if; + end loop; + end; + end if; + end VMS_Conversion; - Arg_Idx := Next_Arg_Idx + 1; - end; + ------------------------------------- + -- Start of processing for GNATCmd -- + ------------------------------------- - exit when Arg_Idx > Argv'Last; +begin + -- Initializations - end loop; - end; + Namet.Initialize; + Csets.Initialize; - Arg_Num := Arg_Num + 1; - end loop; + Snames.Initialize; - if Display_Command then - Put (Standard_Error, "generated command -->"); - Put (Standard_Error, String (Buffer.Table (1 .. Buffer.Last))); - Put (Standard_Error, "<--"); - New_Line (Standard_Error); - raise Normal_Exit; - end if; + Prj.Initialize; + + Last_Switches.Init; + Last_Switches.Set_Last (0); - -- Gross error checking that the number of parameters is correct. - -- Not applicable to Unlimited_Files parameters. + First_Switches.Init; + First_Switches.Set_Last (0); - if not ((Param_Count = Command.Params'Length - 1 and then - Command.Params (Param_Count + 1) = Unlimited_Files) - or else (Param_Count <= Command.Params'Length)) + -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers, + -- filenames and pathnames to Unix style. + + if Hostparm.OpenVMS + or else To_Lower (Getenv ("EMULATE_VMS").all) = "true" then - Put_Line (Standard_Error, - "Parameter count of " - & Integer'Image (Param_Count) - & " not equal to expected " - & Integer'Image (Command.Params'Length)); - Put (Standard_Error, "usage: "); - Put_Line (Standard_Error, Command.Usage.all); - Errors := Errors + 1; - end if; + VMS_Conversion (The_Command); + + -- If not on VMS, scan the command line directly - if Errors > 0 then - raise Error_Exit; else - -- Prepare arguments for a call to spawn, filtering out - -- embedded nulls place there to delineate strings. + if Argument_Count = 0 then + Non_VMS_Usage; + return; + else + begin + if Argument_Count > 1 and then Argument (1) = "-v" then + Opt.Verbose_Mode := True; + Command_Arg := 2; + end if; - declare - Pname_Ptr : Natural; - Args : Argument_List (1 .. 500); - Nargs : Natural; - P1, P2 : Natural; - Exec_Path : String_Access; - Inside_Nul : Boolean := False; - Arg : String (1 .. 1024); - Arg_Ctr : Natural; + The_Command := Real_Command_Type'Value (Argument (Command_Arg)); - begin - Pname_Ptr := 1; + if Command_List (The_Command).VMS_Only then + Non_VMS_Usage; + Fail ("Command """ & Command_List (The_Command).Cname.all & + """ can only be used on VMS"); + end if; + exception + when Constraint_Error => + + -- Check if it is an alternate command + declare + Alternate : Alternate_Command; + + begin + Alternate := Alternate_Command'Value + (Argument (Command_Arg)); + The_Command := Corresponding_To (Alternate); + + exception + when Constraint_Error => + Non_VMS_Usage; + Fail ("Unknown command: " & Argument (Command_Arg)); + end; + end; - while Pname_Ptr < Buffer.Last - and then Buffer.Table (Pname_Ptr + 1) /= ' ' - loop - Pname_Ptr := Pname_Ptr + 1; + for Arg in Command_Arg + 1 .. Argument_Count loop + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(Argument (Arg)); end loop; + end if; + end if; - P1 := Pname_Ptr + 2; - Arg_Ctr := 1; - Arg (Arg_Ctr) := Buffer.Table (P1); + declare + Program : constant String := + Program_Name (Command_List (The_Command).Unixcmd.all).all; - Nargs := 0; - while P1 <= Buffer.Last loop + Exec_Path : String_Access; - if Buffer.Table (P1) = ASCII.NUL then - if Inside_Nul then - Inside_Nul := False; - else - Inside_Nul := True; - end if; - end if; + begin + -- Locate the executable for the command - if Buffer.Table (P1) = ' ' and then not Inside_Nul then - P1 := P1 + 1; - Arg_Ctr := Arg_Ctr + 1; - Arg (Arg_Ctr) := Buffer.Table (P1); + Exec_Path := Locate_Exec_On_Path (Program); - else - Nargs := Nargs + 1; - P2 := P1; + if Exec_Path = null then + Put_Line (Standard_Error, "Couldn't locate " & Program); + raise Error_Exit; + end if; + + -- If there are switches for the executable, put them as first switches + + if Command_List (The_Command).Unixsws /= null then + for J in Command_List (The_Command).Unixsws'Range loop + First_Switches.Increment_Last; + First_Switches.Table (First_Switches.Last) := + Command_List (The_Command).Unixsws (J); + end loop; + end if; + + -- For BIND, FIND, LINK, LIST and XREF, look for project file related + -- switches. + + if The_Command = Bind + or else The_Command = Find + or else The_Command = Link + or else The_Command = List + or else The_Command = Xref + then + case The_Command is + when Bind => + Tool_Package_Name := Name_Binder; + when Find => + Tool_Package_Name := Name_Finder; + when Link => + Tool_Package_Name := Name_Linker; + when List => + Tool_Package_Name := Name_Gnatls; + when Xref => + Tool_Package_Name := Name_Cross_Reference; + when others => + null; + end case; + + declare + Arg_Num : Positive := 1; + Argv : String_Access; + + procedure Remove_Switch (Num : Positive); + -- Remove a project related switch from table Last_Switches + + ------------------- + -- Remove_Switch -- + ------------------- + + procedure Remove_Switch (Num : Positive) is + begin + Last_Switches.Table (Num .. Last_Switches.Last - 1) := + Last_Switches.Table (Num + 1 .. Last_Switches.Last); + Last_Switches.Decrement_Last; + end Remove_Switch; + + -- Start of processing for ??? (need block name here) + + begin + while Arg_Num <= Last_Switches.Last loop + Argv := Last_Switches.Table (Arg_Num); + + if Argv (Argv'First) = '-' then + if Argv'Length = 1 then + Fail ("switch character cannot be followed by a blank"); + end if; + + -- The two style project files (-p and -P) cannot be used + -- together + + if (The_Command = Find or else The_Command = Xref) + and then Argv (2) = 'p' + then + Old_Project_File_Used := True; + if Project_File /= null then + Fail ("-P and -p cannot be used together"); + end if; + end if; + + -- -vPx Specify verbosity while parsing project files + + if Argv'Length = 4 + and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP" + then + case Argv (Argv'Last) is + when '0' => + Current_Verbosity := Prj.Default; + when '1' => + Current_Verbosity := Prj.Medium; + when '2' => + Current_Verbosity := Prj.High; + when others => + Fail ("Invalid switch: " & Argv.all); + end case; + + Remove_Switch (Arg_Num); + + -- -Pproject_file Specify project file to be used + + elsif Argv'Length >= 3 + and then Argv (Argv'First + 1) = 'P' + then + + -- Only one -P switch can be used + + if Project_File /= null then + Fail (Argv.all & + ": second project file forbidden (first is """ & + Project_File.all & """)"); + + -- The two style project files (-p and -P) cannot be + -- used together. + + elsif Old_Project_File_Used then + Fail ("-p and -P cannot be used together"); - while P2 < Buffer.Last - and then (Buffer.Table (P2 + 1) /= ' ' or else - Inside_Nul) - loop - P2 := P2 + 1; - Arg_Ctr := Arg_Ctr + 1; - Arg (Arg_Ctr) := Buffer.Table (P2); - if Buffer.Table (P2) = ASCII.NUL then - Arg_Ctr := Arg_Ctr - 1; - if Inside_Nul then - Inside_Nul := False; else - Inside_Nul := True; + Project_File := + new String'(Argv (Argv'First + 2 .. Argv'Last)); end if; + + Remove_Switch (Arg_Num); + + -- -Xexternal=value Specify an external reference to be + -- used in project files + + elsif Argv'Length >= 5 + and then Argv (Argv'First + 1) = 'X' + then + declare + Equal_Pos : constant Natural := + Index ('=', Argv (Argv'First + 2 .. Argv'Last)); + begin + if Equal_Pos >= Argv'First + 3 and then + Equal_Pos /= Argv'Last then + Add (External_Name => + Argv (Argv'First + 2 .. Equal_Pos - 1), + Value => Argv (Equal_Pos + 1 .. Argv'Last)); + else + Fail (Argv.all & + " is not a valid external assignment."); + end if; + end; + + Remove_Switch (Arg_Num); + + else + Arg_Num := Arg_Num + 1; end if; - end loop; - Args (Nargs) := new String'(String (Arg (1 .. Arg_Ctr))); - P1 := P2 + 2; - Arg_Ctr := 1; - Arg (Arg_Ctr) := Buffer.Table (P1); + else + Arg_Num := Arg_Num + 1; + end if; + end loop; + end; + end if; + + -- If there is a project file specified, parse it, get the switches + -- for the tool and setup PATH environment variables. + + if Project_File /= null then + Prj.Pars.Set_Verbosity (To => Current_Verbosity); + + Prj.Pars.Parse + (Project => Project, + Project_File_Name => Project_File.all); + + if Project = Prj.No_Project then + Fail ("""" & Project_File.all & """ processing failed"); + end if; + + -- Check if a package with the name of the tool is in the project + -- file and if there is one, get the switches, if any, and scan them. + + declare + Data : Prj.Project_Data := Prj.Projects.Table (Project); + Pkg : Prj.Package_Id := + Prj.Util.Value_Of + (Name => Tool_Package_Name, + In_Packages => Data.Decl.Packages); + + Element : Package_Element; + + Default_Switches_Array : Array_Element_Id; + + The_Switches : Prj.Variable_Value; + Current : Prj.String_List_Id; + The_String : String_Element; + + begin + if Pkg /= No_Package then + Element := Packages.Table (Pkg); + + -- Packages Gnatls has a single attribute Switches, that is + -- not an associative array. + + if The_Command = List then + The_Switches := + Prj.Util.Value_Of + (Variable_Name => Snames.Name_Switches, + In_Variables => Element.Decl.Attributes); + + -- Packages Binder (for gnatbind), Cross_Reference (for + -- gnatxref), Linker (for gnatlink) and Finder + -- (for gnatfind) have an attributed Default_Switches, + -- an associative array, indexed by the name of the + -- programming language. + else + Default_Switches_Array := + Prj.Util.Value_Of + (Name => Name_Default_Switches, + In_Arrays => Packages.Table (Pkg).Decl.Arrays); + The_Switches := Prj.Util.Value_Of + (Index => Name_Ada, + In_Array => Default_Switches_Array); + + end if; + + -- If there are switches specified in the package of the + -- project file corresponding to the tool, scan them. + + case The_Switches.Kind is + when Prj.Undefined => + null; + + when Prj.Single => + if String_Length (The_Switches.Value) > 0 then + String_To_Name_Buffer (The_Switches.Value); + First_Switches.Increment_Last; + First_Switches.Table (First_Switches.Last) := + new String'(Name_Buffer (1 .. Name_Len)); + end if; + + when Prj.List => + Current := The_Switches.Values; + while Current /= Prj.Nil_String loop + The_String := String_Elements.Table (Current); + + if String_Length (The_String.Value) > 0 then + String_To_Name_Buffer (The_String.Value); + First_Switches.Increment_Last; + First_Switches.Table (First_Switches.Last) := + new String'(Name_Buffer (1 .. Name_Len)); + end if; + + Current := The_String.Next; + end loop; + end case; end if; + end; + + -- Set up the environment variables ADA_INCLUDE_PATH and + -- ADA_OBJECTS_PATH. + + Setenv + (Name => Ada_Include_Path, + Value => Prj.Env.Ada_Include_Path (Project).all); + Setenv + (Name => Ada_Objects_Path, + Value => Prj.Env.Ada_Objects_Path + (Project, Including_Libraries => False).all); + + if The_Command = Bind or else The_Command = Link then + Change_Dir + (Get_Name_String + (Projects.Table (Project).Object_Directory)); + end if; + + if The_Command = Link then + + -- Add the default search directories, to be able to find + -- libgnat in call to MLib.Utl.Lib_Directory. + + Add_Default_Search_Dirs; + + declare + There_Are_Libraries : Boolean := False; + + begin + -- Check if there are library project files + + if MLib.Tgt.Libraries_Are_Supported then + Set_Libraries (Project, There_Are_Libraries); + end if; + + -- If there are, add the necessary additional switches + + if There_Are_Libraries then + + -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir> + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-L" & MLib.Utl.Lib_Directory); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-lgnarl"); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-lgnat"); + + declare + Option : constant String_Access := + MLib.Tgt.Linker_Library_Path_Option + (MLib.Utl.Lib_Directory); + + begin + if Option /= null then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + Option; + end if; + end; + end if; + end; + end if; + end if; + + -- Gather all the arguments and invoke the executable + + declare + The_Args : Argument_List + (1 .. First_Switches.Last + Last_Switches.Last); + Arg_Num : Natural := 0; + begin + for J in 1 .. First_Switches.Last loop + Arg_Num := Arg_Num + 1; + The_Args (Arg_Num) := First_Switches.Table (J); end loop; - Exec_Path := Locate_Exec_On_Path - (String (Buffer.Table (1 .. Pname_Ptr))); + for J in 1 .. Last_Switches.Last loop + Arg_Num := Arg_Num + 1; + The_Args (Arg_Num) := Last_Switches.Table (J); + end loop; - if Exec_Path = null then - Put_Line (Standard_Error, - "Couldn't locate " - & String (Buffer.Table (1 .. Pname_Ptr))); - raise Error_Exit; + if Opt.Verbose_Mode then + Output.Write_Str (Exec_Path.all); + + for Arg in The_Args'Range loop + Output.Write_Char (' '); + Output.Write_Str (The_Args (Arg).all); + end loop; + + Output.Write_Eol; end if; My_Exit_Status - := Exit_Status (Spawn (Exec_Path.all, Args (1 .. Nargs))); - + := Exit_Status (Spawn (Exec_Path.all, The_Args)); + raise Normal_Exit; end; - - raise Normal_Exit; - end if; + end; exception when Error_Exit => diff --git a/gcc/ada/gnatdll.adb b/gcc/ada/gnatdll.adb index fbeb470c275..5fba394df2e 100644 --- a/gcc/ada/gnatdll.adb +++ b/gcc/ada/gnatdll.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1997-2001, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2002, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,8 +37,8 @@ with GNAT.OS_Lib; with GNAT.Command_Line; with Gnatvsn; -with MDLL.Files; -with MDLL.Tools; +with MDLL.Fil; +with MDLL.Utl; procedure Gnatdll is @@ -62,11 +62,15 @@ procedure Gnatdll is -- Check the context before runing any commands to build the library Syntax_Error : exception; + -- Raised when a syntax error is detected, in this case a usage info will + -- be displayed. + Context_Error : exception; - -- What are these for ??? + -- Raised when some files (specifed on the command line) are missing to + -- build the DLL. Help : Boolean := False; - -- What is this for ??? + -- Help will be set to True the usage information is to be displayed. Version : constant String := Gnatvsn.Gnat_Version_String; -- Why should it be necessary to make a copy of this @@ -75,11 +79,17 @@ procedure Gnatdll is -- Default address for non relocatable DLL (Win32) Lib_Filename : Unbounded_String := Null_Unbounded_String; + -- The DLL filename that will be created (.dll) + Def_Filename : Unbounded_String := Null_Unbounded_String; + -- The definition filename (.def) + List_Filename : Unbounded_String := Null_Unbounded_String; + -- The name of the file containing the objects file to put into the DLL + DLL_Address : Unbounded_String := To_Unbounded_String (Default_DLL_Address); - -- What are the above ??? + -- The DLL's base address Objects_Files : Argument_List_Access := Null_Argument_List_Access; -- List of objects to put inside the library @@ -95,13 +105,18 @@ procedure Gnatdll is Bargs_Options : Argument_List_Access := Null_Argument_List_Access; -- GNAT linker and binder args options - type Build_Mode_State is (Import_Lib, Dynamic_Lib, Nil); - -- Comments needed ??? + type Build_Mode_State is (Import_Lib, Dynamic_Lib, Dynamic_Lib_Only, Nil); + -- Import_Lib means only the .a file will be created, Dynamic_Lib means + -- that both the DLL and the import library will be created. + -- Dynamic_Lib_Only means that only the DLL will be created (no import + -- library). Build_Mode : Build_Mode_State := Nil; + -- Will be set when parsing the command line. + Must_Build_Relocatable : Boolean := True; - Build_Import : Boolean := True; - -- Comments needed + -- True means build a relocatable DLL, will be set to False if a + -- non-relocatable DLL must be built. ------------ -- Syntax -- @@ -130,6 +145,8 @@ procedure Gnatdll is P (" -e file Definition file containing exports"); P (" -d file Put objects in the relocatable dynamic " & "library <file>"); + P (" -b addr Set base address for the relocatable DLL"); + P (" default address is " & Default_DLL_Address); P (" -a[addr] Build non-relocatable DLL at address <addr>"); P (" if <addr> is not specified use " & Default_DLL_Address); @@ -159,16 +176,12 @@ procedure Gnatdll is use GNAT.Command_Line; procedure Add_File (Filename : in String); - -- add one file to the list of file to handle + -- Add one file to the list of file to handle procedure Add_Files_From_List (List_Filename : in String); - -- add the files listed in List_Filename (one by line) to the list + -- Add the files listed in List_Filename (one by line) to the list -- of file to handle - procedure Ali_To_Object_List; - -- for each ali file in Afiles set put a corresponding object file in - -- Ofiles set. - Max_Files : constant := 5_000; Max_Options : constant := 100; -- These are arbitrary limits, a better way will be to use linked list. @@ -196,16 +209,16 @@ procedure Gnatdll is B : Positive := Bopts'First; -- A list of -bargs options (B is next entry to be used) + Build_Import : Boolean := True; + -- Set to Fals if option -n if specified (no-import). + -------------- -- Add_File -- -------------- procedure Add_File (Filename : in String) is begin - -- others files are to be put inside the dynamic library - -- ??? this makes no sense, should it be "Other files ..." - - if Files.Is_Ali (Filename) then + if Fil.Is_Ali (Filename) then Check (Filename); @@ -215,7 +228,7 @@ procedure Gnatdll is Afiles (A) := new String'(Filename); A := A + 1; - elsif Files.Is_Obj (Filename) then + elsif Fil.Is_Obj (Filename) then Check (Filename); @@ -253,18 +266,6 @@ procedure Gnatdll is Text_IO.Close (File); end Add_Files_From_List; - ------------------------ - -- Ali_To_Object_List -- - ------------------------ - - procedure Ali_To_Object_List is - begin - for K in 1 .. A - 1 loop - Ofiles (O) := new String'(Files.Ext_To (Afiles (K).all, "o")); - O := O + 1; - end loop; - end Ali_To_Object_List; - -- Start of processing for Parse_Command_Line begin @@ -273,7 +274,7 @@ procedure Gnatdll is -- scan gnatdll switches loop - case Getopt ("g h v q k a? d: e: l: n I:") is + case Getopt ("g h v q k a? b: d: e: l: n I:") is when ASCII.Nul => exit; @@ -326,6 +327,12 @@ procedure Gnatdll is Must_Build_Relocatable := False; + when 'b' => + + DLL_Address := To_Unbounded_String (Parameter); + + Must_Build_Relocatable := True; + when 'e' => Def_Filename := To_Unbounded_String (Parameter); @@ -338,7 +345,7 @@ procedure Gnatdll is if Def_Filename = Null_Unbounded_String then Def_Filename := To_Unbounded_String - (Files.Ext_To (Parameter, "def")); + (Fil.Ext_To (Parameter, "def")); end if; Build_Mode := Dynamic_Lib; @@ -419,6 +426,17 @@ procedure Gnatdll is "nothing to do."); end if; + -- -n option but no file specified + + if not Build_Import + and then A = Afiles'First + and then O = Ofiles'First + then + Exceptions.Raise_Exception + (Syntax_Error'Identity, + "-n specified but there are no objects to build the library."); + end if; + -- Check if we want to build an import library (option -e and -- no file specified) @@ -429,6 +447,12 @@ procedure Gnatdll is Build_Mode := Import_Lib; end if; + -- Check if only a dynamic library must be built. + + if Build_Mode = Dynamic_Lib and then not Build_Import then + Build_Mode := Dynamic_Lib_Only; + end if; + if O /= Ofiles'First then Objects_Files := new OS_Lib.Argument_List'(Ofiles (1 .. O - 1)); end if; @@ -495,7 +519,7 @@ begin Text_IO.New_Line; end if; - MDLL.Tools.Locate; + MDLL.Utl.Locate; if Help or else (MDLL.Verbose and then Ada.Command_Line.Argument_Count = 1) @@ -521,8 +545,21 @@ begin To_String (Lib_Filename), To_String (Def_Filename), To_String (DLL_Address), - Build_Import, - Must_Build_Relocatable); + Build_Import => True, + Relocatable => Must_Build_Relocatable); + + when Dynamic_Lib_Only => + MDLL.Build_Dynamic_Library + (Objects_Files.all, + Ali_Files.all, + Options.all, + Bargs_Options.all, + Largs_Options.all, + To_String (Lib_Filename), + To_String (Def_Filename), + To_String (DLL_Address), + Build_Import => False, + Relocatable => Must_Build_Relocatable); when Nil => null; diff --git a/gcc/ada/gnatfind.adb b/gcc/ada/gnatfind.adb index f7ebf856a0c..541ad4bf766 100644 --- a/gcc/ada/gnatfind.adb +++ b/gcc/ada/gnatfind.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.26 $ +-- $Revision$ -- -- --- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -25,13 +25,17 @@ -- -- ------------------------------------------------------------------------------ -with Xr_Tabls; -with Xref_Lib; use Xref_Lib; -with Ada.Text_IO; -with GNAT.Command_Line; +with Xr_Tabls; use Xr_Tabls; +with Xref_Lib; use Xref_Lib; +with Osint; use Osint; +with Types; use Types; + with Gnatvsn; -with Osint; +with Opt; + with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with Ada.Text_IO; use Ada.Text_IO; +with GNAT.Command_Line; use GNAT.Command_Line; --------------- -- Gnatfind -- @@ -71,15 +75,20 @@ procedure Gnatfind is procedure Parse_Cmd_Line is begin loop - case GNAT.Command_Line.Getopt ("a aI: aO: d e f g h I: p: r s t") is + case + GNAT.Command_Line.Getopt + ("a aI: aO: d e f g h I: nostdinc nostdlib p: r s t -RTS=") + is when ASCII.NUL => exit; when 'a' => if GNAT.Command_Line.Full_Switch = "a" then Read_Only := True; + elsif GNAT.Command_Line.Full_Switch = "aI" then Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); + else Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); end if; @@ -103,9 +112,18 @@ procedure Gnatfind is Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); + when 'n' => + if GNAT.Command_Line.Full_Switch = "nostdinc" then + Opt.No_Stdinc := True; + + elsif GNAT.Command_Line.Full_Switch = "nostlib" then + Opt.No_Stdlib := True; + end if; + when 'p' => declare S : constant String := GNAT.Command_Line.Parameter; + begin Prj_File_Length := S'Length; Prj_File (1 .. Prj_File_Length) := S; @@ -120,6 +138,39 @@ procedure Gnatfind is when 't' => Type_Tree := True; + -- Only switch starting with -- recognized is --RTS + + when '-' => + Opt.No_Stdinc := True; + Opt.RTS_Switch := True; + + declare + Src_Path_Name : String_Ptr := + Get_RTS_Search_Dir + (GNAT.Command_Line.Parameter, Include); + Lib_Path_Name : String_Ptr := + Get_RTS_Search_Dir + (GNAT.Command_Line.Parameter, Objects); + + begin + if Src_Path_Name /= null and then Lib_Path_Name /= null then + Add_Search_Dirs (Src_Path_Name, Include); + Add_Search_Dirs (Lib_Path_Name, Objects); + + elsif Src_Path_Name = null and then Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude and adalib directories"); + + elsif Src_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude directory"); + + elsif Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adalib directory"); + end if; + end; + when others => Write_Usage; end case; @@ -130,6 +181,7 @@ procedure Gnatfind is loop declare S : constant String := GNAT.Command_Line.Get_Argument; + begin exit when S'Length = 0; @@ -147,7 +199,7 @@ procedure Gnatfind is -- Next arguments are the files to search else - Add_File (S); + Add_Xref_File (S); Wide_Search := False; Nb_File := Nb_File + 1; end if; @@ -162,7 +214,7 @@ procedure Gnatfind is when GNAT.Command_Line.Invalid_Parameter => Ada.Text_IO.Put_Line ("Parameter missing for : " - & GNAT.Command_Line.Parameter); + & GNAT.Command_Line.Full_Switch); Write_Usage; when Xref_Lib.Invalid_Argument => @@ -175,11 +227,9 @@ procedure Gnatfind is ----------------- procedure Write_Usage is - use Ada.Text_IO; - begin Put_Line ("GNATFIND " & Gnatvsn.Gnat_Version_String - & " Copyright 1998-2001, Ada Core Technologies Inc."); + & " Copyright 1998-2002, Ada Core Technologies Inc."); Put_Line ("Usage: gnatfind pattern[:sourcefile[:line[:column]]] " & "[file1 file2 ...]"); New_Line; @@ -195,28 +245,35 @@ procedure Gnatfind is & "references. This parameters are optional"); New_Line; Put_Line ("gnatfind switches:"); - Put_Line (" -a Consider all files, even when the ali file is " + Put_Line (" -a Consider all files, even when the ali file is " & "readonly"); - Put_Line (" -aIdir Specify source files search path"); - Put_Line (" -aOdir Specify library/object files search path"); - Put_Line (" -d Output derived type information"); - Put_Line (" -e Use the full regular expression set for pattern"); - Put_Line (" -f Output full path name"); - Put_Line (" -g Output information only for global symbols"); - Put_Line (" -Idir Like -aIdir -aOdir"); - Put_Line (" -p file Use file as the default project file"); - Put_Line (" -r Find all references (default to find declaration" + Put_Line (" -aIdir Specify source files search path"); + Put_Line (" -aOdir Specify library/object files search path"); + Put_Line (" -d Output derived type information"); + Put_Line (" -e Use the full regular expression set for " + & "pattern"); + Put_Line (" -f Output full path name"); + Put_Line (" -g Output information only for global symbols"); + Put_Line (" -Idir Like -aIdir -aOdir"); + Put_Line (" -nostdinc Don't look for sources in the system default" + & " directory"); + Put_Line (" -nostdlib Don't look for library files in the system" + & " default directory"); + Put_Line (" --RTS=dir specify the default source and object search" + & " path"); + Put_Line (" -p file Use file as the default project file"); + Put_Line (" -r Find all references (default to find declaration" & " only)"); - Put_Line (" -s Print source line"); - Put_Line (" -t Print type hierarchy"); + Put_Line (" -s Print source line"); + Put_Line (" -t Print type hierarchy"); New_Line; raise Usage_Error; end Write_Usage; -begin - Osint.Initialize (Osint.Compiler); +-- Start of processing for Gnatfind +begin Parse_Cmd_Line; if not Have_Entity then diff --git a/gcc/ada/gnatlbr.adb b/gcc/ada/gnatlbr.adb index f4dd7cb2f10..a6896161ea4 100644 --- a/gcc/ada/gnatlbr.adb +++ b/gcc/ada/gnatlbr.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.13 $ +-- $Revision$ -- -- --- Copyright (C) 1997-2000 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-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- -- diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 5143a252f10..24a1198806a 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $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- -- @@ -28,12 +28,17 @@ -- Gnatlink usage: please consult the gnat documentation +with Ada.Exceptions; use Ada.Exceptions; +with ALI; use ALI; with Gnatvsn; use Gnatvsn; with Hostparm; +with Namet; use Namet; with Osint; use Osint; with Output; use Output; +with Switch; use Switch; with System; use System; with Table; +with Types; with Ada.Command_Line; use Ada.Command_Line; with GNAT.OS_Lib; use GNAT.OS_Lib; @@ -97,6 +102,16 @@ procedure Gnatlink is -- file. Only application objects are collected there (see details in -- Linker_Objects table comments) + package Binder_Options_From_ALI is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, -- equals low bound of Argument_List for Spawn + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Gnatlink.Binder_Options_From_ALI"); + -- This table collects the switches from the ALI file of the main + -- subprogram. + package Binder_Options is new Table.Table ( Table_Component_Type => String_Access, Table_Index_Type => Integer, @@ -139,6 +154,8 @@ procedure Gnatlink is Ada_Bind_File : Boolean := True; -- Set to True if bind file is generated in Ada + Standard_Gcc : Boolean := True; + Compile_Bind_File : Boolean := True; -- Set to False if bind file is not to be compiled @@ -250,30 +267,6 @@ procedure Gnatlink is Next_Arg : Integer; begin - Binder_Options.Increment_Last; - Binder_Options.Table (Binder_Options.Last) := new String'("-c"); - - -- If the main program is in Ada it is compiled with the following - -- switches: - - -- -gnatA stops reading gnat.adc, since we don't know what - -- pagmas would work, and we do not need it anyway. - - -- -gnatWb allows brackets coding for wide characters - - -- -gnatiw allows wide characters in identifiers. This is needed - -- because bindgen uses brackets encoding for all upper - -- half and wide characters in identifier names. - - if Ada_Bind_File then - Binder_Options.Increment_Last; - Binder_Options.Table (Binder_Options.Last) := new String'("-gnatA"); - Binder_Options.Increment_Last; - Binder_Options.Table (Binder_Options.Last) := new String'("-gnatWb"); - Binder_Options.Increment_Last; - Binder_Options.Table (Binder_Options.Last) := new String'("-gnatiw"); - end if; - -- Loop through arguments of gnatlink command Next_Arg := 1; @@ -288,9 +281,7 @@ procedure Gnatlink is -- We definitely need section by section comments here ??? - if Arg'Length /= 0 - and then (Arg (1) = Switch_Character or else Arg (1) = '-') - then + if Arg'Length /= 0 and then Arg (1) = '-' then if Arg'Length > 4 and then Arg (2 .. 5) = "gnat" then @@ -440,6 +431,7 @@ procedure Gnatlink is begin Gcc := new String'(Program_Args.all (1).all); + Standard_Gcc := False; -- Set appropriate flags for switches passed @@ -449,10 +441,7 @@ procedure Gnatlink is AF : Integer := Arg'First; begin - if Arg'Length /= 0 - and then (Arg (AF) = Switch_Character - or else Arg (AF) = '-') - then + if Arg'Length /= 0 and then Arg (AF) = '-' then if Arg (AF + 1) = 'g' and then (Arg'Length = 2 or else Arg (AF + 2) in '0' .. '3' @@ -765,131 +754,116 @@ procedure Gnatlink is if Next_Line (Nfirst .. Nlast) /= End_Info then loop - -- Add binder options only if not already set on the command - -- line. This rule is a way to control the linker options order. - - if not Is_Option_Present - (Next_Line (Nfirst .. Nlast)) - then - if Next_Line (Nfirst .. Nlast) = "-static" then - GNAT_Static := True; + if Next_Line (Nfirst .. Nlast) = "-static" then + GNAT_Static := True; - elsif Next_Line (Nfirst .. Nlast) = "-shared" then - GNAT_Shared := True; + elsif Next_Line (Nfirst .. Nlast) = "-shared" then + GNAT_Shared := True; - else - if Nlast > Nfirst + 2 and then - Next_Line (Nfirst .. Nfirst + 1) = "-L" - then - -- Construct a library search path for use later - -- to locate static gnatlib libraries. - - if Libpath.Last > 1 then - Libpath.Increment_Last; - Libpath.Table (Libpath.Last) := Path_Separator; - end if; + -- Add binder options only if not already set on the command + -- line. This rule is a way to control the linker options order. - for I in Nfirst + 2 .. Nlast loop - Libpath.Increment_Last; - Libpath.Table (Libpath.Last) := Next_Line (I); - end loop; + elsif not Is_Option_Present (Next_Line (Nfirst .. Nlast)) then + if Nlast > Nfirst + 2 and then + Next_Line (Nfirst .. Nfirst + 1) = "-L" + then + -- Construct a library search path for use later + -- to locate static gnatlib libraries. - Linker_Options.Increment_Last; + if Libpath.Last > 1 then + Libpath.Increment_Last; + Libpath.Table (Libpath.Last) := Path_Separator; + end if; - Linker_Options.Table (Linker_Options.Last) := - new String'(Next_Line (Nfirst .. Nlast)); + for I in Nfirst + 2 .. Nlast loop + Libpath.Increment_Last; + Libpath.Table (Libpath.Last) := Next_Line (I); + end loop; - elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat" - or else Next_Line (Nfirst .. Nlast) = "-lgnarl" - or else Next_Line (Nfirst .. Nlast) = "-lgnat" - then - -- Given a Gnat standard library, search the - -- library path to find the library location - declare - File_Path : String_Access; + Linker_Options.Increment_Last; - Object_Lib_Extension : constant String := - Value - (Object_Library_Ext_Ptr); + Linker_Options.Table (Linker_Options.Last) := + new String'(Next_Line (Nfirst .. Nlast)); - File_Name : String := - "lib" & - Next_Line (Nfirst + 2 .. Nlast) & - Object_Lib_Extension; + elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat" + or else Next_Line (Nfirst .. Nlast) = "-lgnarl" + or else Next_Line (Nfirst .. Nlast) = "-lgnat" + then + -- Given a Gnat standard library, search the + -- library path to find the library location - begin - File_Path := - Locate_Regular_File - (File_Name, - String (Libpath.Table (1 .. Libpath.Last))); + declare + File_Path : String_Access; + Object_Lib_Extension : constant String := + Value (Object_Library_Ext_Ptr); - if File_Path /= null then - if GNAT_Static then + File_Name : String := "lib" & + Next_Line (Nfirst + 2 .. Nlast) & Object_Lib_Extension; - -- If static gnatlib found, explicitly - -- specify to overcome possible linker - -- default usage of shared version. + begin + File_Path := + Locate_Regular_File (File_Name, + String (Libpath.Table (1 .. Libpath.Last))); - Linker_Options.Increment_Last; + if File_Path /= null then + if GNAT_Static then - Linker_Options.Table (Linker_Options.Last) := - new String'(File_Path.all); + -- If static gnatlib found, explicitly + -- specify to overcome possible linker + -- default usage of shared version. - elsif GNAT_Shared then + Linker_Options.Increment_Last; - -- If shared gnatlib desired, add the - -- appropriate system specific switch - -- so that it can be located at runtime. + Linker_Options.Table (Linker_Options.Last) := + new String'(File_Path.all); - declare - Run_Path_Opt : constant String := - Value - (Run_Path_Option_Ptr); + elsif GNAT_Shared then - begin - if Run_Path_Opt'Length /= 0 then + -- If shared gnatlib desired, add the + -- appropriate system specific switch + -- so that it can be located at runtime. - -- Output the system specific linker - -- command that allows the image - -- activator to find the shared library - -- at runtime. + declare + Run_Path_Opt : constant String := + Value (Run_Path_Option_Ptr); - Linker_Options.Increment_Last; + begin + if Run_Path_Opt'Length /= 0 then - Linker_Options.Table - (Linker_Options.Last) := - new String'(Run_Path_Opt - & File_Path - (1 .. File_Path'Length - - File_Name'Length)); - end if; + -- Output the system specific linker + -- command that allows the image + -- activator to find the shared library + -- at runtime. Linker_Options.Increment_Last; - Linker_Options.Table - (Linker_Options.Last) := - new String'(Next_Line - (Nfirst .. Nlast)); - - end; - end if; + Linker_Options.Table (Linker_Options.Last) + := new String'(Run_Path_Opt + & File_Path + (1 .. File_Path'Length + - File_Name'Length)); + end if; - else - -- If gnatlib library not found, then - -- add it anyway in case some other - -- mechanimsm may find it. + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) + := new String'(Next_Line (Nfirst .. Nlast)); + end; + end if; - Linker_Options.Increment_Last; + else + -- If gnatlib library not found, then + -- add it anyway in case some other + -- mechanimsm may find it. - Linker_Options.Table (Linker_Options.Last) := - new String'(Next_Line (Nfirst .. Nlast)); - end if; - end; - else - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := - new String'(Next_Line (Nfirst .. Nlast)); - end if; + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) + := new String'(Next_Line (Nfirst .. Nlast)); + end if; + end; + else + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) + := new String'(Next_Line (Nfirst .. Nlast)); end if; end if; @@ -897,8 +871,8 @@ procedure Gnatlink is exit when Next_Line (Nfirst .. Nlast) = End_Info; if Ada_Bind_File then - Next_Line (Nfirst .. Nlast - 8) := - Next_Line (Nfirst + 8 .. Nlast); + Next_Line (Nfirst .. Nlast - 8) + := Next_Line (Nfirst + 8 .. Nlast); Nlast := Nlast - 8; end if; end loop; @@ -966,7 +940,6 @@ procedure Gnatlink is -- Start of processing for Gnatlink begin - if Argument_Count = 0 then Write_Usage; Exit_Program (E_Fatal); @@ -981,6 +954,36 @@ begin Process_Args; + -- We always compile with -c + + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-c"); + + -- If the main program is in Ada it is compiled with the following + -- switches: + + -- -gnatA stops reading gnat.adc, since we don't know what + -- pagmas would work, and we do not need it anyway. + + -- -gnatWb allows brackets coding for wide characters + + -- -gnatiw allows wide characters in identifiers. This is needed + -- because bindgen uses brackets encoding for all upper + -- half and wide characters in identifier names. + + if Ada_Bind_File then + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-gnatA"); + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-gnatWb"); + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := + new String'("-gnatiw"); + end if; + -- Locate all the necessary programs and verify required files are present Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all); @@ -999,13 +1002,61 @@ begin if not Is_Regular_File (Ali_File_Name.all) then Exit_With_Error (Ali_File_Name.all & " not found."); + + -- Read the ALI file of the main subprogram if the binder generated + -- file is in Ada, it need to be compiled and no --GCC= switch has + -- been specified. Fetch the back end switches from this ALI file and use + -- these switches to compile the binder generated file + + elsif Ada_Bind_File + and then Compile_Bind_File + and then Standard_Gcc + then + -- Do some initializations + + Initialize_ALI; + Namet.Initialize; + Name_Len := Ali_File_Name'Length; + Name_Buffer (1 .. Name_Len) := Ali_File_Name.all; + + declare + use Types; + F : constant File_Name_Type := Name_Find; + T : Text_Buffer_Ptr; + A : ALI_Id; + + begin + -- Osint.Add_Default_Search_Dirs; + -- Load the ALI file + + T := Read_Library_Info (F, True); + + -- Read it + + A := Scan_ALI (F, T, False, False, False); + + if A /= No_ALI_Id then + for + Index in Units.Table (ALIs.Table (A).First_Unit).First_Arg + .. Units.Table (ALIs.Table (A).First_Unit).Last_Arg + loop + -- Do not compile with the front end switches + + if not Is_Front_End_Switch (Args.Table (Index).all) then + Binder_Options_From_ALI.Increment_Last; + Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) + := String_Access (Args.Table (Index)); + end if; + end loop; + end if; + end; end if; if Verbose_Mode then Write_Eol; Write_Str ("GNATLINK "); Write_Str (Gnat_Version_String); - Write_Str (" Copyright 1996-2001 Free Software Foundation, Inc."); + Write_Str (" Copyright 1996-2002 Free Software Foundation, Inc."); Write_Eol; end if; @@ -1129,11 +1180,17 @@ begin if Compile_Bind_File then Bind_Step : declare Success : Boolean; - Args : Argument_List (1 .. Binder_Options.Last + 1); + Args : Argument_List + (1 .. Binder_Options_From_ALI.Last + Binder_Options.Last + 1); begin - for J in Binder_Options.First .. Binder_Options.Last loop - Args (J) := Binder_Options.Table (J); + for J in 1 .. Binder_Options_From_ALI.Last loop + Args (J) := Binder_Options_From_ALI.Table (J); + end loop; + + for J in 1 .. Binder_Options.Last loop + Args (Binder_Options_From_ALI.Last + J) := + Binder_Options.Table (J); end loop; Args (Args'Last) := Binder_Body_Src_File; @@ -1346,6 +1403,7 @@ begin Exit_Program (E_Success); exception - when others => + when X : others => + Write_Line (Exception_Information (X)); Exit_With_Error ("INTERNAL ERROR. Please report."); end Gnatlink; diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index fc5904e9eea..9a2b4c8d470 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -30,21 +30,15 @@ with ALI; use ALI; with ALI.Util; use ALI.Util; with Binderr; use Binderr; with Butil; use Butil; -with Csets; with Fname; use Fname; with Gnatvsn; use Gnatvsn; with GNAT.OS_Lib; use GNAT.OS_Lib; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; +with Osint.L; use Osint.L; with Output; use Output; -with Prj; use Prj; -with Prj.Pars; use Prj.Pars; -with Prj.Env; -with Prj.Ext; use Prj.Ext; -with Prj.Util; use Prj.Util; -with Snames; use Snames; -with Stringt; use Stringt; +with Targparm; use Targparm; with Types; use Types; procedure Gnatls is @@ -66,6 +60,7 @@ procedure Gnatls is Value : String_Access; Next : Dir_Ref; end record; + -- ??? comment needed First_Source_Dir : Dir_Ref; Last_Source_Dir : Dir_Ref; @@ -91,10 +86,6 @@ procedure Gnatls is -- When True, lines are too long for multi-column output and each -- item of information is on a different line. - Project_File : String_Access; - Project : Prj.Project_Id; - Current_Verbosity : Prj.Verbosity := Prj.Default; - Selective_Output : Boolean := False; Print_Usage : Boolean := False; Print_Unit : Boolean := True; @@ -144,10 +135,6 @@ procedure Gnatls is function Corresponding_Sdep_Entry (A : ALI_Id; U : Unit_Id) return Sdep_Id; -- Give the Sdep entry corresponding to the unit U in ali record A. - function Index (Char : Character; Str : String) return Natural; - -- Returns the first occurrence of Char in Str. - -- Returns 0 if Char is not in Str. - procedure Output_Object (O : File_Name_Type); -- Print out the name of the object when requested @@ -246,10 +233,6 @@ procedure Gnatls is Write_Eol; Error_Msg ("wrong ALI format, can't find dependency line for & in %"); Exit_Program (E_Fatal); - - -- Not needed since we exit the program but avoids compiler warning - - raise Program_Error; end Corresponding_Sdep_Entry; ------------------------- @@ -319,10 +302,12 @@ procedure Gnatls is end if; Source_Start := Unit_End + 1; + if Source_Start > Spaces'Last then Source_Start := Spaces'Last; end if; - Source_End := Source_Start - 1; + + Source_End := Source_Start - 1; if Print_Source then Source_End := Source_Start + Max_Src_Length; @@ -370,32 +355,19 @@ procedure Gnatls is end if; end Find_Status; - ----------- - -- Index -- - ----------- - - function Index (Char : Character; Str : String) return Natural is - begin - for Index in Str'Range loop - if Str (Index) = Char then - return Index; - end if; - end loop; - - return 0; - end Index; - ------------------- -- Output_Object -- ------------------- procedure Output_Object (O : File_Name_Type) is Object_Name : String_Access; + begin if Print_Object then Get_Name_String (O); Object_Name := To_Host_File_Spec (Name_Buffer (1 .. Name_Len)); Write_Str (Object_Name.all); + if Print_Source or else Print_Unit then if Too_Long then Write_Eol; @@ -611,104 +583,119 @@ procedure Gnatls is return; end if; - if Argv (1) = Switch_Character or else Argv (1) = '-' then + if Argv (1) = '-' then if Argv'Length = 1 then Fail ("switch character cannot be followed by a blank"); - -- -I- + -- Processing for -I- elsif Argv (2 .. Argv'Last) = "I-" then Opt.Look_In_Primary_Dir := False; - -- Forbid -?- or -??- where ? is any character + -- Forbid -?- or -??- where ? is any character elsif (Argv'Length = 3 and then Argv (3) = '-') or else (Argv'Length = 4 and then Argv (4) = '-') then Fail ("Trailing ""-"" at the end of ", Argv, " forbidden."); - -- -Idir + -- Processing for -Idir elsif Argv (2) = 'I' then Add_Source_Dir (Argv (3 .. Argv'Last), And_Save); Add_Lib_Dir (Argv (3 .. Argv'Last), And_Save); - -- -aIdir (to gcc this is like a -I switch) + -- Processing for -aIdir (to gcc this is like a -I switch) elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aI" then Add_Source_Dir (Argv (4 .. Argv'Last), And_Save); - -- -aOdir + -- Processing for -aOdir elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aO" then Add_Lib_Dir (Argv (4 .. Argv'Last), And_Save); - -- -aLdir (to gnatbind this is like a -aO switch) + -- Processing for -aLdir (to gnatbind this is like a -aO switch) elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aL" then Add_Lib_Dir (Argv (4 .. Argv'Last), And_Save); - -- -vPx - - elsif Argv'Length = 4 and then Argv (2 .. 3) = "vP" then - case Argv (4) is - when '0' => - Current_Verbosity := Prj.Default; - when '1' => - Current_Verbosity := Prj.Medium; - when '2' => - Current_Verbosity := Prj.High; - when others => - null; - end case; - - -- -Pproject_file - - elsif Argv'Length >= 3 and then Argv (2) = 'P' then - if Project_File /= null then - Fail (Argv & ": second project file forbidden (first is """ & - Project_File.all & """)"); - else - Project_File := new String'(Argv (3 .. Argv'Last)); - end if; - - -- -Xexternal=value - - elsif Argv'Length >= 5 and then Argv (2) = 'X' then - declare - Equal_Pos : constant Natural := - Index ('=', Argv (3 .. Argv'Last)); - begin - if Equal_Pos >= 4 and then - Equal_Pos /= Argv'Last then - Add (External_Name => Argv (3 .. Equal_Pos - 1), - Value => Argv (Equal_Pos + 1 .. Argv'Last)); - else - Fail (Argv & " is not a valid external assignment."); - end if; - end; + -- Processing for -nostdinc elsif Argv (2 .. Argv'Last) = "nostdinc" then Opt.No_Stdinc := True; + -- Processing for one character switches + elsif Argv'Length = 2 then case Argv (2) is - when 'a' => Also_Predef := True; - when 'h' => Print_Usage := True; + when 'a' => Also_Predef := True; + when 'h' => Print_Usage := True; when 'u' => Reset_Print; Print_Unit := True; when 's' => Reset_Print; Print_Source := True; when 'o' => Reset_Print; Print_Object := True; - when 'v' => Verbose_Mode := True; - when 'd' => Dependable := True; + when 'v' => Verbose_Mode := True; + when 'd' => Dependable := True; + when others => null; end case; + + -- Processing for --RTS=path + + elsif Argv (1 .. 5) = "--RTS" then + + if Argv (6) /= '=' or else + (Argv (6) = '=' + and then Argv'Length = 6) + then + Osint.Fail ("missing path for --RTS"); + + else + -- Valid --RTS switch + + Opt.No_Stdinc := True; + Opt.RTS_Switch := True; + + declare + Src_Path_Name : String_Ptr := + String_Ptr + (Get_RTS_Search_Dir + (Argv (7 .. Argv'Last), Include)); + Lib_Path_Name : String_Ptr := + String_Ptr + (Get_RTS_Search_Dir + (Argv (7 .. Argv'Last), Objects)); + + begin + if Src_Path_Name /= null + and then Lib_Path_Name /= null + then + Add_Search_Dirs (Src_Path_Name, Include); + Add_Search_Dirs (Lib_Path_Name, Objects); + + elsif Src_Path_Name = null + and then Lib_Path_Name = null + then + Osint.Fail ("RTS path not valid: missing " & + "adainclude and adalib directories"); + + elsif Src_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude directory"); + + elsif Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adalib directory"); + end if; + end; + end if; end if; - -- If not a switch it must be a file name + -- If not a switch, it must be a file name else - Set_Main_File_Name (Argv); + Add_File (Argv); end if; end Scan_Ls_Arg; @@ -717,14 +704,6 @@ procedure Gnatls is ----------- procedure Usage is - procedure Write_Switch_Char; - -- Write two spaces followed by appropriate switch character - - procedure Write_Switch_Char is - begin - Write_Str (" "); - Write_Char (Switch_Character); - end Write_Switch_Char; -- Start of processing for Usage @@ -744,95 +723,71 @@ procedure Gnatls is -- Line for -a - Write_Switch_Char; - Write_Str ("a also output relevant predefined units"); + Write_Str (" -a also output relevant predefined units"); Write_Eol; -- Line for -u - Write_Switch_Char; - Write_Str ("u output only relevant unit names"); + Write_Str (" -u output only relevant unit names"); Write_Eol; -- Line for -h - Write_Switch_Char; - Write_Str ("h output this help message"); + Write_Str (" -h output this help message"); Write_Eol; -- Line for -s - Write_Switch_Char; - Write_Str ("s output only relevant source names"); + Write_Str (" -s output only relevant source names"); Write_Eol; -- Line for -o - Write_Switch_Char; - Write_Str ("o output only relevant object names"); + Write_Str (" -o output only relevant object names"); Write_Eol; -- Line for -d - Write_Switch_Char; - Write_Str ("d output sources on which specified units depend"); + Write_Str (" -d output sources on which specified units depend"); Write_Eol; -- Line for -v - Write_Switch_Char; - Write_Str ("v verbose output, full path and unit information"); + Write_Str (" -v verbose output, full path and unit information"); Write_Eol; Write_Eol; -- Line for -aI switch - Write_Switch_Char; - Write_Str ("aIdir specify source files search path"); + Write_Str (" -aIdir specify source files search path"); Write_Eol; -- Line for -aO switch - Write_Switch_Char; - Write_Str ("aOdir specify object files search path"); + Write_Str (" -aOdir specify object files search path"); Write_Eol; -- Line for -I switch - Write_Switch_Char; - Write_Str ("Idir like -aIdir -aOdir"); + Write_Str (" -Idir like -aIdir -aOdir"); Write_Eol; -- Line for -I- switch - Write_Switch_Char; - Write_Str ("I- do not look for sources & object files"); + Write_Str (" -I- do not look for sources & object files"); Write_Str (" in the default directory"); Write_Eol; - -- Line for -vPx - - Write_Switch_Char; - Write_Str ("vPx verbosity for project file (0, 1 or 2)"); - Write_Eol; - - -- Line for -Pproject_file + -- Line for -nostdinc - Write_Switch_Char; - Write_Str ("Pprj use a project file prj"); + Write_Str (" -nostdinc do not look for source files"); + Write_Str (" in the system default directory"); Write_Eol; - -- Line for -Xexternal=value + -- Line for --RTS - Write_Switch_Char; - Write_Str ("Xext=val specify an external value."); - Write_Eol; - - -- Line for -nostdinc - - Write_Switch_Char; - Write_Str ("nostdinc do not look for source files"); - Write_Str (" in the system default directory"); + Write_Str (" --RTS=dir specify the default source and object search" + & " path"); Write_Eol; -- File Status explanation @@ -854,14 +809,6 @@ procedure Gnatls is -- Start of processing for Gnatls begin - Osint.Initialize (Binder); - - Namet.Initialize; - Csets.Initialize; - - Snames.Initialize; - - Prj.Initialize; -- Use low level argument routines to avoid dragging in the secondary stack @@ -879,88 +826,6 @@ begin Next_Arg := Next_Arg + 1; end loop Scan_Args; - -- If a switch -P is used, parse the project file - - if Project_File /= null then - - Prj.Pars.Set_Verbosity (To => Current_Verbosity); - - Prj.Pars.Parse - (Project => Project, - Project_File_Name => Project_File.all); - - if Project = Prj.No_Project then - Fail ("""" & Project_File.all & """ processing failed"); - end if; - - -- Add the source directories and the object directories - -- to the searched directories. - - declare - procedure Register_Source_Dirs is new - Prj.Env.For_All_Source_Dirs (Add_Src_Search_Dir); - - procedure Register_Object_Dirs is new - Prj.Env.For_All_Object_Dirs (Add_Lib_Search_Dir); - - begin - Register_Source_Dirs (Project); - Register_Object_Dirs (Project); - end; - - -- Check if a package gnatls is in the project file and if there is - -- there is one, get the switches, if any, and scan them. - - declare - Data : Prj.Project_Data := Prj.Projects.Table (Project); - Pkg : Prj.Package_Id := - Prj.Util.Value_Of - (Name => Name_Gnatls, - In_Packages => Data.Decl.Packages); - Element : Package_Element; - Switches : Prj.Variable_Value; - Current : Prj.String_List_Id; - The_String : String_Element; - - begin - if Pkg /= No_Package then - Element := Packages.Table (Pkg); - Switches := - Prj.Util.Value_Of - (Variable_Name => Name_Switches, - In_Variables => Element.Decl.Attributes); - - case Switches.Kind is - when Prj.Undefined => - null; - - when Prj.Single => - if String_Length (Switches.Value) > 0 then - String_To_Name_Buffer (Switches.Value); - Scan_Ls_Arg - (Name_Buffer (1 .. Name_Len), - And_Save => False); - end if; - - when Prj.List => - Current := Switches.Values; - while Current /= Prj.Nil_String loop - The_String := String_Elements.Table (Current); - - if String_Length (The_String.Value) > 0 then - String_To_Name_Buffer (The_String.Value); - Scan_Ls_Arg - (Name_Buffer (1 .. Name_Len), - And_Save => False); - end if; - - Current := The_String.Next; - end loop; - end case; - end if; - end; - end if; - -- Add the source and object directories specified on the -- command line, if any, to the searched directories. @@ -974,11 +839,13 @@ begin First_Lib_Dir := First_Lib_Dir.Next; end loop; - -- Finally, add the default directories. + -- Finally, add the default directories and obtain target parameters Osint.Add_Default_Search_Dirs; if Verbose_Mode then + Namet.Initialize; + Targparm.Get_Target_Parameters; -- WARNING: the output of gnatls -v is used during the compilation -- and installation of GLADE to recreate sdefault.adb and locate @@ -987,8 +854,13 @@ begin Write_Eol; Write_Str ("GNATLS "); + + if Targparm.High_Integrity_Mode_On_Target then + Write_Str ("Pro High Integrity "); + end if; + Write_Str (Gnat_Version_String); - Write_Str (" Copyright 1997-2001 Free Software Foundation, Inc."); + Write_Str (" Copyright 1997-2002 Free Software Foundation, Inc."); Write_Eol; Write_Eol; Write_Str ("Source Search Path:"); @@ -1042,6 +914,7 @@ begin Exit_Program (E_Fatal); end if; + Namet.Initialize; Initialize_ALI; Initialize_ALI_Source; @@ -1131,10 +1004,12 @@ begin if Verbose_Mode then Write_Str (" "); Output_Source (D); + elsif Too_Long then Write_Str (" "); Output_Source (D); Write_Eol; + else Write_Str (Spaces (1 .. Source_Start - 2)); Output_Source (D); diff --git a/gcc/ada/gnatmain.adb b/gcc/ada/gnatmain.adb deleted file mode 100644 index cba6181b64b..00000000000 --- a/gcc/ada/gnatmain.adb +++ /dev/null @@ -1,594 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T M A I N -- --- -- --- B o d y -- --- -- --- $Revision: 1.1 $ --- -- --- 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. -- --- -- --- 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 Csets; -with GNAT.Case_Util; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with Namet; use Namet; -with Opt; -with Osint; use Osint; -with Output; use Output; -with Prj; use Prj; -with Prj.Env; -with Prj.Ext; use Prj.Ext; -with Prj.Pars; -with Prj.Util; use Prj.Util; -with Snames; use Snames; -with Stringt; use Stringt; -with Table; -with Types; use Types; - -procedure Gnatmain is - - Ada_Include_Path : constant String := "ADA_INCLUDE_PATH"; - Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH"; - - type Tool_Type is (None, List, Xref, Find, Stub, Make, Comp, Bind, Link); - - -- The tool that is going to be called - - Tool : Tool_Type := None; - - -- For each tool, Tool_Package_Names contains the name of the - -- corresponding package in the project file. - - Tool_Package_Names : constant array (Tool_Type) of Name_Id := - (None => No_Name, - List => Name_Gnatls, - Xref => Name_Cross_Reference, - Find => Name_Finder, - Stub => Name_Gnatstub, - Comp => No_Name, - Make => No_Name, - Bind => No_Name, - Link => No_Name); - - -- For each tool, Tool_Names contains the name of the executable - -- to be spawned. - - Gnatmake : constant String_Access := new String'("gnatmake"); - - Tool_Names : constant array (Tool_Type) of String_Access := - (None => null, - List => new String'("gnatls"), - Xref => new String'("gnatxref"), - Find => new String'("gnatfind"), - Stub => new String'("gnatstub"), - Comp => Gnatmake, - Make => Gnatmake, - Bind => Gnatmake, - Link => Gnatmake); - - Project_File : String_Access; - Project : Prj.Project_Id; - Current_Verbosity : Prj.Verbosity := Prj.Default; - - -- This flag indicates a switch -p (for gnatxref and gnatfind) for - -- an old fashioned project file. -p cannot be used in conjonction - -- with -P. - - Old_Project_File_Used : Boolean := False; - - Next_Arg : Positive; - - -- A table to keep the switches on the command line - - package Saved_Switches is new Table.Table ( - Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Gnatmain.Saved_Switches"); - - -- A table to keep the switches from the project file - - package Switches is new Table.Table ( - Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Gnatmain.Switches"); - - procedure Add_Switch (Argv : String; And_Save : Boolean); - -- Add a switch in one of the tables above - - procedure Display (Program : String; Args : Argument_List); - -- Displays Program followed by the arguments in Args - - function Index (Char : Character; Str : String) return Natural; - -- Returns the first occurrence of Char in Str. - -- Returns 0 if Char is not in Str. - - procedure Scan_Arg (Argv : String; And_Save : Boolean); - -- Scan and process arguments. Argv is a single argument. - - procedure Usage; - -- Output usage - - ---------------- - -- Add_Switch -- - ---------------- - - procedure Add_Switch (Argv : String; And_Save : Boolean) is - begin - if And_Save then - Saved_Switches.Increment_Last; - Saved_Switches.Table (Saved_Switches.Last) := new String'(Argv); - - else - Switches.Increment_Last; - Switches.Table (Switches.Last) := new String'(Argv); - end if; - end Add_Switch; - - ------------- - -- Display -- - ------------- - - procedure Display (Program : String; Args : Argument_List) is - begin - if not Opt.Quiet_Output then - Write_Str (Program); - - for J in Args'Range loop - Write_Str (" "); - Write_Str (Args (J).all); - end loop; - - Write_Eol; - end if; - end Display; - - ----------- - -- Index -- - ----------- - - function Index (Char : Character; Str : String) return Natural is - begin - for Index in Str'Range loop - if Str (Index) = Char then - return Index; - end if; - end loop; - - return 0; - end Index; - - -------------- - -- Scan_Arg -- - -------------- - - procedure Scan_Arg (Argv : String; And_Save : Boolean) is - begin - pragma Assert (Argv'First = 1); - - if Argv'Length = 0 then - return; - end if; - - if Argv (1) = Switch_Character or else Argv (1) = '-' then - - if Argv'Length = 1 then - Fail ("switch character cannot be followed by a blank"); - end if; - - -- The two style project files (-p and -P) cannot be used together - - if (Tool = Find or else Tool = Xref) - and then Argv (2) = 'p' - then - Old_Project_File_Used := True; - if Project_File /= null then - Fail ("-P and -p cannot be used together"); - end if; - end if; - - -- -q Be quiet: do not output tool command - - if Argv (2 .. Argv'Last) = "q" then - Opt.Quiet_Output := True; - - -- Only gnatstub and gnatmake have a -q switch - - if Tool = Stub or else Tool_Names (Tool) = Gnatmake then - Add_Switch (Argv, And_Save); - end if; - - -- gnatmake will take care of the project file related switches - - elsif Tool_Names (Tool) = Gnatmake then - Add_Switch (Argv, And_Save); - - -- -vPx Specify verbosity while parsing project files - - elsif Argv'Length = 4 and then Argv (2 .. 3) = "vP" then - case Argv (4) is - when '0' => - Current_Verbosity := Prj.Default; - when '1' => - Current_Verbosity := Prj.Medium; - when '2' => - Current_Verbosity := Prj.High; - when others => - null; - end case; - - -- -Pproject_file Specify project file to be used - - elsif Argv'Length >= 3 and then Argv (2) = 'P' then - - -- Only one -P switch can be used - - if Project_File /= null then - Fail (Argv & ": second project file forbidden (first is """ & - Project_File.all & """)"); - - -- The two style project files (-p and -P) cannot be used together - - elsif Old_Project_File_Used then - Fail ("-p and -P cannot be used together"); - - else - Project_File := new String'(Argv (3 .. Argv'Last)); - end if; - - -- -Xexternal=value Specify an external reference to be used - -- in project files - - elsif Argv'Length >= 5 and then Argv (2) = 'X' then - declare - Equal_Pos : constant Natural := - Index ('=', Argv (3 .. Argv'Last)); - begin - if Equal_Pos >= 4 and then - Equal_Pos /= Argv'Last then - Add (External_Name => Argv (3 .. Equal_Pos - 1), - Value => Argv (Equal_Pos + 1 .. Argv'Last)); - else - Fail (Argv & " is not a valid external assignment."); - end if; - end; - - else - Add_Switch (Argv, And_Save); - end if; - - else - Add_Switch (Argv, And_Save); - end if; - - end Scan_Arg; - - ----------- - -- Usage -- - ----------- - - procedure Usage is - begin - Write_Str ("Usage: "); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" list switches [list of object files]"); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" xref switches file1 file2 ..."); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" find switches pattern[:sourcefile[:line[:column]]] " & - "[file1 file2 ...]"); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" stub switches filename [directory]"); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" comp switches files"); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" make switches [files]"); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" bind switches files"); - Write_Eol; - - Osint.Write_Program_Name; - Write_Str (" link switches files"); - Write_Eol; - - Write_Eol; - - Write_Str ("switches interpreted by "); - Osint.Write_Program_Name; - Write_Str (" for List Xref and Find:"); - Write_Eol; - - Write_Str (" -q Be quiet: do not output tool command"); - Write_Eol; - - Write_Str (" -Pproj Use GNAT Project File proj"); - Write_Eol; - - Write_Str (" -vPx Specify verbosity when parsing " & - "GNAT Project Files"); - Write_Eol; - - Write_Str (" -Xnm=val Specify an external reference for " & - "GNAT Project Files"); - Write_Eol; - - Write_Eol; - - Write_Str ("all other arguments are transmited to the tool"); - Write_Eol; - - Write_Eol; - - end Usage; - -begin - - Osint.Initialize (Unspecified); - - Namet.Initialize; - Csets.Initialize; - - Snames.Initialize; - - Prj.Initialize; - - if Arg_Count = 1 then - Usage; - return; - end if; - - -- Get the name of the tool - - declare - Tool_Name : String (1 .. Len_Arg (1)); - - begin - Fill_Arg (Tool_Name'Address, 1); - GNAT.Case_Util.To_Lower (Tool_Name); - - if Tool_Name = "list" then - Tool := List; - - elsif Tool_Name = "xref" then - Tool := Xref; - - elsif Tool_Name = "find" then - Tool := Find; - - elsif Tool_Name = "stub" then - Tool := Stub; - - elsif Tool_Name = "comp" then - Tool := Comp; - - elsif Tool_Name = "make" then - Tool := Make; - - elsif Tool_Name = "bind" then - Tool := Bind; - - elsif Tool_Name = "link" then - Tool := Link; - - else - Fail ("first argument needs to be ""list"", ""xref"", ""find""" & - ", ""stub"", ""comp"", ""make"", ""bind"" or ""link"""); - end if; - end; - - Next_Arg := 2; - - -- Get the command line switches that follow the name of the tool - - Scan_Args : while Next_Arg < Arg_Count loop - declare - Next_Argv : String (1 .. Len_Arg (Next_Arg)); - - begin - Fill_Arg (Next_Argv'Address, Next_Arg); - Scan_Arg (Next_Argv, And_Save => True); - end; - - Next_Arg := Next_Arg + 1; - end loop Scan_Args; - - -- If a switch -P was specified, parse the project file. - -- Project_File is always null if we are going to invoke gnatmake, - -- that is when Tool is Comp, Make, Bind or Link. - - if Project_File /= null then - - Prj.Pars.Set_Verbosity (To => Current_Verbosity); - - Prj.Pars.Parse - (Project => Project, - Project_File_Name => Project_File.all); - - if Project = Prj.No_Project then - Fail ("""" & Project_File.all & """ processing failed"); - end if; - - -- Check if a package with the name of the tool is in the project file - -- and if there is one, get the switches, if any, and scan them. - - declare - Data : Prj.Project_Data := Prj.Projects.Table (Project); - Pkg : Prj.Package_Id := - Prj.Util.Value_Of - (Name => Tool_Package_Names (Tool), - In_Packages => Data.Decl.Packages); - Element : Package_Element; - Default_Switches_Array : Array_Element_Id; - Switches : Prj.Variable_Value; - Current : Prj.String_List_Id; - The_String : String_Element; - - begin - if Pkg /= No_Package then - Element := Packages.Table (Pkg); - - -- Packages Gnatls and Gnatstub have a single attribute Switches, - -- that is not an associative array. - - if Tool = List or else Tool = Stub then - Switches := - Prj.Util.Value_Of - (Variable_Name => Name_Switches, - In_Variables => Element.Decl.Attributes); - - -- Packages Cross_Reference (for gnatxref) and Finder - -- (for gnatfind) have an attributed Default_Switches, - -- an associative array, indexed by the name of the - -- programming language. - else - Default_Switches_Array := - Prj.Util.Value_Of - (Name => Name_Default_Switches, - In_Arrays => Packages.Table (Pkg).Decl.Arrays); - Switches := Prj.Util.Value_Of - (Index => Name_Ada, - In_Array => Default_Switches_Array); - - end if; - - -- If there are switches specified in the package of the - -- project file corresponding to the tool, scan them. - - case Switches.Kind is - when Prj.Undefined => - null; - - when Prj.Single => - if String_Length (Switches.Value) > 0 then - String_To_Name_Buffer (Switches.Value); - Scan_Arg - (Name_Buffer (1 .. Name_Len), - And_Save => False); - end if; - - when Prj.List => - Current := Switches.Values; - while Current /= Prj.Nil_String loop - The_String := String_Elements.Table (Current); - - if String_Length (The_String.Value) > 0 then - String_To_Name_Buffer (The_String.Value); - Scan_Arg - (Name_Buffer (1 .. Name_Len), - And_Save => False); - end if; - - Current := The_String.Next; - end loop; - end case; - end if; - end; - - -- Set up the environment variables ADA_INCLUDE_PATH and - -- ADA_OBJECTS_PATH. - - Setenv - (Name => Ada_Include_Path, - Value => Prj.Env.Ada_Include_Path (Project).all); - Setenv - (Name => Ada_Objects_Path, - Value => Prj.Env.Ada_Objects_Path - (Project, Including_Libraries => False).all); - - end if; - - -- Gather all the arguments, those from the project file first, - -- locate the tool and call it with the arguments. - - declare - Args : Argument_List (1 .. Switches.Last + Saved_Switches.Last + 4); - Arg_Num : Natural := 0; - Tool_Path : String_Access; - Success : Boolean; - - procedure Add (Arg : String_Access); - - procedure Add (Arg : String_Access) is - begin - Arg_Num := Arg_Num + 1; - Args (Arg_Num) := Arg; - end Add; - - begin - - case Tool is - when Comp => - Add (new String'("-u")); - Add (new String'("-f")); - - when Bind => - Add (new String'("-b")); - - when Link => - Add (new String'("-l")); - - when others => - null; - - end case; - - for Index in 1 .. Switches.Last loop - Arg_Num := Arg_Num + 1; - Args (Arg_Num) := Switches.Table (Index); - end loop; - - for Index in 1 .. Saved_Switches.Last loop - Arg_Num := Arg_Num + 1; - Args (Arg_Num) := Saved_Switches.Table (Index); - end loop; - - Tool_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Tool_Names (Tool).all); - - if Tool_Path = null then - Fail ("error, unable to locate " & Tool_Names (Tool).all); - end if; - - Display (Tool_Names (Tool).all, Args (1 .. Arg_Num)); - - GNAT.OS_Lib.Spawn (Tool_Path.all, Args (1 .. Arg_Num), Success); - - end; - -end Gnatmain; diff --git a/gcc/ada/gnatmem.adb b/gcc/ada/gnatmem.adb index c4c91244884..c6a99ae7189 100644 --- a/gcc/ada/gnatmem.adb +++ b/gcc/ada/gnatmem.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- --- Copyright (C) 1997-2001, Ada Core Technologies, Inc. -- +-- Copyright (C) 1997-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- -- @@ -328,8 +328,8 @@ procedure Gnatmem is Put_Line (FD, " silent"); Put_Line (FD, " set lang c"); Put_Line (FD, " set print address on"); - Put_Line (FD, " finish"); - Put_Line (FD, " set $gm_addr = $"); + Put_Line (FD, " up"); + Put_Line (FD, " set $gm_addr = $pc"); Put_Line (FD, " printf ""\n\n"""); Put_Line (FD, " printf ""ALLOC^0x%x^\n"", $gm_addr"); Put_Line (FD, " set print address off"); @@ -341,8 +341,8 @@ procedure Gnatmem is Put_Line (FD, " set lang c"); Put_Line (FD, " set $gm_size = size"); Put_Line (FD, " set print address on"); - Put_Line (FD, " finish"); - Put_Line (FD, " set $gm_addr = $"); + Put_Line (FD, " up"); + Put_Line (FD, " set $gm_addr = $pc"); Put_Line (FD, " printf ""\n\n"""); Put_Line (FD, " printf ""ALLOC^%d^0x%x^\n"", $gm_size, $gm_addr"); Put_Line (FD, " set print address off"); @@ -352,7 +352,7 @@ procedure Gnatmem is Put (FD, " backtrace"); if BT_Depth /= 0 then - Put (FD, Integer'Image (BT_Depth)); + Put (FD, Integer'Image (BT_Depth + 1)); end if; New_Line (FD); @@ -369,12 +369,12 @@ procedure Gnatmem is Put_Line (FD, " printf ""\n\n"""); Put_Line (FD, " printf ""DEALL^0x%x^\n"", ptr"); Put_Line (FD, " set print address off"); - Put_Line (FD, " finish"); + Put_Line (FD, " up"); Put (FD, " backtrace"); if BT_Depth /= 0 then - Put (FD, Integer'Image (BT_Depth)); + Put (FD, Integer'Image (BT_Depth + 1)); end if; New_Line (FD); @@ -434,7 +434,7 @@ procedure Gnatmem is New_Line; Put ("GNATMEM "); Put (Gnat_Version_String); - Put_Line (" Copyright 1997-2000 Free Software Foundation, Inc."); + Put_Line (" Copyright 1997-2002 Free Software Foundation, Inc."); New_Line; if Cross_Case then diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb new file mode 100644 index 00000000000..4dc3364db3d --- /dev/null +++ b/gcc/ada/gnatname.adb @@ -0,0 +1,337 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T N A M E -- +-- -- +-- B o d y -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 2001-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. -- +-- -- +-- 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 Gnatvsn; +with Opt; +with Osint; use Osint; +with Output; use Output; +with Prj.Makr; +with Table; + +with Ada.Text_IO; use Ada.Text_IO; +with GNAT.Command_Line; use GNAT.Command_Line; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +procedure Gnatname is + + Usage_Output : Boolean := False; + -- Set to True when usage is output, to avoid multiple output + + Usage_Needed : Boolean := False; + -- Set to True by -h switch + + Version_Output : Boolean := False; + -- Set to True when version is output, to avoid multiple output + + Very_Verbose : Boolean := False; + -- Set to True with -v -v + + Create_Project : Boolean := False; + -- Set to True with a -P switch + + File_Path : String_Access := new String'("gnat.adc"); + -- Path name of the file specified by -c or -P switch + + File_Set : Boolean := False; + -- Set to True by -c or -P switch. + -- Used to detect multiple -c/-P switches. + + package Excluded_Patterns is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 10, + Table_Name => "Gnatname.Excluded_Patterns"); + -- Table to accumulate the negative patterns. + + package Patterns is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 10, + Table_Name => "Gnatname.Patterns"); + -- Table to accumulate the name patterns. + + package Source_Directories is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 10, + Table_Name => "Gnatname.Source_Directories"); + -- Table to accumulate the source directories specified directly with -d + -- or indirectly with -D. + + procedure Output_Version; + -- Print name and version + + procedure Usage; + -- Print usage + + procedure Scan_Args; + -- Scan the command line arguments + + procedure Add_Source_Directory (S : String); + -- Add S in the Source_Directories table + + procedure Get_Directories (From_File : String); + -- Read a source directory text file + + -------------------------- + -- Add_Source_Directory -- + -------------------------- + + procedure Add_Source_Directory (S : String) is + begin + Source_Directories.Increment_Last; + Source_Directories.Table (Source_Directories.Last) := new String'(S); + end Add_Source_Directory; + + --------------------- + -- Get_Directories -- + --------------------- + + procedure Get_Directories (From_File : String) is + File : Ada.Text_IO.File_Type; + Line : String (1 .. 2_000); + Last : Natural; + + begin + Open (File, In_File, From_File); + + while not End_Of_File (File) loop + Get_Line (File, Line, Last); + + if Last /= 0 then + Add_Source_Directory (Line (1 .. Last)); + end if; + end loop; + + Close (File); + + exception + when Name_Error => + Fail ("cannot open source directory """ & From_File & '"'); + end Get_Directories; + + -------------------- + -- Output_Version -- + -------------------- + + procedure Output_Version is + begin + if not Version_Output then + Version_Output := True; + Output.Write_Eol; + Output.Write_Str ("GNATNAME "); + Output.Write_Str (Gnatvsn.Gnat_Version_String); + Output.Write_Line + (" Copyright 2001-2002 Free Software Foundation, Inc."); + end if; + end Output_Version; + + --------------- + -- Scan_Args -- + --------------- + + procedure Scan_Args is + begin + Initialize_Option_Scan; + + -- Scan options first + + loop + case Getopt ("c: d: D: h P: v x:") is + when ASCII.NUL => + exit; + + when 'c' => + if File_Set then + Fail ("only one -P or -c switch may be specified"); + end if; + + File_Set := True; + File_Path := new String'(Parameter); + Create_Project := False; + + when 'd' => + Add_Source_Directory (Parameter); + + when 'D' => + Get_Directories (Parameter); + + when 'h' => + Usage_Needed := True; + + when 'P' => + if File_Set then + Fail ("only one -c or -P switch may be specified"); + end if; + + File_Set := True; + File_Path := new String'(Parameter); + Create_Project := True; + + when 'v' => + if Opt.Verbose_Mode then + Very_Verbose := True; + + else + Opt.Verbose_Mode := True; + end if; + + when 'x' => + Excluded_Patterns.Increment_Last; + Excluded_Patterns.Table (Excluded_Patterns.Last) := + new String'(Parameter); + + when others => + null; + end case; + end loop; + + -- Now, get the name patterns, if any + + loop + declare + S : constant String := Get_Argument (Do_Expansion => False); + + begin + exit when S = ""; + Patterns.Increment_Last; + Patterns.Table (Patterns.Last) := new String'(S); + end; + end loop; + + exception + when Invalid_Switch => + Fail ("invalid switch " & Full_Switch); + + end Scan_Args; + + ----------- + -- Usage -- + ----------- + + procedure Usage is + begin + if not Usage_Output then + Usage_Needed := False; + Usage_Output := True; + Write_Str ("Usage: "); + Osint.Write_Program_Name; + Write_Line (" [switches] naming-pattern [naming-patterns]"); + Write_Eol; + Write_Line ("switches:"); + + Write_Line (" -cfile create configuration pragmas file"); + Write_Line (" -ddir use dir as one of the source directories"); + Write_Line (" -Dfile get source directories from file"); + Write_Line (" -h output this help message"); + Write_Line (" -Pproj update or create project file proj"); + Write_Line (" -v verbose output"); + Write_Line (" -v -v very verbose output"); + Write_Line (" -xpat exclude pattern pat"); + end if; + end Usage; + +-- Start of processing for Gnatname + +begin + -- Initialize tables + + Excluded_Patterns.Set_Last (0); + Patterns.Set_Last (0); + Source_Directories.Set_Last (0); + + -- Get the arguments + + Scan_Args; + + if Opt.Verbose_Mode then + Output_Version; + end if; + + if Usage_Needed then + Usage; + end if; + + -- If no pattern was specified, print the usage and return + + if Patterns.Last = 0 then + Usage; + return; + end if; + + -- If no source directory was specified, use the current directory as the + -- unique directory. Note that if a file was specified with directory + -- information, the current directory is the directory of the specified + -- file. + + if Source_Directories.Last = 0 then + Source_Directories.Increment_Last; + Source_Directories.Table (Source_Directories.Last) := new String'("."); + end if; + + declare + Directories : Argument_List (1 .. Integer (Source_Directories.Last)); + Name_Patterns : Argument_List (1 .. Integer (Patterns.Last)); + Excl_Patterns : Argument_List (1 .. Integer (Excluded_Patterns.Last)); + + begin + -- Build the Directories and Name_Patterns arguments + + for Index in Directories'Range loop + Directories (Index) := Source_Directories.Table (Index); + end loop; + + for Index in Name_Patterns'Range loop + Name_Patterns (Index) := Patterns.Table (Index); + end loop; + + for Index in Excl_Patterns'Range loop + Excl_Patterns (Index) := Excluded_Patterns.Table (Index); + end loop; + + -- Call Prj.Makr.Make where the real work is done + + Prj.Makr.Make + (File_Path => File_Path.all, + Project_File => Create_Project, + Directories => Directories, + Name_Patterns => Name_Patterns, + Excluded_Patterns => Excl_Patterns, + Very_Verbose => Very_Verbose); + end; + + if Opt.Verbose_Mode then + Write_Eol; + end if; +end Gnatname; diff --git a/gcc/ada/gnatmain.ads b/gcc/ada/gnatname.ads index 5f81d8f9c1f..373c8e72a9d 100644 --- a/gcc/ada/gnatmain.ads +++ b/gcc/ada/gnatname.ads @@ -2,13 +2,13 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- G N A T M A I N -- +-- G N A T N A M E -- -- -- -- S p e c -- -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 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- -- @@ -26,13 +26,8 @@ -- -- ------------------------------------------------------------------------------ --- This procedure is the project-aware driver for the GNAT tools. --- For gnatls, gnatxref, gnatfind and gnatstub, it setup the environment --- variables ADA_INCLUDE_PATH and ADA_OBJECT_PATH and gather the switches --- and file names from the project file (if any) and from the common line, --- then call the non project-aware tool (gnatls, gnatxref, gnatfind or --- gnatstub). --- For other tools (compiler, binder, linker, gnatmake), it invokes --- gnatmake with the proper switches. +-- Tool for dealing with source files with arbitrary naming conventions. +-- It either creates a configuration pragmas file, or updates or creates +-- a project file. -procedure Gnatmain; +procedure Gnatname; diff --git a/gcc/ada/gnatprep.adb b/gcc/ada/gnatprep.adb index ccff6fc4a3c..23400dac90a 100644 --- a/gcc/ada/gnatprep.adb +++ b/gcc/ada/gnatprep.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.27 $ +-- $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- -- @@ -39,8 +39,6 @@ with Gnatvsn; procedure GNATprep is pragma Ident (Gnatvsn.Gnat_Version_String); - Version_String : constant String := "$Revision: 1.27 $"; - type Strptr is access String; Usage_Error : exception; @@ -58,12 +56,23 @@ procedure GNATprep is -- Argument Line Data -- ------------------------ - Infile_Name : Strptr; Outfile_Name : Strptr; Deffile_Name : Strptr; -- Names of files - Infile : File_Type; + type Input; + type Input_Ptr is access Input; + type Input is record + File : File_Type; + Next : Input_Ptr; + Prev : Input_Ptr; + Name : Strptr; + Line_Num : Natural := 0; + end record; + -- Data for the current input file (main input file or included file + -- or definition file). + + Infile : Input_Ptr := new Input; Outfile : File_Type; Deffile : File_Type; @@ -100,15 +109,13 @@ procedure GNATprep is Line_Length : Natural; -- Length of line in Line_Buffer - Line_Num : Natural; - -- Current input file line number - Ptr : Natural; -- Input scan pointer for line in Line_Buffer type Keyword is (K_Not, K_Then, K_If, K_Else, K_End, K_Elsif, K_And, K_Or, K_Open_Paren, K_Close_Paren, - K_Defined, K_Andthen, K_Orelse, K_Equal, K_None); + K_Defined, K_Andthen, K_Orelse, K_Equal, K_Include, + K_None); -- Keywords that are recognized on preprocessor lines. K_None indicates -- that no keyword was present. @@ -131,6 +138,9 @@ procedure GNATprep is If_Line : Positive; -- Line number for #if line + If_Name : Strptr; + -- File name of #if line + Else_Line : Natural; -- Line number for #else line, zero = no else seen yet @@ -141,6 +151,7 @@ procedure GNATprep is -- True if either the #if condition or one of the previously seen -- #elsif lines was true, meaning that any future #elsif sections -- or the #else section, is to be deleted. + end record; PP_Depth : Natural; @@ -162,7 +173,7 @@ procedure GNATprep is procedure Error (Msg : String); -- Post error message with given text. The line number is taken from - -- Line_Num, and the column number from Ptr. + -- Infile.Line_Num, and the column number from Ptr. function Eval_Condition (Parenthesis : Natural := 0; @@ -184,6 +195,9 @@ procedure GNATprep is procedure Help_Page; -- Print a help page to summarize the usage of gnatprep + function Image (N : Natural) return String; + -- Returns Natural'Image (N) without the initial space + function Is_Preprocessor_Line return Boolean; -- Tests if current line is a preprocessor line, i.e. that its first -- non-blank character is a # character. If so, then a result of True @@ -244,7 +258,7 @@ procedure GNATprep is ----------- procedure Error (Msg : String) is - L : constant String := Natural'Image (Line_Num); + L : constant String := Natural'Image (Infile.Line_Num); C : constant String := Natural'Image (Ptr); begin @@ -419,6 +433,7 @@ procedure GNATprep is when K_Equal => -- Read the second part of the statement + Skip_Spaces; Start_Sym := Ptr; @@ -510,9 +525,9 @@ procedure GNATprep is procedure Help_Page is begin Put_Line (Standard_Error, - "GNAT Preprocessor Version " & - Version_String (12 .. 15) & - " Copyright 1996-2001 Free Software Foundation, Inc."); + "GNAT Preprocessor " & + Gnatvsn.Gnat_Version_String & + " Copyright 1996-2002 Free Software Foundation, Inc."); Put_Line (Standard_Error, "Usage: gnatprep [-bcrsu] [-Dsymbol=value] infile " & "outfile [deffile]"); @@ -533,6 +548,16 @@ procedure GNATprep is New_Line (Standard_Error); end Help_Page; + ----------- + -- Image -- + ----------- + + function Image (N : Natural) return String is + Result : constant String := Natural'Image (N); + begin + return Result (Result'First + 1 .. Result'Last); + end Image; + -------------------------- -- Is_Preprocessor_Line -- -------------------------- @@ -654,14 +679,16 @@ procedure GNATprep is begin Open (Deffile, In_File, Deffile_Name.all); - Line_Num := 0; + -- Initialize data for procedure Error + + Infile.Line_Num := 0; Current_File_Name := Deffile_Name; -- Loop through lines in symbol definitions file while not End_Of_File (Deffile) loop Get_Line (Deffile, Line_Buffer, Line_Length); - Line_Num := Line_Num + 1; + Infile.Line_Num := Infile.Line_Num + 1; Ptr := 1; Skip_Spaces; @@ -826,6 +853,9 @@ procedure GNATprep is elsif Matching_Strings (Sym, "'defined") then return K_Defined; + elsif Matching_Strings (Sym, "include") then + return K_Include; + elsif Sym = "(" then return K_Open_Paren; @@ -991,8 +1021,8 @@ begin begin exit when S'Length = 0; - if Infile_Name = null then - Infile_Name := new String'(S); + if Infile.Name = null then + Infile.Name := new String'(S); elsif Outfile_Name = null then Outfile_Name := new String'(S); elsif Deffile_Name = null then @@ -1005,7 +1035,7 @@ begin -- Test we had all the arguments needed - if Infile_Name = null + if Infile.Name = null or else Outfile_Name = null then raise Usage_Error; @@ -1111,11 +1141,11 @@ begin -- Open files and initialize preprocessing begin - Open (Infile, In_File, Infile_Name.all); + Open (Infile.File, In_File, Infile.Name.all); exception when Name_Error => - Put_Line (Standard_Error, "cannot open " & Infile_Name.all); + Put_Line (Standard_Error, "cannot open " & Infile.Name.all); raise Fatal_Error; end; @@ -1128,22 +1158,34 @@ begin raise Fatal_Error; end; - if Source_Ref_Pragma then - Put_Line - (Outfile, "pragma Source_Reference (1, """ & Infile_Name.all & """);"); - end if; - - Line_Num := 0; - Current_File_Name := Infile_Name; + Infile.Line_Num := 0; + Current_File_Name := Infile.Name; PP_Depth := 0; PP (0).Deleting := False; + -- We return here after we start reading an include file and after + -- we have finished reading an include file. + + <<Read_In_File>> + + -- If we generate Source_Reference pragmas, then generate one + -- either with line number 1 for a newly included file, or + -- with the number of the next line when we have returned to the + -- including file. + + if Source_Ref_Pragma then + Put_Line + (Outfile, "pragma Source_Reference (" & + Image (Infile.Line_Num + 1) & + ", """ & Infile.Name.all & """);"); + end if; + -- Loop through lines in input file - while not End_Of_File (Infile) loop - Get_Line (Infile, Line_Buffer, Line_Length); - Line_Num := Line_Num + 1; + while not End_Of_File (Infile.File) loop + Get_Line (Infile.File, Line_Buffer, Line_Length); + Infile.Line_Num := Infile.Line_Num + 1; -- Handle preprocessor line @@ -1152,6 +1194,112 @@ begin case K is + -- Include file + + when K_Include => + -- Ignore if Deleting is True + + if PP (PP_Depth).Deleting then + goto Output; + end if; + + Skip_Spaces; + + if Ptr >= Line_Length then + Error ("no file to include"); + + elsif Line_Buffer (Ptr) /= '"' then + Error + ("file to include must be specified as a literal string"); + + else + declare + Start_File : constant Positive := Ptr + 1; + + begin + Ptr := Line_Length; + + while Line_Buffer (Ptr) = ' ' + or else Line_Buffer (Ptr) = ASCII.HT + loop + Ptr := Ptr - 1; + end loop; + + if Ptr <= Start_File + or else Line_Buffer (Ptr) /= '"' + then + Error ("no string literal for included file"); + + else + if Infile.Next = null then + Infile.Next := new Input; + Infile.Next.Prev := Infile; + end if; + + Infile := Infile.Next; + Infile.Name := + new String'(Line_Buffer (Start_File .. Ptr - 1)); + + -- Check for circularity: an file including itself, + -- either directly or indirectly. + + declare + File : Input_Ptr := Infile.Prev; + + begin + while File /= null + and then File.Name.all /= Infile.Name.all + loop + File := File.Prev; + end loop; + + if File /= null then + Infile := Infile.Prev; + Error ("circularity in included files"); + + while File.Prev /= null loop + File := File.Prev; + end loop; + + while File /= Infile.Next loop + Error ('"' & File.Name.all & + """ includes """ & + File.Next.Name.all & '"'); + File := File.Next; + end loop; + + else + -- We have a file name and no circularity. + -- Open the file and record an error if the + -- file cannot be opened. + + begin + Open (Infile.File, In_File, Infile.Name.all); + Current_File_Name := Infile.Name; + Infile.Line_Num := 0; + + -- If we use Source_Reference pragma, + -- we need to output one for this new file. + goto Read_In_File; + + exception + when Name_Error => + + -- We need to set the input file to + -- the including file, so that the + -- line number is correct when reporting + -- the error. + + Infile := Infile.Prev; + Error ("cannot open """ & + Infile.Next.Name.all & '"'); + end; + end if; + end; + end if; + end; + end if; + -- If/Elsif processing when K_If | K_Elsif => @@ -1165,7 +1313,8 @@ begin if K = K_If then PP_Depth := PP_Depth + 1; PP (PP_Depth) := - (If_Line => Line_Num, + (If_Line => Infile.Line_Num, + If_Name => Infile.Name, Else_Line => 0, Deleting => False, Match_Seen => PP (PP_Depth - 1).Deleting); @@ -1202,7 +1351,7 @@ begin ")"); else - PP (PP_Depth).Else_Line := Line_Num; + PP (PP_Depth).Else_Line := Infile.Line_Num; PP (PP_Depth).Deleting := PP (PP_Depth).Match_Seen; end if; @@ -1356,9 +1505,25 @@ begin end if; end loop; + -- If we have finished reading an included file, close it and continue + -- with the next line of the including file. + + if Infile.Prev /= null then + Close (Infile.File); + Infile := Infile.Prev; + Current_File_Name := Infile.Name; + goto Read_In_File; + end if; + for J in 1 .. PP_Depth loop - Error ("no matching #end for #if at line" & - Natural'Image (PP (J).If_Line)); + if PP (J).If_Name = Infile.Name then + Error ("no matching #end for #if at line" & + Natural'Image (PP (J).If_Line)); + else + Error ("no matching #end for #if at line" & + Natural'Image (PP (J).If_Line) & + " of file """ & PP (J).If_Name.all & '"'); + end if; end loop; if Num_Errors = 0 then diff --git a/gcc/ada/gnatpsys.adb b/gcc/ada/gnatpsys.adb deleted file mode 100644 index 9e65c2a2537..00000000000 --- a/gcc/ada/gnatpsys.adb +++ /dev/null @@ -1,171 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT SYSTEM UTILITIES -- --- -- --- G N A T P S Y S -- --- -- --- B o d y -- --- -- --- $Revision: 1.3 $ -- --- -- --- Copyright (C) 1997 Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- 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). -- --- -- ------------------------------------------------------------------------------- - --- Program to print out listing of System package with all constants --- appearing explicitly. - -with Ada.Text_IO; -with System; use System; -with Gnatvsn; - -procedure GnatPsys is - pragma Ident (Gnatvsn.Gnat_Version_String); - - procedure P (Item : String) renames Ada.Text_IO.Put_Line; - -begin - P ("package System is"); - - P ("pragma Pure (System);"); - - P (""); - - P (" type Name is (SYSTEM_NAME_GNAT);"); - - P (" System_Name : constant Name := SYSTEM_NAME_GNAT;"); - - P (""); - - P (" -- System-Dependent Named Numbers"); - - P (""); - - P (" Min_Int : constant := -(2 **" & - Long_Long_Integer'Image (Long_Long_Integer'Size - 1) & ");"); - - P (" Max_Int : constant := 2 **" & - Long_Long_Integer'Image (Long_Long_Integer'Size - 1) & " - 1;"); - - P (""); - - P (" Max_Binary_Modulus : constant := 2 **" & - Long_Long_Integer'Image (Long_Long_Integer'Size) & ";"); - - P (" Max_Nonbinary_Modulus : constant :=" & - Integer'Image (Integer'Last) & ";"); - - P (""); - - P (" Max_Base_Digits : constant :=" & - Natural'Image (Long_Long_Float'Digits) & ";"); - - P (" Max_Digits : constant :=" & - Natural'Image (Long_Long_Float'Digits) & ";"); - - P (""); - - P (" Max_Mantissa : constant := 63;"); - - P (" Fine_Delta : constant := 2.0 ** (-Max_Mantissa);"); - - P (""); - - P (" Tick : constant :=" & - Duration'Image (Duration (Standard'Tick)) & ";"); - - P (""); - - P (" -- Storage-related Declarations"); - - P (""); - - P (" type Address is private;"); - - P (" Null_Address : constant Address;"); - - P (""); - - P (" Storage_Unit : constant :=" & - Natural'Image (Standard'Storage_Unit) & ";"); - - P (" Word_Size : constant :=" & - Natural'Image (Standard'Word_Size) & ";"); - - P (" Memory_Size : constant := 2 **" & - Natural'Image (Standard'Address_Size) & ";"); - - P (""); - P (" -- Address comparison"); - P (""); - P (" function ""<"" (Left, Right : Address) return Boolean;"); - P (" function ""<="" (Left, Right : Address) return Boolean;"); - P (" function "">"" (Left, Right : Address) return Boolean;"); - P (" function "">="" (Left, Right : Address) return Boolean;"); - P (" function ""="" (Left, Right : Address) return Boolean;"); - P (""); - P (" pragma Import (Intrinsic, ""<""); "); - P (" pragma Import (Intrinsic, ""<="");"); - P (" pragma Import (Intrinsic, "">""); "); - P (" pragma Import (Intrinsic, "">="");"); - P (" pragma Import (Intrinsic, ""=""); "); - P (""); - P (" -- Other System-Dependent Declarations"); - P (""); - P (" type Bit_Order is (High_Order_First, Low_Order_First);"); - P (" Default_Bit_Order : constant Bit_Order;"); - P (""); - P (" -- Priority-related Declarations (RM D.1)"); - P (""); - P (" subtype Any_Priority is Integer range 0 .." & - Natural'Image (Standard'Max_Interrupt_Priority) & ";"); - - P (""); - - P (" subtype Priority is Any_Priority range 0 .." & - Natural'Image (Standard'Max_Priority) & ";"); - - P (""); - - P (" subtype Interrupt_Priority is Any_Priority range" & - Natural'Image (Standard'Max_Priority + 1) & " .." & - Natural'Image (Standard'Max_Interrupt_Priority) & ";"); - - P (""); - - P (" Default_Priority : constant Priority :=" & - Natural'Image ((Priority'First + Priority'Last) / 2) & ";"); - - P (""); - - P ("private"); - - P (""); - - P (" type Address is mod Memory_Size; "); - - P (" Null_Address : constant Address := 0; "); - - P (" "); - - P (" Default_Bit_Order : constant Bit_Order := " & - Bit_Order'Image (Bit_Order'Val (Standard'Default_Bit_Order)) & ";"); - - P (""); - - P ("end System;"); -end GnatPsys; diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads index 9287832366c..36a95c5dc00 100644 --- a/gcc/ada/gnatvsn.ads +++ b/gcc/ada/gnatvsn.ads @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -38,14 +38,41 @@ package Gnatvsn is - Gnat_Version_String : constant String := "5.00w (20010924)"; + Gnat_Version_String : constant String := "3.1 (20020212)"; -- Version output when GNAT (compiler), or its related tools, including -- GNATBIND, GNATCHOP, GNATFIND, GNATLINK, GNATMAKE, GNATXREF, are run -- (with appropriate verbose option switch set). -- - -- WARNING: some gnatmail scripts (at least make-bin and corcs) rely on - -- the format of this string. Any change must be coordinated with - -- a gnatmail maintainer. + -- WARNING: some scripts rely on the format of this string. Any change + -- must be coordinated with a script maintainer. Furthermore, no + -- other variable in this package may have a name starting with + -- Gnat_Version_String. + + Gnat_Version_Type : constant String := "FSF "; + -- This string is set to one of three values: + -- + -- "FSF " + -- GNAT FSF version. This version of GNAT is part of a Free Software + -- Foundation release of the GNU Compiler Collection (GCC). The binder + -- will not output informational messages regarding intended use. + -- and the bug box generated by Comperr will give information on + -- how to report bugs and list the "no warranty" information. + -- + -- "GNATPRO" + -- GNAT Professional version. This version of GNAT is supported + -- by Ada Core Technologies. The binder will not output the + -- usual "no warranty" messages, and the bug box generated by + -- package Comperr will give instructions on bug submission + -- that include references to customer number, ftp site etc. + -- + -- "PUBLIC " + -- GNAT Public version. This is a public version of GNAT, released + -- by Ada Core Technologies and intended for educational use. + -- The binder will output informational messages, and the bug box + -- generated by the package Comperr will give appropriate bug + -- submission instructions that do not reference customer number etc. + -- + -- These are the only allowable settings for this string Ver_Len_Max : constant := 32; -- Longest possible length for Gnat_Version_String in this or any @@ -54,7 +81,7 @@ package Gnatvsn is -- value should never be decreased in the future, but it would be -- OK to increase it if absolutely necessary. - Library_Version : constant String := "GNAT Lib v3.15a"; + Library_Version : constant String := "GNAT Lib v3.15"; -- Library version. This value must be updated whenever any change to the -- compiler affects the library formats in such a way as to obsolete -- previously compiled library modules. diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb index 6e44ddcdde7..f930de6c97c 100644 --- a/gcc/ada/gnatxref.adb +++ b/gcc/ada/gnatxref.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.21 $ +-- $Revision$ -- -- --- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -25,13 +25,17 @@ -- -- ------------------------------------------------------------------------------ -with Xr_Tabls; -with Xref_Lib; use Xref_Lib; -with Ada.Text_IO; -with Ada.Strings.Fixed; -with GNAT.Command_Line; +with Xr_Tabls; use Xr_Tabls; +with Xref_Lib; use Xref_Lib; +with Osint; use Osint; +with Types; use Types; + with Gnatvsn; -with Osint; +with Opt; + +with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with Ada.Text_IO; use Ada.Text_IO; +with GNAT.Command_Line; use GNAT.Command_Line; procedure Gnatxref is @@ -59,20 +63,25 @@ procedure Gnatxref is procedure Parse_Cmd_Line is begin loop - case GNAT.Command_Line.Getopt ("a aI: aO: d f g h I: p: u v") is + case + GNAT.Command_Line.Getopt + ("a aI: aO: d f g h I: nostdinc nostdlib p: u v -RTS=") + is when ASCII.NUL => exit; when 'a' => if GNAT.Command_Line.Full_Switch = "a" then Read_Only := True; + elsif GNAT.Command_Line.Full_Switch = "aI" then Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); + else Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); end if; - when 'd' => + when 'd' => Der_Info := True; when 'f' => @@ -88,6 +97,13 @@ procedure Gnatxref is Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); + when 'n' => + if GNAT.Command_Line.Full_Switch = "nostdinc" then + Opt.No_Stdinc := True; + elsif GNAT.Command_Line.Full_Switch = "nostlib" then + Opt.No_Stdlib := True; + end if; + when 'p' => declare S : constant String := GNAT.Command_Line.Parameter; @@ -105,6 +121,40 @@ procedure Gnatxref is Vi_Mode := True; Search_Unused := False; + -- The only switch starting with -- recognized is --RTS + + when '-' => + Opt.No_Stdinc := True; + Opt.RTS_Switch := True; + + declare + Src_Path_Name : String_Ptr := + Get_RTS_Search_Dir + (GNAT.Command_Line.Parameter, Include); + + Lib_Path_Name : String_Ptr := + Get_RTS_Search_Dir + (GNAT.Command_Line.Parameter, Objects); + + begin + if Src_Path_Name /= null and then Lib_Path_Name /= null then + Add_Search_Dirs (Src_Path_Name, Include); + Add_Search_Dirs (Lib_Path_Name, Objects); + + elsif Src_Path_Name = null and then Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude and adalib directories"); + + elsif Src_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude directory"); + + elsif Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adalib directory"); + end if; + end; + when others => Write_Usage; end case; @@ -125,7 +175,7 @@ procedure Gnatxref is Write_Usage; end if; - Add_File (S); + Add_Xref_File (S); Have_File := True; end; end loop; @@ -138,7 +188,7 @@ procedure Gnatxref is when GNAT.Command_Line.Invalid_Parameter => Ada.Text_IO.Put_Line ("Parameter missing for : " - & GNAT.Command_Line.Parameter); + & GNAT.Command_Line.Full_Switch); Write_Usage; end Parse_Cmd_Line; @@ -151,24 +201,30 @@ procedure Gnatxref is begin Put_Line ("GNATXREF " & Gnatvsn.Gnat_Version_String - & " Copyright 1998-2001, Ada Core Technologies Inc."); + & " Copyright 1998-2002, Ada Core Technologies Inc."); Put_Line ("Usage: gnatxref [switches] file1 file2 ..."); New_Line; Put_Line (" file ... list of source files to xref, " & "including with'ed units"); New_Line; Put_Line ("gnatxref switches:"); - Put_Line (" -a Consider all files, even when the ali file is" + Put_Line (" -a Consider all files, even when the ali file is" & " readonly"); - Put_Line (" -aIdir Specify source files search path"); - Put_Line (" -aOdir Specify library/object files search path"); - Put_Line (" -d Output derived type information"); - Put_Line (" -f Output full path name"); - Put_Line (" -g Output information only for global symbols"); - Put_Line (" -Idir Like -aIdir -aOdir"); - Put_Line (" -p file Use file as the default project file"); - Put_Line (" -u List unused entities"); - Put_Line (" -v Print a 'tags' file for vi"); + Put_Line (" -aIdir Specify source files search path"); + Put_Line (" -aOdir Specify library/object files search path"); + Put_Line (" -d Output derived type information"); + Put_Line (" -f Output full path name"); + Put_Line (" -g Output information only for global symbols"); + Put_Line (" -Idir Like -aIdir -aOdir"); + Put_Line (" -nostdinc Don't look for sources in the system default" + & " directory"); + Put_Line (" -nostdlib Don't look for library files in the system" + & " default directory"); + Put_Line (" --RTS=dir specify the default source and object search" + & " path"); + Put_Line (" -p file Use file as the default project file"); + Put_Line (" -u List unused entities"); + Put_Line (" -v Print a 'tags' file for vi"); New_Line; raise Usage_Error; diff --git a/gcc/ada/hlo.adb b/gcc/ada/hlo.adb index 86fe3bd3282..c657ea4b7bb 100644 --- a/gcc/ada/hlo.adb +++ b/gcc/ada/hlo.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ -- +-- $Revision$ -- -- --- Copyright (C) 1998 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,6 +35,8 @@ package body HLO is ------------------------- procedure High_Level_Optimize (N : Node_Id) is + pragma Warnings (Off, N); + begin Write_Str ("High level optimizer activated"); Write_Eol; diff --git a/gcc/ada/hostparm.ads b/gcc/ada/hostparm.ads index b076f99bd69..69ca47aad9c 100644 --- a/gcc/ada/hostparm.ads +++ b/gcc/ada/hostparm.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.18 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -38,7 +38,6 @@ -- compiler is running, and thus this package is part of the compiler. package Hostparm is -pragma Preelaborate (Hostparm); ----------------------- -- TARGET Parameters -- @@ -53,7 +52,10 @@ pragma Preelaborate (Hostparm); -- HOST Parameters -- --------------------- - OpenVMS : Boolean := False; + Gnat_VMSp : Integer; + pragma Import (C, Gnat_VMSp, "__gnat_vmsp"); + + OpenVMS : Boolean := Gnat_VMSp /= 0; -- Set True for OpenVMS host. See also OpenVMS target boolean in -- 5vsystem.ads and OpenVMS_On_Target boolean in Targparm. This is -- not a constant, because it can be modified by -gnatdm. diff --git a/gcc/ada/i-cobol.adb b/gcc/ada/i-cobol.adb index 74b65b9e457..d4ebf30bbff 100644 --- a/gcc/ada/i-cobol.adb +++ b/gcc/ada/i-cobol.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.14 $ +-- $Revision$ -- -- --- Copyright (C) 1992-1999 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- -- @@ -696,7 +696,6 @@ package body Interfaces.COBOL is if Format = Packed_Unsigned then return Item (Item'Last) = 16#F#; - -- For signed, accept all standard and non-standard signs else @@ -718,6 +717,8 @@ package body Interfaces.COBOL is -- Note that the tests here are all compile time tests function Length (Format : Binary_Format) return Natural is + pragma Warnings (Off, Format); + begin if Num'Digits <= 2 then return 1; @@ -756,6 +757,8 @@ package body Interfaces.COBOL is (Format : Packed_Format) return Natural is + pragma Warnings (Off, Format); + begin case Packed_Representation is when IBM => diff --git a/gcc/ada/i-cpp.adb b/gcc/ada/i-cpp.adb index 3aed957b943..b44885d0f93 100644 --- a/gcc/ada/i-cpp.adb +++ b/gcc/ada/i-cpp.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.19 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -75,13 +75,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 -- --------------------------------------------- @@ -158,6 +154,8 @@ package body Interfaces.CPP is ----------------------- function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is + pragma Warnings (Off, T); + begin return 0; end CPP_Get_RC_Offset; @@ -167,6 +165,8 @@ package body Interfaces.CPP is ------------------------------- function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is + pragma Warnings (Off, T); + begin return True; end CPP_Get_Remotely_Callable; @@ -269,6 +269,9 @@ package body Interfaces.CPP is ----------------------- procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is + pragma Warnings (Off, T); + pragma Warnings (Off, Value); + begin null; end CPP_Set_RC_Offset; @@ -278,6 +281,9 @@ package body Interfaces.CPP is ------------------------------- procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is + pragma Warnings (Off, T); + pragma Warnings (Off, Value); + begin null; end CPP_Set_Remotely_Callable; @@ -301,6 +307,9 @@ package body Interfaces.CPP is Position : Positive) return System.Address is + pragma Warnings (Off, Vptr); + pragma Warnings (Off, Position); + begin return Current_This; diff --git a/gcc/ada/i-cstrea.ads b/gcc/ada/i-cstrea.ads index 220b215e78f..dcb00650149 100644 --- a/gcc/ada/i-cstrea.ads +++ b/gcc/ada/i-cstrea.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.26 $ +-- $Revision$ -- -- --- Copyright (C) 1995-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1995-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- -- @@ -33,16 +33,13 @@ -- -- ------------------------------------------------------------------------------ - - -- This package is a thin binding to selected functions in the C -- library that provide a complete interface for handling C streams. -with Unchecked_Conversion; with System.Parameters; package Interfaces.C_Streams is -pragma Elaborate_Body (C_Streams); + pragma Preelaborate; -- Note: the reason we do not use the types that are in Interfaces.C is -- that we want to avoid dragging in the code in this unit if possible. @@ -291,56 +288,25 @@ private pragma Import (C, full_name, "__gnat_full_name"); -- The following may be implemented as macros, and so are supported - -- via an interface function in the a-stdio.c file. + -- via an interface function in the a-cstrea.c file. pragma Import (C, feof, "__gnat_feof"); pragma Import (C, ferror, "__gnat_ferror"); pragma Import (C, fileno, "__gnat_fileno"); - -- Constants in stdio are provided via imported variables that are - -- defined in a-cstrea.c using the stdio.h header. It would be cleaner - -- if we could import constant directly, but GNAT does not support - -- pragma Import for constants ??? - - c_constant_EOF : int; - - c_constant_IOFBF : int; - c_constant_IOLBF : int; - c_constant_IONBF : int; - - c_constant_SEEK_CUR : int; - c_constant_SEEK_END : int; - c_constant_SEEK_SET : int; - - c_constant_L_tmpnam : int; - - pragma Import (C, c_constant_EOF, "__gnat_constant_eof"); - pragma Import (C, c_constant_IOFBF, "__gnat_constant_iofbf"); - pragma Import (C, c_constant_IOLBF, "__gnat_constant_iolbf"); - pragma Import (C, c_constant_IONBF, "__gnat_constant_ionbf"); - pragma Import (C, c_constant_SEEK_CUR, "__gnat_constant_seek_cur"); - pragma Import (C, c_constant_SEEK_END, "__gnat_constant_seek_end"); - pragma Import (C, c_constant_SEEK_SET, "__gnat_constant_seek_set"); - pragma Import (C, c_constant_L_tmpnam, "__gnat_constant_l_tmpnam"); + pragma Import (C, EOF, "__gnat_constant_eof"); + pragma Import (C, IOFBF, "__gnat_constant_iofbf"); + pragma Import (C, IOLBF, "__gnat_constant_iolbf"); + pragma Import (C, IONBF, "__gnat_constant_ionbf"); + pragma Import (C, SEEK_CUR, "__gnat_constant_seek_cur"); + pragma Import (C, SEEK_END, "__gnat_constant_seek_end"); + pragma Import (C, SEEK_SET, "__gnat_constant_seek_set"); + pragma Import (C, L_tmpnam, "__gnat_constant_l_tmpnam"); pragma Import (C, stderr, "__gnat_constant_stderr"); pragma Import (C, stdin, "__gnat_constant_stdin"); pragma Import (C, stdout, "__gnat_constant_stdout"); - EOF : constant int := c_constant_EOF; - IOFBF : constant int := c_constant_IOFBF; - IOLBF : constant int := c_constant_IOLBF; - IONBF : constant int := c_constant_IONBF; - SEEK_CUR : constant int := c_constant_SEEK_CUR; - SEEK_END : constant int := c_constant_SEEK_END; - SEEK_SET : constant int := c_constant_SEEK_SET; - L_tmpnam : constant int := c_constant_L_tmpnam; - - type Dummy is access Integer; - function To_Address is new Unchecked_Conversion (Dummy, System.Address); - -- Used to concoct the null address below - - NULL_Stream : constant FILEs := To_Address (Dummy'(null)); - -- Value returned (NULL in C) to indicate an fdopen/fopen/tmpfile error + NULL_Stream : constant FILEs := System.Null_Address; end Interfaces.C_Streams; diff --git a/gcc/ada/i-cstrin.adb b/gcc/ada/i-cstrin.adb index 4c0f166ce67..df59e9b9f4c 100644 --- a/gcc/ada/i-cstrin.adb +++ b/gcc/ada/i-cstrin.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.21 $ +-- $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- -- @@ -59,11 +59,14 @@ package body Interfaces.C.Strings is function Position_Of_Nul (Into : char_array) return size_t; -- Returns position of the first Nul in Into or Into'Last + 1 if none - function C_Malloc (Size : size_t) return chars_ptr; - pragma Import (C, C_Malloc, "__gnat_malloc"); + -- We can't use directly System.Memory because the categorization is not + -- compatible, so we directly import here the malloc and free routines. - procedure C_Free (Address : chars_ptr); - pragma Import (C, C_Free, "__gnat_free"); + function Memory_Alloc (Size : size_t) return chars_ptr; + pragma Import (C, Memory_Alloc, "__gnat_malloc"); + + procedure Memory_Free (Address : chars_ptr); + pragma Import (C, Memory_Free, "__gnat_free"); --------- -- "+" -- @@ -84,7 +87,7 @@ package body Interfaces.C.Strings is return; end if; - C_Free (Item); + Memory_Free (Item); Item := Null_Ptr; end Free; @@ -101,7 +104,7 @@ package body Interfaces.C.Strings is -- nul is absent and must be added explicitly. Index := Position_Of_Nul (Into => Chars); - Pointer := C_Malloc ((Index - Chars'First + 1)); + Pointer := Memory_Alloc ((Index - Chars'First + 1)); -- If nul is present, transfer string up to and including it. diff --git a/gcc/ada/i-pacdec.adb b/gcc/ada/i-pacdec.adb index 81f805120a5..e49c455635f 100644 --- a/gcc/ada/i-pacdec.adb +++ b/gcc/ada/i-pacdec.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (Version for IBM Mainframe Packed Decimal Format) -- -- -- --- $Revision: 1.6 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- @@ -209,6 +209,7 @@ package body Interfaces.Packed_Decimal is -- Cases where all nibbles are used else + V := 0; J := 1; end if; @@ -294,6 +295,7 @@ package body Interfaces.Packed_Decimal is else J := 1; + V := 0; end if; -- Loop to process bytes containing two digit nibbles diff --git a/gcc/ada/i-vxwork.ads b/gcc/ada/i-vxwork.ads index edd61d027ca..82b744e7415 100644 --- a/gcc/ada/i-vxwork.ads +++ b/gcc/ada/i-vxwork.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.4 $ +-- $Revision$ -- -- -- --- Copyright (C) 1999 - 2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 1999 - 2002 Ada Core Technologies, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index b7242d2549d..3fb0c56f91b 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 2000-2001 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- -- @@ -138,8 +138,10 @@ package body Impunit is -- GNAT Defined Additions to Ada -- ----------------------------------- + "a-chlat9", -- Ada.Characters.Latin_9 "a-colire", -- Ada.Command_Line.Remove "a-cwila1", -- Ada.Characters.Wide_Latin_1 + "a-cwila9", -- Ada.Characters.Wide_Latin_9 "a-diocst", -- Ada.Direct_IO.C_Streams "a-einuoc", -- Ada.Exceptions.Is_Null_Occurrence "a-siocst", -- Ada.Sequential_IO.C_Streams @@ -207,6 +209,7 @@ package body Impunit is "g-io ", -- GNAT.IO "g-io_aux", -- GNAT.IO_Aux "g-locfil", -- GNAT.Lock_Files + "g-md5 ", -- GNAT.MD5 "g-moreex", -- GNAT.Most_Recent_Exception "g-os_lib", -- GNAT.Os_Lib "g-regexp", -- GNAT.Regexp @@ -254,7 +257,8 @@ package body Impunit is "i-os2syn", -- Interfaces.Os2lib.Synchronization "i-os2thr", -- Interfaces.Os2lib.Threads "i-pacdec", -- Interfaces.Packed_Decimal - "i-vxwork", -- Interfaces.Vxworks + "i-vxwork", -- Interfaces.VxWorks + "i-vxwoio", -- Interfaces.VxWorks.IO -------------------------------------------------- -- System Hierarchy Units from Reference Manual -- diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 0637b781ad1..f5888b0f995 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -4,11 +4,11 @@ * * * I N I T * * * - * $Revision: 1.7 $ + * $Revision$ * * * C Implementation File * * * - * Copyright (C) 1992-2001 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- * @@ -51,6 +51,9 @@ #include "tconfig.h" #include "tsystem.h" #include <sys/stat.h> + +/* We don't have libiberty, so us malloc. */ +#define xmalloc(S) malloc (S) #else #include "config.h" #include "system.h" @@ -94,14 +97,16 @@ extern void Propagate_Signal_Exception PARAMS ((struct Machine_State *, struct Exception_Data *, const char *)); /* Copies of global values computed by the binder */ -int __gl_main_priority = -1; -int __gl_time_slice_val = -1; -char __gl_wc_encoding = 'n'; -char __gl_locking_policy = ' '; -char __gl_queuing_policy = ' '; -char __gl_task_dispatching_policy = ' '; -int __gl_unreserve_all_interrupts = 0; -int __gl_exception_tracebacks = 0; +int __gl_main_priority = -1; +int __gl_time_slice_val = -1; +char __gl_wc_encoding = 'n'; +char __gl_locking_policy = ' '; +char __gl_queuing_policy = ' '; +char *__gl_restrictions = 0; +char __gl_task_dispatching_policy = ' '; +int __gl_unreserve_all_interrupts = 0; +int __gl_exception_tracebacks = 0; +int __gl_zero_cost_exceptions = 0; /* Indication of whether synchronous signal handler has already been installed by a previous call to adainit */ @@ -126,14 +131,15 @@ int __gnat_handler_installed = 0; void __gnat_set_globals (main_priority, time_slice_val, wc_encoding, locking_policy, - queuing_policy, task_dispatching_policy, adafinal_ptr, - unreserve_all_interrupts, exception_tracebacks) + queuing_policy, task_dispatching_policy, restrictions, + unreserve_all_interrupts, exception_tracebacks, + zero_cost_exceptions) int main_priority; int time_slice_val; - int wc_encoding; - int locking_policy, queuing_policy, task_dispatching_policy; - void (*adafinal_ptr) PARAMS ((void)) ATTRIBUTE_UNUSED; - int unreserve_all_interrupts, exception_tracebacks; + char wc_encoding; + char locking_policy, queuing_policy, task_dispatching_policy; + char *restrictions; + int unreserve_all_interrupts, exception_tracebacks, zero_cost_exceptions; { static int already_called = 0; @@ -163,14 +169,14 @@ __gnat_set_globals (main_priority, time_slice_val, wc_encoding, locking_policy, if (already_called) { - if (__gl_locking_policy != locking_policy || - __gl_queuing_policy != queuing_policy || - __gl_task_dispatching_policy != task_dispatching_policy || - __gl_unreserve_all_interrupts != unreserve_all_interrupts || - __gl_exception_tracebacks != exception_tracebacks) - { - __gnat_raise_program_error (__FILE__, __LINE__); - } + if (__gl_locking_policy != locking_policy + || __gl_queuing_policy != queuing_policy + || __gl_task_dispatching_policy != task_dispatching_policy + || __gl_unreserve_all_interrupts != unreserve_all_interrupts + || __gl_exception_tracebacks != exception_tracebacks + || __gl_zero_cost_exceptions != zero_cost_exceptions) + __gnat_raise_program_error (__FILE__, __LINE__); + return; } already_called = 1; @@ -180,9 +186,25 @@ __gnat_set_globals (main_priority, time_slice_val, wc_encoding, locking_policy, __gl_wc_encoding = wc_encoding; __gl_locking_policy = locking_policy; __gl_queuing_policy = queuing_policy; + __gl_restrictions = restrictions; __gl_task_dispatching_policy = task_dispatching_policy; __gl_unreserve_all_interrupts = unreserve_all_interrupts; __gl_exception_tracebacks = exception_tracebacks; + + /* ??? __gl_zero_cost_exceptions is new in 3.15 and is referenced from + a-except.adb, which is also part of the compiler sources. Since the + compiler is built with an older release of GNAT, the call generated by + the old binder to this function does not provide any value for the + corresponding argument, so the global has to be initialized in some + reasonable other way. This could be removed as soon as the next major + release is out. */ + +#ifdef IN_RTS + __gl_zero_cost_exceptions = zero_cost_exceptions; +#else + __gl_zero_cost_exceptions = 0; + /* We never build the compiler to run in ZCX mode currently anyway. */ +#endif } /*********************/ @@ -268,13 +290,9 @@ __gnat_install_handler () (void) sigaction (SIGABRT, &act, NULL); (void) sigaction (SIGFPE, &act, NULL); - - if (__gl_unreserve_all_interrupts == 0) - { - (void) sigaction (SIGILL, &act, NULL); - (void) sigaction (SIGSEGV, &act, NULL); - (void) sigaction (SIGBUS, &act, NULL); - } + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); __gnat_handler_installed = 1; } @@ -393,13 +411,9 @@ __gnat_install_handler () (void) sigaction (SIGABRT, &act, NULL); (void) sigaction (SIGFPE, &act, NULL); - - if (__gl_unreserve_all_interrupts == 0) - { - (void) sigaction (SIGILL, &act, NULL); - (void) sigaction (SIGSEGV, &act, NULL); - (void) sigaction (SIGBUS, &act, NULL); - } + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); __gnat_handler_installed = 1; } @@ -491,12 +505,14 @@ __gnat_install_handler () handled properly, avoiding a SEGV generation from stack usage by the handler itself. */ - static char handler_stack [SIGSTKSZ]; + static char handler_stack[SIGSTKSZ*2]; + /* SIGSTKSZ appeared to be "short" for the needs in some contexts + (e.g. experiments with GCC ZCX exceptions). */ stack_t stack; stack.ss_sp = handler_stack; - stack.ss_size = SIGSTKSZ; + stack.ss_size = sizeof (handler_stack); stack.ss_flags = 0; (void) sigaltstack (&stack, NULL); @@ -507,13 +523,10 @@ __gnat_install_handler () (void) sigaction (SIGABRT, &act, NULL); (void) sigaction (SIGFPE, &act, NULL); + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); - if (__gl_unreserve_all_interrupts == 0) - { - (void) sigaction (SIGILL, &act, NULL); - (void) sigaction (SIGSEGV, &act, NULL); - (void) sigaction (SIGBUS, &act, NULL); - } __gnat_handler_installed = 1; } @@ -654,13 +667,10 @@ __gnat_install_handler () (void) sigaction (SIGABRT, &act, NULL); (void) sigaction (SIGFPE, &act, NULL); + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); - if (__gl_unreserve_all_interrupts == 0) - { - (void) sigaction (SIGILL, &act, NULL); - (void) sigaction (SIGSEGV, &act, NULL); - (void) sigaction (SIGBUS, &act, NULL); - } __gnat_handler_installed = 1; } @@ -878,10 +888,9 @@ __gnat_install_handler () /* (void) sigaction (SIGABRT, &act, NULL); */ /* (void) sigaction (SIGFPE, &act, NULL); */ /* (void) sigaction (SIGBUS, &act, NULL); */ - if (__gl_unreserve_all_interrupts == 0) - { - (void) sigaction (SIGSEGV, &act, NULL); - } + + (void) sigaction (SIGSEGV, &act, NULL); + __gnat_handler_installed = 1; } @@ -1061,13 +1070,9 @@ __gnat_install_handler () (void) sigaction (SIGABRT, &act, NULL); (void) sigaction (SIGFPE, &act, NULL); - - if (__gl_unreserve_all_interrupts == 0) - { - (void) sigaction (SIGILL, &act, NULL); - (void) sigaction (SIGSEGV, &act, NULL); - (void) sigaction (SIGBUS, &act, NULL); - } + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); (void) sigaction (SIGADAABORT, &act, NULL); __gnat_handler_installed = 1; } @@ -1170,13 +1175,10 @@ __gnat_install_handler () (void) sigemptyset (&act.sa_mask); (void) sigaction (SIGABRT, &act, NULL); + (void) sigaction (SIGFPE, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); - if (__gl_unreserve_all_interrupts == 0) - { - (void) sigaction (SIGFPE, &act, NULL); - (void) sigaction (SIGSEGV, &act, NULL); - (void) sigaction (SIGBUS, &act, NULL); - } __gnat_handler_installed = 1; } @@ -1256,13 +1258,10 @@ __gnat_install_handler () (void) sigaction (SIGABRT, &act, NULL); (void) sigaction (SIGFPE, &act, NULL); + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); - if (__gl_unreserve_all_interrupts == 0) - { - (void) sigaction (SIGILL, &act, NULL); - (void) sigaction (SIGSEGV, &act, NULL); - (void) sigaction (SIGBUS, &act, NULL); - } __gnat_handler_installed = 1; } @@ -1317,21 +1316,21 @@ extern struct Exception_Data *Coded_Exception (int); struct descriptor_s {unsigned short len, mbz; char *adr; }; -static long __gnat_error_handler PARAMS ((int *, void *)); +long __gnat_error_handler PARAMS ((int *, void *)); -static long +long __gnat_error_handler (sigargs, mechargs) int *sigargs; void *mechargs; { struct Exception_Data *exception = 0; char *msg = ""; - char message [256]; + char message[256]; long prvhnd; struct descriptor_s msgdesc; int msg_flag = 0x000f; /* 1 bit for each of the four message parts */ unsigned short outlen; - char curr_icb [544]; + char curr_icb[544]; long curr_invo_handle; long *mstate; @@ -1359,20 +1358,20 @@ __gnat_error_handler (sigargs, mechargs) #ifdef IN_RTS /* See if it's an imported exception. Mask off severity bits. */ - exception = Coded_Exception (sigargs [1] & 0xfffffff8); + exception = Coded_Exception (sigargs[1] & 0xfffffff8); if (exception) { msgdesc.len = 256; msgdesc.mbz = 0; msgdesc.adr = message; SYS$GETMSG (sigargs[1], &outlen, &msgdesc, msg_flag, 0); - message [outlen] = 0; + message[outlen] = 0; msg = message; exception->Name_Length = 19; /* The full name really should be get sys$getmsg returns. ??? */ exception->Full_Name = "IMPORTED_EXCEPTION"; - exception->Import_Code = sigargs [1] & 0xfffffff8; + exception->Import_Code = sigargs[1] & 0xfffffff8; } #endif @@ -1440,7 +1439,7 @@ __gnat_error_handler (sigargs, mechargs) msgdesc.mbz = 0; msgdesc.adr = message; SYS$GETMSG (sigargs[1], &outlen, &msgdesc, msg_flag, 0); - message [outlen] = 0; + message[outlen] = 0; msg = message; break; } @@ -1463,7 +1462,7 @@ __gnat_install_handler () long prvhnd; char *c; - c = (char *) malloc (2049); + c = (char *) xmalloc (2049); __gnat_error_prehandler_stack = &c[2048]; @@ -1593,13 +1592,10 @@ __gnat_install_handler () (void) sigemptyset (&act.sa_mask); (void) sigaction (SIGFPE, &act, NULL); + (void) sigaction (SIGILL, &act, NULL); + (void) sigaction (SIGSEGV, &act, NULL); + (void) sigaction (SIGBUS, &act, NULL); - if (__gl_unreserve_all_interrupts == 0) - { - (void) sigaction (SIGILL, &act, NULL); - (void) sigaction (SIGSEGV, &act, NULL); - (void) sigaction (SIGBUS, &act, NULL); - } __gnat_handler_installed = 1; } diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 84a08ac659e..09ba57ca678 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -479,12 +479,12 @@ package body Inline is begin Analyzing_Inlined_Bodies := False; - if Errors_Detected = 0 then + if Serious_Errors_Detected = 0 then New_Scope (Standard_Standard); J := 0; while J <= Inlined_Bodies.Last - and then Errors_Detected = 0 + and then Serious_Errors_Detected = 0 loop Pack := Inlined_Bodies.Table (J); @@ -503,9 +503,14 @@ package body Inline is Comp_Unit := Parent (Comp_Unit); end loop; + -- Load the body, unless it the main unit, or is an instance + -- whose body has already been analyzed. + if Present (Comp_Unit) and then Comp_Unit /= Cunit (Main_Unit) and then Body_Required (Comp_Unit) + and then (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration + or else No (Corresponding_Body (Unit (Comp_Unit)))) then declare Bname : constant Unit_Name_Type := @@ -757,7 +762,7 @@ package body Inline is Info : Pending_Body_Info; begin - if Errors_Detected = 0 then + if Serious_Errors_Detected = 0 then Expander_Active := (Operating_Mode = Opt.Generate_Code); New_Scope (Standard_Standard); @@ -774,7 +779,7 @@ package body Inline is J := 0; while J <= Pending_Instantiations.Last - and then Errors_Detected = 0 + and then Serious_Errors_Detected = 0 loop Info := Pending_Instantiations.Table (J); diff --git a/gcc/ada/io-aux.c b/gcc/ada/io-aux.c index d42f362caec..5b9fca0e326 100644 --- a/gcc/ada/io-aux.c +++ b/gcc/ada/io-aux.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * $Revision: 1.1 $ + * $Revision$ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * @@ -34,40 +34,12 @@ #include <stdio.h> -#ifdef IN_RTS -#include "tconfig.h" -#else -#include "config.h" -#endif - /* Function wrappers are needed to access the values from Ada which are */ /* defined as C macros. */ -FILE *c_stdin PARAMS ((void)); -FILE *c_stdout PARAMS ((void)); -FILE *c_stderr PARAMS ((void)); -int seek_set_function PARAMS ((void)); -int seek_end_function PARAMS ((void)); -void *null_function PARAMS ((void)); -int c_fileno PARAMS ((FILE *)); - -FILE * -c_stdin () -{ - return stdin; -} - -FILE * -c_stdout () -{ - return stdout; -} - -FILE * -c_stderr () -{ - return stderr; -} +FILE *c_stdin (void) { return stdin; } +FILE *c_stdout (void) { return stdout;} +FILE *c_stderr (void) { return stderr;} #ifndef SEEK_SET /* Symbolic constants for the "fseek" function: */ #define SEEK_SET 0 /* Set file pointer to offset */ @@ -75,26 +47,8 @@ c_stderr () #define SEEK_END 2 /* Set file pointer to the size of the file plus offset */ #endif -int -seek_set_function () -{ - return SEEK_SET; -} - -int -seek_end_function () -{ - return SEEK_END; -} - -void *null_function () -{ - return NULL; -} +int seek_set_function (void) { return SEEK_SET; } +int seek_end_function (void) { return SEEK_END; } +void *null_function (void) { return NULL; } -int -c_fileno (s) - FILE *s; -{ - return fileno (s); -} +int c_fileno (FILE *s) { return fileno (s); } diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 2cf97cb2fb8..8245e9556d7 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -171,6 +171,12 @@ package body Layout is -- E are set (either from previously given values, or from the newly -- computed values, as appropriate). + procedure Set_Composite_Alignment (E : Entity_Id); + -- This procedure is called for record types and subtypes, and also for + -- atomic array types and subtypes. If no alignment is set, and the size + -- is 2 or 4 (or 8 if the word size is 8), then the alignment is set to + -- match the size. + ---------------------------- -- Adjust_Esize_Alignment -- ---------------------------- @@ -930,16 +936,21 @@ package body Layout is Insert_Typ := E; end if; - -- Cannot do anything if Esize of component type unknown + -- Deal with component size if base type - if Unknown_Esize (Ctyp) then - return; - end if; + if Ekind (E) = E_Array_Type then + + -- Cannot do anything if Esize of component type unknown + + if Unknown_Esize (Ctyp) then + return; + end if; - -- Set component size if not set already + -- Set component size if not set already - if Unknown_Component_Size (E) then - Set_Component_Size (E, Esize (Ctyp)); + if Unknown_Component_Size (E) then + Set_Component_Size (E, Esize (Ctyp)); + end if; end if; -- (RM 13.3 (48)) says that the size of an unconstrained array @@ -2263,9 +2274,30 @@ package body Layout is if Frontend_Layout_On_Target then if Is_Array_Type (E) and then not Is_Bit_Packed_Array (E) then Layout_Array_Type (E); + return; elsif Is_Record_Type (E) then Layout_Record_Type (E); + return; end if; + + -- Special remaining processing for record types with a known size + -- of 16, 32, or 64 bits whose alignment is not yet set. For these + -- types, we set a corresponding alignment matching the size if + -- possible, or as large as possible if not. + + elsif Is_Record_Type (E) and not Debug_Flag_Q then + Set_Composite_Alignment (E); + + -- For arrays, we only do this processing for arrays that are + -- required to be atomic. Here, we really need to have proper + -- alignment, but for the normal case of non-atomic arrays it + -- seems better to use the component alignment as the default. + + elsif Is_Array_Type (E) + and then Is_Atomic (E) + and then not Debug_Flag_Q + then + Set_Composite_Alignment (E); end if; end Layout_Type; @@ -2379,6 +2411,58 @@ package body Layout is end if; end Set_And_Check_Static_Size; + ----------------------------- + -- Set_Composite_Alignment -- + ----------------------------- + + procedure Set_Composite_Alignment (E : Entity_Id) is + Siz : Uint; + Align : Nat; + + begin + if Unknown_Alignment (E) then + if Known_Static_Esize (E) then + Siz := Esize (E); + + elsif Unknown_Esize (E) + and then Known_Static_RM_Size (E) + then + Siz := RM_Size (E); + + else + return; + end if; + + -- Size is known, alignment is not set + + if Siz = System_Storage_Unit then + Align := 1; + elsif Siz = 2 * System_Storage_Unit then + Align := 2; + elsif Siz = 4 * System_Storage_Unit then + Align := 4; + elsif Siz = 8 * System_Storage_Unit then + Align := 8; + else + return; + end if; + + if Align > Maximum_Alignment then + Align := Maximum_Alignment; + end if; + + if Align > System_Word_Size / System_Storage_Unit then + Align := System_Word_Size / System_Storage_Unit; + end if; + + Set_Alignment (E, UI_From_Int (Align)); + + if Unknown_Esize (E) then + Set_Esize (E, UI_From_Int (Align * System_Storage_Unit)); + end if; + end if; + end Set_Composite_Alignment; + -------------------------- -- Set_Discrete_RM_Size -- -------------------------- diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index b1f18d5f41e..a8d4250cc22 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.86 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -36,12 +36,14 @@ with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Osint; use Osint; +with Osint.C; use Osint.C; with Output; use Output; with Par; with Scn; use Scn; with Sinfo; use Sinfo; with Sinput; use Sinput; with Sinput.L; use Sinput.L; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Uname; use Uname; @@ -241,9 +243,25 @@ package body Lib.Load is -- to inline stuff from it. If this is not the case, an error -- message will be issued in Rtsfind in any case. + ------------------------------ + -- Set_Load_Unit_Dependency -- + ------------------------------ + procedure Set_Load_Unit_Dependency (U : Unit_Number_Type) is begin + -- Differentiate between pragma No_Run_Time (that can be used + -- with a standard installation), and HI-E mode which comes + -- with a special installation. + -- + -- For No_Run_Time mode, we do not want to create a dependency + -- since the binder would generate references to these units. + -- In the case of HI-E, a special run time is provided that do + -- not have any elaboration, so it is safe (and useful) to add + -- the dependency. In particular, this allows the user to + -- recompile run time units, e.g GNAT.IO. + if No_Run_Time + and then not High_Integrity_Mode_On_Target and then Is_Internal_File_Name (Unit_File_Name (U)) then null; diff --git a/gcc/ada/lib-util.adb b/gcc/ada/lib-util.adb index 4e3770c5bab..bee3a768ff8 100644 --- a/gcc/ada/lib-util.adb +++ b/gcc/ada/lib-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.7 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -28,7 +28,7 @@ with Hostparm; with Namet; use Namet; -with Osint; use Osint; +with Osint.C; use Osint.C; package body Lib.Util is diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index c2b15d59df0..e0c3c406d2a 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -40,13 +40,13 @@ with Nlists; use Nlists; with Gnatvsn; use Gnatvsn; with Opt; use Opt; with Osint; use Osint; +with Osint.C; use Osint.C; with Par; with Restrict; use Restrict; with Scn; use Scn; with Sinfo; use Sinfo; with Sinput; use Sinput; with Stringt; use Stringt; -with Targparm; use Targparm; with Uname; use Uname; with System.WCh_Con; use System.WCh_Con; @@ -483,6 +483,51 @@ package body Lib.Writ is end if; Write_With_Lines; + + -- Output linker option lines + + for J in 1 .. Linker_Option_Lines.Last loop + declare + S : constant Linker_Option_Entry := + Linker_Option_Lines.Table (J); + C : Character; + + begin + if S.Unit = Unit_Num then + Write_Info_Initiate ('L'); + Write_Info_Str (" """); + + for J in 1 .. String_Length (S.Option) loop + C := Get_Character (Get_String_Char (S.Option, J)); + + if C in Character'Val (16#20#) .. Character'Val (16#7E#) + and then C /= '{' + then + Write_Info_Char (C); + + if C = '"' then + Write_Info_Char (C); + end if; + + else + declare + Hex : array (0 .. 15) of Character := + "0123456789ABCDEF"; + + begin + Write_Info_Char ('{'); + Write_Info_Char (Hex (Character'Pos (C) / 16)); + Write_Info_Char (Hex (Character'Pos (C) mod 16)); + Write_Info_Char ('}'); + end; + end if; + end loop; + + Write_Info_Char ('"'); + Write_Info_EOL; + end if; + end; + end loop; end Write_Unit_Information; ---------------------- @@ -773,7 +818,7 @@ package body Lib.Writ is Write_Info_Str (" UA"); end if; - if ZCX_By_Default_On_Target then + if Exception_Mechanism /= Setjmp_Longjmp then if Unit_Exception_Table_Present then Write_Info_Str (" UX"); end if; @@ -788,7 +833,7 @@ package body Lib.Writ is Write_Info_Initiate ('R'); Write_Info_Char (' '); - for J in Partition_Restrictions loop + for J in All_Restrictions loop if Main_Restrictions (J) then Write_Info_Char ('r'); elsif Violations (J) then @@ -814,47 +859,6 @@ package body Lib.Writ is Write_Info_EOL; -- blank line - -- Output linker option lines - - for J in 1 .. Linker_Option_Lines.Last loop - declare - S : constant String_Id := Linker_Option_Lines.Table (J); - C : Character; - - begin - Write_Info_Initiate ('L'); - Write_Info_Str (" """); - - for J in 1 .. String_Length (S) loop - C := Get_Character (Get_String_Char (S, J)); - - if C in Character'Val (16#20#) .. Character'Val (16#7E#) - and then C /= '{' - then - Write_Info_Char (C); - - if C = '"' then - Write_Info_Char (C); - end if; - - else - declare - Hex : array (0 .. 15) of Character := "0123456789ABCDEF"; - - begin - Write_Info_Char ('{'); - Write_Info_Char (Hex (Character'Pos (C) / 16)); - Write_Info_Char (Hex (Character'Pos (C) mod 16)); - Write_Info_Char ('}'); - end; - end if; - end loop; - - Write_Info_Char ('"'); - Write_Info_EOL; - end; - end loop; - -- Output external version reference lines for J in 1 .. Version_Ref.Last loop diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index f1770ba590e..3ef8f0c6c70 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -203,8 +203,8 @@ package Lib.Writ is -- This line records information regarding restrictions. The -- parameter is a string of characters, one for each entry in - -- Restrict.Partition_Restrictions, in order. There are three - -- settings possible settings for each restriction: + -- Restrict.Compilation_Unit_Restrictions, in order. There are + -- three settings possible settings for each restriction: -- r Restricted. Unit was compiled under control of a pragma -- Restrictions for the corresponding restriction. In @@ -216,7 +216,7 @@ package Lib.Writ is -- pragma Restrictions for the corresponding restriction, -- and does not make any use of the referenced feature. - -- v Violated. The unit was not compiled uner control of a + -- v Violated. The unit was not compiled under control of a -- pragma Restrictions for the corresponding restriction, -- and it does indeed use the referenced feature. @@ -344,23 +344,15 @@ package Lib.Writ is -- of a generic unit compiled with earlier versions of GNAT which -- did not generate object or ali files for generics. - --------------------- - -- Reference Lines -- - --------------------- - - -- The reference lines contain information about references from - -- any of the units in the compilation (including, body version - -- and version attributes, linker options pragmas and source - -- dependencies. - -- ----------------------- -- -- L Linker_Options -- -- ----------------------- - -- Following the unit information is an optional series of lines that - -- indicates the usage of pragma Linker_Options. For each appearence - -- of pragma Linker_Actions in any of the units for which unit lines - -- are present, a line of the form: + -- Following the W lines (if any, or the U line if not), are an + -- optional series of lines that indicates the usage of the pragma + -- Linker_Options in the associated unit. For each appearence of a + -- pragma Linker_Options (or Link_With) in the unit, a line is + -- present with the form: -- L "string" @@ -378,6 +370,20 @@ package Lib.Writ is -- that wide characters in the form {hhhh} cannot be produced, since -- pragma Linker_Option accepts only String, not Wide_String. + -- The L lines are required to appear in the same order as the + -- corresponding Linker_Options (or Link_With) pragmas appear in + -- the source file, so that this order is preserved by the binder + -- in constructing the set of linker arguments. + + --------------------- + -- Reference Lines -- + --------------------- + + -- The reference lines contain information about references from + -- any of the units in the compilation (including, body version + -- and version attributes, linker options pragmas and source + -- dependencies. + -- ------------------------------------ -- -- E External Version References -- -- ------------------------------------ diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 06397c74fce..e0e20b45edd 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1998-2001, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -28,12 +28,13 @@ with Atree; use Atree; with Csets; use Csets; -with Debug; use Debug; +with Errout; use Errout; with Lib.Util; use Lib.Util; with Namet; use Namet; with Opt; use Opt; with Sinfo; use Sinfo; with Sinput; use Sinput; +with Stand; use Stand; with Table; use Table; with Widechar; use Widechar; @@ -79,7 +80,7 @@ package body Lib.Xref is package Xrefs is new Table.Table ( Table_Component_Type => Xref_Entry, - Table_Index_Type => Int, + Table_Index_Type => Xref_Entry_Number, Table_Low_Bound => 1, Table_Initial => Alloc.Xrefs_Initial, Table_Increment => Alloc.Xrefs_Increment, @@ -201,13 +202,22 @@ package body Lib.Xref is -- we omit this test if Typ is 'e', since these entries are -- really structural, and it is useful to have them in units -- that reference packages as well as units that define packages. + -- We also omit the test for the case of 'p' since we want to + -- include inherited primitive operations from other packages. if not In_Extended_Main_Source_Unit (N) and then Typ /= 'e' + and then Typ /= 'p' then return; end if; + -- For reference type p, then entity must be in main source unit + + if Typ = 'p' and then not In_Extended_Main_Source_Unit (E) then + return; + end if; + -- Unless the reference is forced, we ignore references where -- the reference itself does not come from Source. @@ -227,6 +237,26 @@ package body Lib.Xref is if Set_Ref then Set_Referenced (E); + -- Check for pragma unreferenced given + + if Has_Pragma_Unreferenced (E) then + + -- A reference as a named parameter in a call does not count + -- as a violation of pragma Unreferenced for this purpose. + + if Nkind (N) = N_Identifier + and then Nkind (Parent (N)) = N_Parameter_Association + and then Selector_Name (Parent (N)) = N + then + null; + + -- Here we issue the warning, since this is a real reference + + else + Error_Msg_NE ("?pragma Unreferenced given for&", N, E); + end if; + end if; + -- If this is a subprogram instance, mark as well the internal -- subprogram in the wrapper package, which may be a visible -- compilation unit. @@ -523,12 +553,6 @@ package body Lib.Xref is return; end if; - -- For now, nothing to do unless special debug flag set - - if not Debug_Flag_MM then - return; - end if; - -- Output instantiation reference Write_Info_Char ('['); @@ -768,7 +792,7 @@ package body Lib.Xref is -- Write out renaming reference if we have one - if Debug_Flag_MM and then Present (Rref) then + if Present (Rref) then Write_Info_Char ('='); Write_Info_Nat (Int (Get_Logical_Line_Number (Sloc (Rref)))); @@ -850,20 +874,20 @@ package body Lib.Xref is end if; -- Exit if no type reference, or we are stuck in - -- some loop trying to find the type reference. + -- some loop trying to find the type reference, or + -- if the type is standard void type (the latter is + -- an implementation artifact that should not show + -- up in the generated cross-references). - exit when No (Tref) or else Tref = Sav; + exit when No (Tref) + or else Tref = Sav + or else Tref = Standard_Void_Type; -- Here we have a type reference to output -- Case of standard entity, output name if Sloc (Tref) = Standard_Location then - - -- For now, output only if special -gnatdM flag set - - exit when not Debug_Flag_MM; - Write_Info_Char (Left); Write_Info_Name (Chars (Tref)); Write_Info_Char (Right); @@ -873,11 +897,6 @@ package body Lib.Xref is elsif Comes_From_Source (Tref) then - -- For now, output only derived type entries - -- unless we have special debug flag -gnatdM - - exit when not (Debug_Flag_MM or else Left = '<'); - -- Do not output type reference if referenced -- entity is not in the main unit and is itself -- not referenced, since otherwise the reference @@ -898,8 +917,26 @@ package body Lib.Xref is Write_Info_Nat (Int (Get_Logical_Line_Number (Sloc (Tref)))); - Write_Info_Char - (Xref_Entity_Letters (Ekind (Tref))); + + declare + Ent : Entity_Id := Tref; + Kind : constant Entity_Kind := Ekind (Ent); + Ctyp : Character := Xref_Entity_Letters (Kind); + + begin + if Ctyp = '+' + and then Present (Full_View (Ent)) + then + Ent := Underlying_Type (Ent); + + if Present (Ent) then + Ctyp := Xref_Entity_Letters (Ekind (Ent)); + end if; + end if; + + Write_Info_Char (Ctyp); + end; + Write_Info_Nat (Int (Get_Column_Number (Sloc (Tref)))); Write_Info_Char (Right); diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index 396d8468ee8..c56a8566065 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1998-2001, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -40,37 +40,41 @@ package Lib.Xref is -- Cross-reference sections follow the dependency section (D lines) in -- an ALI file, so that they need not be read by gnatbind, gnatmake etc. - -- + -- A cross reference section has a header of the form - -- + -- X dependency-number filename - -- + -- This header precedes xref information (entities/references from -- the unit, identified by dependency number and file name. The -- dependency number is the index into the generated D lines and -- is ones origin (i.e. 2 = reference to second generated D line). - -- + -- Note that the filename here will reflect the original name if -- a Source_Reference pragma was encountered (since all line number -- references will be with respect to the original file). - -- + -- The lines following the header look like - -- + -- line type col level entity renameref typeref ref ref ref - -- - -- line is the line number of the referenced entity. It starts - -- in column one. - -- + + -- line is the line number of the referenced entity. The name of + -- the entity starts in column col. Columns are numbered from one, + -- and if horizontal tab characters are present, the column number + -- is computed assuming standard 1,9,17,.. tab stops. For example, + -- if the entity is the first token on the line, and is preceded + -- by space-HT-space, then the column would be column 10. + -- type is a single letter identifying the type of the entity. -- See next section (Cross-Reference Entity Identifiers) for a -- full list of the characters used). - -- + -- col is the column number of the referenced entity - -- + -- level is a single character that separates the col and -- entity fields. It is an asterisk for a top level library -- entity that is publicly visible, and space otherwise. - -- + -- entity is the name of the referenced entity, with casing in -- the canical casing for the source file where it is defined. @@ -79,32 +83,33 @@ package Lib.Xref is -- a renaming declaration, and the renaming refers to an entity -- with a simple identifier or expanded name, then renameref has -- the form: - -- + -- =line:col - -- + -- Here line:col give the reference to the identifier that -- appears in the renaming declaration. Note that we never need -- a file entry, since this identifier is always in the current -- file in which the entity is declared. Currently, renameref -- appears only for the simple renaming case. If the renaming -- reference is a complex expressions, then renameref is omitted. - -- + -- Here line/col give line/column as defined above. + -- typeref is the reference for a related type. This part is -- optional. It is present for the following cases: - -- + -- derived types (points to the parent type) LR=<> -- access types (points to designated type) LR=() -- subtypes (points to ancestor type) LR={} -- functions (points to result type) LR={} -- enumeration literals (points to enum type) LR={} -- objects and components (points to type) LR={} - -- + -- In the above list LR shows the brackets used in the output, -- which has one of the two following forms: - -- + -- L file | line type col R user entity -- L name-in-lower-case R standard entity - -- + -- For the form for a user entity, file is the dependency number -- of the file containing the declaration of the related type. -- This number and the following vertical bar are omitted if the @@ -113,26 +118,32 @@ package Lib.Xref is -- specify the location of the relevant type declaration in the -- referenced file. For the standard entity form, the name between -- the brackets is the normal name of the entity in lower case. - -- + -- There may be zero or more ref entries on each line - -- + -- file | line type col [...] - -- + -- file is the dependency number of the file with the reference. -- It and the following vertical bar are omitted if the file is -- the same as the previous ref, and the refs for the current -- file are first (and do not need a bar). - -- + + -- line is the line number of the reference + + -- col is the column number of the reference, as defined above. + -- type is one of - -- r = reference - -- m = modification -- b = body entity -- c = completion of private or incomplete type - -- x = type extension - -- i = implicit reference -- e = end of spec + -- i = implicit reference + -- l = label on end line + -- m = modification + -- p = primitive operation + -- r = reference -- t = end of body - -- + -- x = type extension + -- b is used for spec entities that are repeated in a body, -- including the unit (subprogram, package, task, protected -- body, protected entry) name itself, and in the case of a @@ -141,53 +152,72 @@ package Lib.Xref is -- are not considered to be definitions for cross-referencing -- purposes, but rather are considered to be references to the -- corresponding spec entities, marked with this special type. - -- - -- c is similarly used to mark the completion of a private or - -- incomplete type. Again, the completion is not regarded as - -- a separate definition, but rather a reference to the initial - -- declaration, marked with this special type. - -- - -- x is used to identify the reference as the entity from which - -- a tagged type is extended. This allows immediate access to - -- the parent of a tagged type. - -- - -- i is used to identify a reference to the entity in a generic - -- actual or in a default in a call. The node that denotes the - -- entity does not come from source, but it has the Sloc of the - -- source node that generates the implicit reference, and it is - -- useful to record this one. - -- + + -- c is similar to b but is used to mark the completion of a + -- private or incomplete type. As with b, the completion is not + -- regarded as a separate definition, but rather a reference to + -- the initial declaration, marked with this special type. + -- e is used to identify the end of a construct in the following -- cases: - -- + -- Block Statement end [block_IDENTIFIER]; -- Loop Statement end loop [loop_IDENTIFIER]; -- Package Specification end [[PARENT_UNIT_NAME .] IDENTIFIER]; -- Task Definition end [task_IDENTIFIER]; -- Protected Definition end [protected_IDENTIFIER]; -- Record Definition end record; - -- - -- Note that 'e' entries are special in that you get they appear - -- even in referencing units (normally xref entries appear only + -- Enumeration Definition ); + + -- Note that 'e' entries are special in that they appear even + -- in referencing units (normally xref entries appear only -- for references in the extended main source unit (see Lib) to -- which the ali applies. But 'e' entries are really structural -- and simply indicate where packages end. This information can -- be used to reconstruct scope information for any entities - -- referenced from within the package. - -- - -- t is similarly used to identify the end of a corresponding + -- referenced from within the package. The line/column values + -- for these entries point to the semicolon ending the construct. + + -- i is used to identify a reference to the entity in a generic + -- actual or in a default in a call. The node that denotes the + -- entity does not come from source, but it has the Sloc of the + -- source node that generates the implicit reference, and it is + -- useful to record this one. + + -- l is used to identify the occurrence in the source of the + -- name on an end line. This is just a syntactic reference + -- which can be ignored for semantic purposes (such as call + -- graph construction). Again, in the case of an accept there + -- can be multiple l lines. + + -- p is used to mark a primitive operation of the given entity. + -- For example, if we have a type Tx, and a primitive operation + -- Pq of this type, then an entry in the list of references to + -- Tx will point to the declaration of Pq. Note that this entry + -- type is unusual because it an implicit rather than explicit, + -- and the name of the refrerence does not match the name of the + -- entity for which a reference is generated. These entries are + -- generated only for entities declared in the extended main + -- source unit (main unit itself, its separate spec (if any). + -- and all subunits (considered recursively). + + -- t is similar to e. It identifies the end of a corresponding -- body (such a reference always links up with a b reference) - -- + -- Subprogram Body end [DESIGNATOR]; -- Package Body end [[PARENT_UNIT_NAME .] IDENTIFIER]; -- Task Body end [task_IDENTIFIER]; -- Entry Body end [entry_IDENTIFIER]; -- Protected Body end [protected_IDENTIFIER] -- Accept Statement end [entry_IDENTIFIER]]; - -- + -- Note that in the case of accept statements, there can - -- be multiple b and T/t entries for the same entity. - -- + -- be multiple b and t entries for the same entity. + + -- x is used to identify the reference as the entity from which + -- a tagged type is extended. This allows immediate access to + -- the parent of a tagged type. + -- [..] is used for generic instantiation references. These -- references are present only if the entity in question is -- a generic entity, and in that case the [..] contains the @@ -199,58 +229,58 @@ package Lib.Xref is -- of file numbers in such references follows the normal -- rules (present only if needed, and resets the current -- file for subsequent references). - -- + -- Examples: - -- + -- 44B5*Flag_Type{boolean} 5r23 6m45 3|9r35 11r56 - -- + -- This line gives references for the publicly visible Boolean -- type Flag_Type declared on line 44, column 5. There are four -- references - -- + -- a reference on line 5, column 23 of the current file - -- + -- a modification on line 6, column 45 of the current file - -- + -- a reference on line 9, column 35 of unit number 3 - -- + -- a reference on line 11, column 56 of unit number 3 - -- + -- 2U13 p3=2:35 5b13 8r4 12r13 12t15 - -- + -- This line gives references for the non-publicly visible -- procedure p3 declared on line 2, column 13. This procedure -- renames the procedure whose identifier reference is at -- line 2 column 35. There are four references: - -- + -- the corresponding body entity at line 5, column 13, -- of the current file. - -- + -- a reference (e.g. a call) at line 8 column 4 of the -- of the current file. - -- + -- the END line of the body has an explict reference to -- the name of the procedure at line 12, column 13. - -- + -- the body ends at line 12, column 15, just past this label. - -- + -- 16I9*My_Type<2|4I9> 18r8 - -- + -- This line gives references for the publicly visible Integer -- derived type My_Type declared on line 16, column 9. It also -- gives references to the parent type declared in the unit -- number 2 on line 4, column 9. There is one reference: - -- + -- a reference (e.g. a variable declaration) at line 18 column -- 4 of the current file. - -- + -- 10I3*Genv{integer} 3|4I10[6|12] - -- + -- This line gives a reference for the entity Genv in a generic -- package. The reference in file 3, line 4, col 10, refers to -- an instance of the generic where the instantiation can be -- found in file 6 at line 12. - -- + -- Continuation lines are used if the reference list gets too long, -- a continuation line starts with a period, and then has references -- continuing from the previous line. The references are sorted first @@ -439,15 +469,15 @@ package Lib.Xref is -- This procedure is called to record a reference. N is the location -- of the reference and E is the referenced entity. Typ is one of: -- - -- 'b' body entity (see below) + -- 'b' body entity -- 'c' completion of incomplete or private type (see below) - -- 'E' end of spec (label present) - -- 'e' end of spec (no label present) + -- 'e' end of construct -- 'i' implicit reference + -- 'l' label on end line -- 'm' modification + -- 'p' primitive operation -- 'r' standard reference - -- 'T' end of body (label present) - -- 't' end of body (no label present) + -- 't' end of body -- 'x' type extension -- ' ' dummy reference (see below) -- @@ -459,23 +489,29 @@ package Lib.Xref is -- for the spec. The entity in the body is treated as a reference -- with type 'b'. Similar handling for references to subprogram formals. -- - -- The call has no effect if N is not in the extended main source unit. - -- If N is in the extended main source unit, then the Is_Referenced - -- flag of E is set. In addition, if appropriate, a cross-reference - -- entry is made. The entry is made if: - -- - -- cross-reference collection is enabled - -- both entity and reference come from source (or Force is True) - -- the entity is one for which xrefs are appropriate - -- the type letter is non-blank - -- the node N is an identifier, defining identifier, or expanded name - -- - -- If all these conditions are met, then a cross-reference entry is - -- made for later output when Output_References is called. - -- - -- Note: the dummy entry is for the convenience of some callers, who - -- find it easier to pass a space to suppress the entry than to do a - -- specific test. The call has no effect if the type is a space. + -- The call has no effect if N is not in the extended main source unit + -- This check is omitted for type 'e' references (where it is useful to + -- have structural scoping information for other than the main source), + -- and for 'p' (since we want to pick up inherited primitive operations + -- that are defined in other packages). + -- + -- The call also has no effect if any of the following conditions hold: + -- + -- cross-reference collection is disabled + -- entity does not come from source (and Force is False) + -- reference does not come from source (and Force is False) + -- the entity is not one for which xrefs are appropriate + -- the type letter is blank + -- the node N is not an identifier, defining identifier, or expanded name + -- the type is 'p' and the entity is not in the extended main source + -- + -- If all these conditions are met, then the Is_Referenced flag of E + -- is set (unless Set_Ref is False) and a cross-reference entry is + -- recorded for later output when Output_References is called. + -- + -- Note: the dummy space entry is for the convenience of some callers, + -- who find it easier to pass a space to suppress the entry than to do + -- a specific test. The call has no effect if the type is a space. -- -- The parameter Set_Ref is normally True, and indicates that in -- addition to generating a cross-reference, the Referenced flag diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index 5b3ed4b0ce5..8d2ea918901 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -177,7 +177,7 @@ package body Lib is procedure Set_Fatal_Error (U : Unit_Number_Type; B : Boolean := True) is begin - Units.Table (U).Fatal_Error := True; + Units.Table (U).Fatal_Error := B; end Set_Fatal_Error; procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True) is @@ -397,6 +397,15 @@ package body Lib is end Check_Same_Extended_Unit; + ------------------------------- + -- Compilation_Switches_Last -- + ------------------------------- + + function Compilation_Switches_Last return Nat is + begin + return Compilation_Switches.Last; + end Compilation_Switches_Last; + ------------------------------ -- Earlier_In_Extended_Unit -- ------------------------------ @@ -474,7 +483,7 @@ package body Lib is return Main_Unit; end Get_Code_Unit; - function Get_Code_Unit (N : Node_Id) return Unit_Number_Type is + function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is begin return Get_Code_Unit (Sloc (N)); end Get_Code_Unit; @@ -485,7 +494,7 @@ package body Lib is function Get_Compilation_Switch (N : Pos) return String_Ptr is begin - if N >= Compilation_Switches.Last then + if N <= Compilation_Switches.Last then return Compilation_Switches.Table (N); else @@ -558,7 +567,7 @@ package body Lib is return Main_Unit; end Get_Source_Unit; - function Get_Source_Unit (N : Node_Id) return Unit_Number_Type is + function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is begin return Get_Source_Unit (Sloc (N)); end Get_Source_Unit; @@ -567,7 +576,10 @@ package body Lib is -- In_Extended_Main_Code_Unit -- -------------------------------- - function In_Extended_Main_Code_Unit (N : Node_Id) return Boolean is + function In_Extended_Main_Code_Unit + (N : Node_Or_Entity_Id) + return Boolean + is begin if Sloc (N) = Standard_Location then return True; @@ -599,7 +611,10 @@ package body Lib is -- In_Extended_Main_Source_Unit -- ---------------------------------- - function In_Extended_Main_Source_Unit (N : Node_Id) return Boolean is + function In_Extended_Main_Source_Unit + (N : Node_Or_Entity_Id) + return Boolean + is begin if Sloc (N) = Standard_Location then return True; @@ -767,10 +782,10 @@ package body Lib is begin if Match_String'Length > 0 then for J in 1 .. Linker_Option_Lines.Last loop - String_To_Name_Buffer (Linker_Option_Lines.Table (J)); + String_To_Name_Buffer (Linker_Option_Lines.Table (J).Option); if Match_String = Name_Buffer (1 .. Match_String'Length) then - Linker_Option_Lines.Table (J) := S; + Linker_Option_Lines.Table (J).Option := S; return; end if; end loop; @@ -803,7 +818,8 @@ package body Lib is procedure Store_Linker_Option_String (S : String_Id) is begin Linker_Option_Lines.Increment_Last; - Linker_Option_Lines.Table (Linker_Option_Lines.Last) := S; + Linker_Option_Lines.Table (Linker_Option_Lines.Last) := + (Option => S, Unit => Current_Sem_Unit); end Store_Linker_Option_String; --------------- diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index d14fa2d0cc2..006d5ae9b0b 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.100 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -425,7 +425,7 @@ package Lib is -- within generic instantiations return True if the instantiation is -- itself "in the main unit" by this definition. Otherwise False. - function Get_Source_Unit (N : Node_Id) return Unit_Number_Type; + function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type; pragma Inline (Get_Source_Unit); function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type; -- Return unit number of file identified by given source pointer value. @@ -436,7 +436,7 @@ package Lib is -- corresponding to the given Source_Ptr value. The version taking -- a Node_Id argument, N, simply applies the function to Sloc (N). - function Get_Code_Unit (N : Node_Id) return Unit_Number_Type; + function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type; pragma Inline (Get_Code_Unit); function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type; -- This is like Get_Source_Unit, except that in the instantiation case, @@ -463,7 +463,9 @@ package Lib is -- included). Returns true if S1 and S2 are in the same extended unit -- and False otherwise. - function In_Extended_Main_Code_Unit (N : Node_Id) return Boolean; + function In_Extended_Main_Code_Unit + (N : Node_Or_Entity_Id) + return Boolean; -- Return True if the node is in the generated code of the extended main -- unit, defined as the main unit, its specification (if any), and all -- its subunits (considered recursively). Units for which this enquiry @@ -472,7 +474,9 @@ package Lib is -- If the main unit is itself a subunit, then the extended main unit -- includes its parent unit, and the parent unit spec if it is separate. - function In_Extended_Main_Source_Unit (N : Node_Id) return Boolean; + function In_Extended_Main_Source_Unit + (N : Node_Or_Entity_Id) + return Boolean; -- Return True if the node is in the source text of the extended main -- unit, defined as the main unit, its specification (if any), and all -- its subunits (considered recursively). Units for which this enquiry @@ -488,9 +492,12 @@ package Lib is -- S2, and False otherwise. The result is undefined if S1 and S2 are -- not in the same extended unit. + function Compilation_Switches_Last return Nat; + -- Return the count of stored compilation switches + function Get_Compilation_Switch (N : Pos) return String_Ptr; -- Return the Nth stored compilation switch, or null if less than N - -- switches have been stored. Used by ASIS. + -- switches have been stored. Used by ASIS and back ends written in Ada. function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type; -- Return unit number of the unit whose N_Compilation_Unit node is the @@ -600,7 +607,7 @@ private Expected_Unit : Unit_Name_Type; Source_Index : Source_File_Index; Cunit : Node_Id; - Cunit_Entity : Node_Id; + Cunit_Entity : Entity_Id; Dependency_Num : Int; Dependent_Unit : Boolean; Fatal_Error : Boolean; @@ -625,8 +632,16 @@ private -- The following table stores strings from pragma Linker_Option lines + type Linker_Option_Entry is record + Option : String_Id; + -- The string for the linker option line + + Unit : Unit_Number_Type; + -- The unit from which the linker option comes + end record; + package Linker_Option_Lines is new Table.Table ( - Table_Component_Type => String_Id, + Table_Component_Type => Linker_Option_Entry, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => Alloc.Linker_Option_Lines_Initial, diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 500caf8a6e1..e46c54e836f 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.9 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -30,27 +30,27 @@ with Ada.Exceptions; use Ada.Exceptions; with Ada.Command_Line; use Ada.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with ALI; use ALI; -with ALI.Util; use ALI.Util; +with ALI; use ALI; +with ALI.Util; use ALI.Util; with Csets; with Debug; -with Fname; use Fname; -with Fname.SF; use Fname.SF; -with Fname.UF; use Fname.UF; -with Gnatvsn; use Gnatvsn; -with Hostparm; use Hostparm; +with Fname; use Fname; +with Fname.SF; use Fname.SF; +with Fname.UF; use Fname.UF; +with Gnatvsn; use Gnatvsn; +with Hostparm; use Hostparm; with Makeusg; with MLib.Prj; with MLib.Tgt; with MLib.Utl; -with Namet; use Namet; -with Opt; use Opt; -with Osint; use Osint; +with Namet; use Namet; +with Opt; use Opt; +with Osint.M; use Osint.M; +with Osint; use Osint; with Gnatvsn; -with Output; use Output; -with Prj; use Prj; +with Output; use Output; +with Prj; use Prj; with Prj.Com; with Prj.Env; with Prj.Ext; @@ -58,13 +58,13 @@ with Prj.Pars; with Prj.Util; with SFN_Scan; with Sinput.L; -with Snames; use Snames; -with Stringt; use Stringt; -with Table; -with Types; use Types; -with Switch; use Switch; +with Snames; use Snames; +with Stringt; use Stringt; +with Switch; use Switch; +with Switch.M; use Switch.M; +with Targparm; -with System.WCh_Con; use System.WCh_Con; +with System.WCh_Con; use System.WCh_Con; package body Make is @@ -193,6 +193,17 @@ package body Make is Table_Increment => 100, Table_Name => "Make.Saved_Make_Switches"); + package Switches_To_Check is new Table.Table ( + Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Make.Switches_To_Check"); + + Normalized_Switches : Argument_List_Access := new Argument_List (1 .. 10); + Last_Norm_Switch : Natural := 0; + Saved_Maximum_Processes : Natural := 0; Saved_WC_Encoding_Method : WC_Encoding_Method := WC_Encoding_Method'First; Saved_WC_Encoding_Method_Set : Boolean := False; @@ -238,23 +249,6 @@ package body Make is Table_Name => "Make.Bad_Compilation"); -- Full name of all the source files for which compilation fails. - type Special_Argument is record - File : String_Access; - Args : Argument_List_Access; - end record; - -- File is the name of the file for which a special set of compilation - -- arguments (Args) is required. - - package Special_Args is new Table.Table ( - Table_Component_Type => Special_Argument, - Table_Index_Type => Natural, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Make.Special_Args"); - -- Compilation arguments of all the source files for which an entry has - -- been found in the project file. - Original_Ada_Include_Path : constant String_Access := Getenv ("ADA_INCLUDE_PATH"); Original_Ada_Objects_Path : constant String_Access := @@ -283,9 +277,6 @@ package body Make is function Is_Marked (Source_File : File_Name_Type) return Boolean; -- Returns True if Source_File was previously marked. - procedure Unmark (Source_File : File_Name_Type); - -- Unmarks Source_File. - ------------------- -- Misc Routines -- ------------------- @@ -315,14 +306,22 @@ package body Make is -- after S1. S2 is printed last. Both N1 and N2 are printed in quotation -- marks. + Usage_Needed : Boolean := True; + -- Flag used to make sure Makeusg is call at most once + + procedure Usage; + -- Call Makeusg, if Usage_Needed is True. + -- Set Usage_Needed to False. + ----------------------- -- Gnatmake Routines -- ----------------------- subtype Lib_Mark_Type is Byte; + -- ??? this needs a comment - Ada_Lib_Dir : constant Lib_Mark_Type := 1; - GNAT_Lib_Dir : constant Lib_Mark_Type := 2; + Ada_Lib_Dir : constant Lib_Mark_Type := 1; + -- ??? this needs a comment -- Note that the notion of GNAT lib dir is no longer used. The code -- related to it has not been removed to give an idea on how to use @@ -352,11 +351,6 @@ package body Make is -- Get directory prefix of this file and get lib mark stored in name -- table for this directory. Then check if an Ada lib mark has been set. - procedure Mark_Dir_Path - (Path : String_Access; - Mark : Lib_Mark_Type); - -- Invoke Mark_Directory on each directory of the path. - procedure Mark_Directory (Dir : String; Mark : Lib_Mark_Type); @@ -388,14 +382,16 @@ package body Make is -- Return the switches for the source file in the specified package -- of a project file. If the Source_File ends with a standard GNAT -- extension (".ads" or ".adb"), try first the full name, then the - -- name without the extension. If there is no switches for either - -- names, try the default switches for Ada. If all failed, return - -- No_Variable_Value. + -- name without the extension, then, if Allow_ALI is True, the name with + -- the extension ".ali". If there is no switches for either names, try the + -- default switches for Ada. If all failed, return No_Variable_Value. - procedure Test_If_Relative_Path (Switch : String_Access); + procedure Test_If_Relative_Path + (Switch : in out String_Access; + Parent : String_Access); -- Test if Switch is a relative search path switch. - -- Fail if it is. This subprogram is only called - -- when using project files. + -- If it is, fail if Parent is null, otherwise prepend the path with + -- Parent. This subprogram is only called when using project files. procedure Set_Library_For (Project : Project_Id; @@ -442,6 +438,9 @@ package body Make is Object_Suffix : constant String := Get_Object_Suffix.all; Executable_Suffix : constant String := Get_Executable_Suffix.all; + Syntax_Only : Boolean := False; + -- Set to True when compiling with -gnats + Display_Executed_Programs : Boolean := True; -- Set to True if name of commands should be output on stderr. @@ -510,6 +509,20 @@ package body Make is -- Displays Program followed by the arguments in Args if variable -- Display_Executed_Programs is set. The lower bound of Args must be 1. + type Temp_File_Names is array (Positive range <>) of Temp_File_Name; + + type Temp_Files_Ptr is access Temp_File_Names; + + The_Mapping_File_Names : Temp_Files_Ptr; + Last_Mapping_File_Name : Natural := 0; + + procedure Delete_Mapping_Files; + -- Delete all temporary mapping files + + procedure Init_Mapping_File (File_Name : in out Temp_File_Name); + -- Create a new temporary mapping file, and fill it with the project file + -- mappings, when using project file(s) + -------------------- -- Add_Object_Dir -- -------------------- @@ -554,60 +567,55 @@ package body Make is is generic with package T is new Table.Table (<>); - procedure Generic_Position (New_Position : out Integer); - -- Generic procedure that allocates a position for S in T at the - -- beginning or the end, depending on the boolean Append_Switch. + function Generic_Position return Integer; + -- Generic procedure that adds S at the end or beginning of T depending + -- of the value of the boolean Append_Switch. ---------------------- -- Generic_Position -- ---------------------- - procedure Generic_Position (New_Position : out Integer) is + function Generic_Position return Integer is begin T.Increment_Last; if Append_Switch then - New_Position := Integer (T.Last); + return Integer (T.Last); else for J in reverse T.Table_Index_Type'Succ (T.First) .. T.Last loop T.Table (J) := T.Table (T.Table_Index_Type'Pred (J)); end loop; - New_Position := Integer (T.First); + return Integer (T.First); end if; end Generic_Position; - procedure Gcc_Switches_Pos is new Generic_Position (Gcc_Switches); - procedure Binder_Switches_Pos is new Generic_Position (Binder_Switches); - procedure Linker_Switches_Pos is new Generic_Position (Linker_Switches); + function Gcc_Switches_Pos is new Generic_Position (Gcc_Switches); + function Binder_Switches_Pos is new Generic_Position (Binder_Switches); + function Linker_Switches_Pos is new Generic_Position (Linker_Switches); - procedure Saved_Gcc_Switches_Pos is new + function Saved_Gcc_Switches_Pos is new Generic_Position (Saved_Gcc_Switches); - procedure Saved_Binder_Switches_Pos is new + function Saved_Binder_Switches_Pos is new Generic_Position (Saved_Binder_Switches); - procedure Saved_Linker_Switches_Pos is new + function Saved_Linker_Switches_Pos is new Generic_Position (Saved_Linker_Switches); - New_Position : Integer; - -- Start of processing for Add_Switch begin if And_Save then case Program is when Compiler => - Saved_Gcc_Switches_Pos (New_Position); - Saved_Gcc_Switches.Table (New_Position) := S; + Saved_Gcc_Switches.Table (Saved_Gcc_Switches_Pos) := S; when Binder => - Saved_Binder_Switches_Pos (New_Position); - Saved_Binder_Switches.Table (New_Position) := S; + Saved_Binder_Switches.Table (Saved_Binder_Switches_Pos) := S; when Linker => - Saved_Linker_Switches_Pos (New_Position); - Saved_Linker_Switches.Table (New_Position) := S; + Saved_Linker_Switches.Table (Saved_Linker_Switches_Pos) := S; when None => raise Program_Error; @@ -616,16 +624,13 @@ package body Make is else case Program is when Compiler => - Gcc_Switches_Pos (New_Position); - Gcc_Switches.Table (New_Position) := S; + Gcc_Switches.Table (Gcc_Switches_Pos) := S; when Binder => - Binder_Switches_Pos (New_Position); - Binder_Switches.Table (New_Position) := S; + Binder_Switches.Table (Binder_Switches_Pos) := S; when Linker => - Linker_Switches_Pos (New_Position); - Linker_Switches.Table (New_Position) := S; + Linker_Switches.Table (Linker_Switches_Pos) := S; when None => raise Program_Error; @@ -754,6 +759,8 @@ package body Make is Bind_Last := Bind_Last + 1; Bind_Args (Bind_Last) := new String'(Name_Buffer (1 .. Name_Len)); + GNAT.OS_Lib.Normalize_Arguments (Bind_Args (Args'First .. Bind_Last)); + Display (Gnatbind.all, Bind_Args (Args'First .. Bind_Last)); if Gnatbind_Path = null then @@ -918,9 +925,6 @@ package body Make is Num_Args : Integer; -- Number of compiler arguments processed - Special_Arg : Argument_List_Access; - -- Special arguments if any of a given compilation file - -- Start of processing for Check begin @@ -990,114 +994,71 @@ package body Make is Get_Name_String (ALIs.Table (ALI).Sfile); - for J in 1 .. Special_Args.Last loop - if Special_Args.Table (J).File.all = - Name_Buffer (1 .. Name_Len) + Switches_To_Check.Set_Last (0); + + for J in Gcc_Switches.First .. Gcc_Switches.Last loop + + -- Skip non switches, -I and -o switches + + if Gcc_Switches.Table (J) (1) = '-' + and then Gcc_Switches.Table (J) (2) /= 'o' + and then Gcc_Switches.Table (J) (2) /= 'I' then - Special_Arg := Special_Args.Table (J).Args; - exit; + Normalize_Compiler_Switches + (Gcc_Switches.Table (J).all, + Normalized_Switches, + Last_Norm_Switch); + + for K in 1 .. Last_Norm_Switch loop + Switches_To_Check.Increment_Last; + Switches_To_Check.Table (Switches_To_Check.Last) := + Normalized_Switches (K); + end loop; end if; end loop; - if Main_Project /= No_Project then - null; - end if; - - if Special_Arg = null then - for J in Gcc_Switches.First .. Gcc_Switches.Last loop - - -- Skip non switches, -I and -o switches + for J in 1 .. Switches_To_Check.Last loop - if (Gcc_Switches.Table (J) (1) = '-' - or else - Gcc_Switches.Table (J) (1) = Switch_Character) - and then Gcc_Switches.Table (J) (2) /= 'o' - and then Gcc_Switches.Table (J) (2) /= 'I' - then - Num_Args := Num_Args + 1; - - -- Comparing switches is delicate because gcc reorders - -- a number of switches, according to lang-specs.h, but - -- gnatmake doesn't have the sufficient knowledge to - -- perform the same reordering. Instead, we ignore orders - -- between different "first letter" switches, but keep - -- orders between same switches, e.g -O -O2 is different - -- than -O2 -O, but -g -O is equivalent to -O -g. - - if Gcc_Switches.Table (J) (2) /= Prev_Switch then - Prev_Switch := Gcc_Switches.Table (J) (2); - Arg := - Units.Table (ALIs.Table (ALI).First_Unit).First_Arg; - end if; + -- Comparing switches is delicate because gcc reorders + -- a number of switches, according to lang-specs.h, but + -- gnatmake doesn't have the sufficient knowledge to + -- perform the same reordering. Instead, we ignore orders + -- between different "first letter" switches, but keep + -- orders between same switches, e.g -O -O2 is different + -- than -O2 -O, but -g -O is equivalent to -O -g. - Switch_Found := False; + if Switches_To_Check.Table (J) (2) /= Prev_Switch then + Prev_Switch := Switches_To_Check.Table (J) (2); + Arg := + Units.Table (ALIs.Table (ALI).First_Unit).First_Arg; + end if; - for K in Arg .. - Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg - loop - if Gcc_Switches.Table (J).all = Args.Table (K).all then - Arg := K + 1; - Switch_Found := True; - exit; - end if; - end loop; + Switch_Found := False; - if not Switch_Found then - if Opt.Verbose_Mode then - Verbose_Msg (ALIs.Table (ALI).Sfile, - "switch mismatch"); - end if; + for K in Arg .. + Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg + loop + Num_Args := Num_Args + 1; - ALI := No_ALI_Id; - return; - end if; + if + Switches_To_Check.Table (J).all = Args.Table (K).all + then + Arg := K + 1; + Switch_Found := True; + exit; end if; end loop; - -- Special_Arg is non-null - - else - for J in Special_Arg'Range loop - - -- Skip non switches, -I and -o switches - - if (Special_Arg (J) (1) = '-' - or else Special_Arg (J) (1) = Switch_Character) - and then Special_Arg (J) (2) /= 'o' - and then Special_Arg (J) (2) /= 'I' - then - Num_Args := Num_Args + 1; - - if Special_Arg (J) (2) /= Prev_Switch then - Prev_Switch := Special_Arg (J) (2); - Arg := - Units.Table (ALIs.Table (ALI).First_Unit).First_Arg; - end if; - - Switch_Found := False; - - for K in Arg .. - Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg - loop - if Special_Arg (J).all = Args.Table (K).all then - Arg := K + 1; - Switch_Found := True; - exit; - end if; - end loop; - - if not Switch_Found then - if Opt.Verbose_Mode then - Verbose_Msg (ALIs.Table (ALI).Sfile, - "switch mismatch"); - end if; - - ALI := No_ALI_Id; - return; - end if; + if not Switch_Found then + if Opt.Verbose_Mode then + Verbose_Msg (ALIs.Table (ALI).Sfile, + "switch mismatch"); end if; - end loop; - end if; + + ALI := No_ALI_Id; + return; + end if; + end loop; if Num_Args /= Integer (Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg - @@ -1199,9 +1160,8 @@ package body Make is if Name_Len <= 0 then return; - elsif Name_Buffer (1) = Get_Switch_Character - or else Name_Buffer (1) = '-' - then + elsif Name_Buffer (1) = '-' then + -- Do not check if File is a switch other than "-l" if Name_Buffer (2) /= 'l' then @@ -1350,11 +1310,16 @@ package body Make is -- expected library file name. Process_Id of the process spawned to -- execute the compile. + No_Mapping_File : constant Temp_File_Name := (others => ' '); + type Compilation_Data is record Pid : Process_Id; Full_Source_File : File_Name_Type; Lib_File : File_Name_Type; Source_Unit : Unit_Name_Type; + Mapping_File : Temp_File_Name := No_Mapping_File; + Use_Mapping_File : Boolean := False; + Syntax_Only : Boolean := False; end record; Running_Compile : array (1 .. Max_Process) of Compilation_Data; @@ -1396,6 +1361,8 @@ package body Make is Pid : Process_Id; Text : Text_Buffer_Ptr; + Mfile : Temp_File_Name := No_Mapping_File; + Data : Prj.Project_Data; Arg_Index : Natural; @@ -1403,11 +1370,17 @@ package body Make is Need_To_Check_Standard_Library : Boolean := Check_Readonly_Files; + Mapping_File_Arg : constant String_Access := new String' + (1 => '-', 2 => 'g', 3 => 'n', 4 => 'a', 5 => 't', 6 => 'e', 7 => 'm', + 8 .. 7 + Mfile'Length => ' '); + procedure Add_Process - (Pid : Process_Id; - Sfile : File_Name_Type; - Afile : File_Name_Type; - Uname : Unit_Name_Type); + (Pid : Process_Id; + Sfile : File_Name_Type; + Afile : File_Name_Type; + Uname : Unit_Name_Type; + Mfile : Temp_File_Name := No_Mapping_File; + UMfile : Boolean := False); -- Adds process Pid to the current list of outstanding compilation -- processes and record the full name of the source file Sfile that -- we are compiling, the name of its library file Afile and the @@ -1427,7 +1400,7 @@ package body Make is -- resp. No_File, No_File and No_Name if there were no compilations -- to wait for. - procedure Collect_Arguments_And_Compile; + procedure Collect_Arguments_And_Compile (Source_File : File_Name_Type); -- Collect arguments from project file (if any) and compile package Good_ALI is new Table.Table ( @@ -1469,15 +1442,21 @@ package body Make is -- pragmas file to be specified for For_Project, -- otherwise return an empty argument list. + procedure Get_Mapping_File; + -- Get a mapping file name. If there is one to be reused, reuse it. + -- Otherwise, create a new mapping file. + ----------------- -- Add_Process -- ----------------- procedure Add_Process - (Pid : Process_Id; - Sfile : File_Name_Type; - Afile : File_Name_Type; - Uname : Unit_Name_Type) + (Pid : Process_Id; + Sfile : File_Name_Type; + Afile : File_Name_Type; + Uname : Unit_Name_Type; + Mfile : Temp_File_Name := No_Mapping_File; + UMfile : Boolean := False) is OC1 : constant Positive := Outstanding_Compiles + 1; @@ -1489,6 +1468,9 @@ package body Make is Running_Compile (OC1).Full_Source_File := Sfile; Running_Compile (OC1).Lib_File := Afile; Running_Compile (OC1).Source_Unit := Uname; + Running_Compile (OC1).Mapping_File := Mfile; + Running_Compile (OC1).Use_Mapping_File := UMfile; + Running_Compile (OC1).Syntax_Only := Syntax_Only; Outstanding_Compiles := OC1; end Add_Process; @@ -1524,6 +1506,16 @@ package body Make is Sfile := Running_Compile (J).Full_Source_File; Afile := Running_Compile (J).Lib_File; Uname := Running_Compile (J).Source_Unit; + Syntax_Only := Running_Compile (J).Syntax_Only; + + -- If a mapping file was used by this compilation, + -- get its file name for reuse by a subsequent compilation + + if Running_Compile (J).Use_Mapping_File then + Last_Mapping_File_Name := Last_Mapping_File_Name + 1; + The_Mapping_File_Names (Last_Mapping_File_Name) := + Running_Compile (J).Mapping_File; + end if; -- To actually remove this Pid and related info from -- Running_Compile replace its entry with the last valid @@ -1558,8 +1550,15 @@ package body Make is -- Collect_Arguments_And_Compile -- ----------------------------------- - procedure Collect_Arguments_And_Compile is + procedure Collect_Arguments_And_Compile (Source_File : File_Name_Type) is begin + + -- If we use mapping file (-P or -C switches), then get one + + if Create_Mapping_File then + Get_Mapping_File; + end if; + -- If no project file is used, then just call Compile with -- the specified Args. @@ -1579,7 +1578,7 @@ package body Make is declare Source_File_Name : constant String := - Name_Buffer (1 .. Name_Len); + Get_Name_String (Source_File); Current_Project : Prj.Project_Id; Path_Name : File_Name_Type := Source_File; Compiler_Package : Prj.Package_Id; @@ -1741,7 +1740,8 @@ package body Make is String_To_Name_Buffer (Element.Value); New_Args (Index) := new String' (Name_Buffer (1 .. Name_Len)); - Test_If_Relative_Path (New_Args (Index)); + Test_If_Relative_Path + (New_Args (Index), Parent => null); Current := Element.Next; end loop; @@ -1759,15 +1759,16 @@ package body Make is -- this switch, plus the saved gcc switches. when Single => - String_To_Name_Buffer (Switches.Value); + declare - New_Args : constant Argument_List := + New_Args : Argument_List := (1 => new String' (Name_Buffer (1 .. Name_Len))); begin - Test_If_Relative_Path (New_Args (1)); + Test_If_Relative_Path + (New_Args (1), Parent => null); Pid := Compile (Path_Name, Lib_File, @@ -1792,8 +1793,8 @@ package body Make is (Path_Name, Lib_File, Args & Output_Flag & Object_File & - Configuration_Pragmas_Switch (Current_Project) & - The_Saved_Gcc_Switches.all); + Configuration_Pragmas_Switch (Current_Project) & + The_Saved_Gcc_Switches.all); end case; end if; end; @@ -1807,7 +1808,7 @@ package body Make is function Compile (S : Name_Id; L : Name_Id; Args : Argument_List) return Process_Id is - Comp_Args : Argument_List (Args'First .. Args'Last + 7); + Comp_Args : Argument_List (Args'First .. Args'Last + 8); Comp_Next : Integer := Args'First; Comp_Last : Integer; @@ -1833,6 +1834,34 @@ package body Make is -- Start of processing for Compile begin + -- By default, Syntax_Only is False + + Syntax_Only := False; + + for J in Args'Range loop + if Args (J).all = "-gnats" then + + -- If we compile with -gnats, the bind step and the link step + -- are inhibited. Also, we set Syntax_Only to True, so that + -- we don't fail when we don't find the ALI file, after + -- compilation. + + Do_Bind_Step := False; + Do_Link_Step := False; + Syntax_Only := True; + + elsif Args (J).all = "-gnatc" then + + -- If we compile with -gnatc, the bind step and the link step + -- are inhibited. We set Syntax_Only to True for the case when + -- -gnats was previously specified. + + Do_Bind_Step := False; + Do_Link_Step := False; + Syntax_Only := False; + end if; + end loop; + Comp_Args (Comp_Next) := Comp_Flag; Comp_Next := Comp_Next + 1; @@ -1906,11 +1935,18 @@ package body Make is Comp_Args (Comp_Last) := new String'(Name_Buffer (1 .. Name_Len)); end if; + if Create_Mapping_File then + Comp_Last := Comp_Last + 1; + Comp_Args (Comp_Last) := Mapping_File_Arg; + end if; + Get_Name_String (S); Comp_Last := Comp_Last + 1; Comp_Args (Comp_Last) := new String'(Name_Buffer (1 .. Name_Len)); + GNAT.OS_Lib.Normalize_Arguments (Comp_Args (Args'First .. Comp_Last)); + Display (Gcc.all, Comp_Args (Args'First .. Comp_Last)); if Gcc_Path = null then @@ -1959,6 +1995,31 @@ package body Make is end if; end Debug_Msg; + ---------------------- + -- Get_Mapping_File -- + ---------------------- + + procedure Get_Mapping_File is + begin + -- If there is a mapping file ready to be reused, reuse it + + if Last_Mapping_File_Name > 0 then + Mfile := The_Mapping_File_Names (Last_Mapping_File_Name); + Last_Mapping_File_Name := Last_Mapping_File_Name - 1; + + -- Otherwise, create and initialize a new one + + else + Init_Mapping_File (File_Name => Mfile); + end if; + + -- Put the name in the mapping file argument for the invocation + -- of the compiler. + + Mapping_File_Arg (8 .. Mapping_File_Arg'Last) := Mfile; + + end Get_Mapping_File; + ----------------------- -- Get_Next_Good_ALI -- ----------------------- @@ -2014,7 +2075,6 @@ package body Make is -- Package and Queue initializations. Good_ALI.Init; - Bad_Compilation.Init; Output.Set_Standard_Error; Init_Q; @@ -2188,12 +2248,11 @@ package body Make is -- Check for special compilation flags Arg_Index := 0; - Get_Name_String (Source_File); -- Start the compilation and record it. We can do this -- because there is at least one free process. - Collect_Arguments_And_Compile; + Collect_Arguments_And_Compile (Source_File); -- Make sure we could successfully start the compilation @@ -2201,7 +2260,12 @@ package body Make is Record_Failure (Full_Source_File, Source_Unit); else Add_Process - (Pid, Full_Source_File, Lib_File, Source_Unit); + (Pid, + Full_Source_File, + Lib_File, + Source_Unit, + Mfile, + Create_Mapping_File); end if; end if; end if; @@ -2222,11 +2286,28 @@ package body Make is if not Compilation_OK then Record_Failure (Full_Source_File, Source_Unit); + end if; + + if Compilation_OK or else Keep_Going then - else -- Re-read the updated library file - Text := Read_Library_Info (Lib_File); + declare + Saved_Object_Consistency : constant Boolean := + Opt.Check_Object_Consistency; + + begin + -- If compilation was not OK, don't check object + -- consistency. + + Opt.Check_Object_Consistency := + Opt.Check_Object_Consistency and Compilation_OK; + Text := Read_Library_Info (Lib_File); + + -- Restore Check_Object_Consistency to its initial value + + Opt.Check_Object_Consistency := Saved_Object_Consistency; + end; -- If no ALI file was generated by this compilation nothing -- more to do, otherwise scan the ali file and record it. @@ -2238,9 +2319,15 @@ package body Make is Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True); if ALI = No_ALI_Id then - Inform - (Lib_File, "incompatible ALI file, please recompile"); - Record_Failure (Full_Source_File, Source_Unit); + + -- Record a failure only if not already done + + if Compilation_OK then + Inform + (Lib_File, + "incompatible ALI file, please recompile"); + Record_Failure (Full_Source_File, Source_Unit); + end if; else Free (Text); Record_Good_ALI (ALI); @@ -2252,12 +2339,15 @@ package body Make is -- is set Read_Library_Info checks that the time stamp of the -- object file is more recent than that of the ALI). For an -- example of problems caught by this test see [6625-009]. + -- However, we record a failure only if not already done. else - Inform - (Lib_File, - "WARNING: ALI or object file not found after compile"); - Record_Failure (Full_Source_File, Source_Unit); + if Compilation_OK and not Syntax_Only then + Inform + (Lib_File, + "WARNING: ALI or object file not found after compile"); + Record_Failure (Full_Source_File, Source_Unit); + end if; end if; end if; end if; @@ -2296,7 +2386,8 @@ package body Make is if not ALIs.Table (ALI).No_Run_Time then declare - Sfile : Name_Id; + Sfile : Name_Id; + Add_It : Boolean := True; begin Name_Len := Standard_Library_Package_Body_Name'Length; @@ -2304,7 +2395,14 @@ package body Make is Standard_Library_Package_Body_Name; Sfile := Name_Enter; - if not Is_Marked (Sfile) then + -- If we have a special runtime, we add the standard + -- library only if we can find it. + + if Opt.RTS_Switch then + Add_It := Find_File (Sfile, Osint.Source) /= No_File; + end if; + + if Add_It and then not Is_Marked (Sfile) then Insert_Q (Sfile); Mark (Sfile); end if; @@ -2394,6 +2492,20 @@ package body Make is end if; end Compile_Sources; + -------------------------- + -- Delete_Mapping_Files -- + -------------------------- + + procedure Delete_Mapping_Files is + Success : Boolean; + + begin + for Index in 1 .. Last_Mapping_File_Name loop + Delete_File + (Name => The_Mapping_File_Names (Index), Success => Success); + end loop; + end Delete_Mapping_Files; + ------------- -- Display -- ------------- @@ -2406,8 +2518,18 @@ package body Make is Write_Str (Program); for J in Args'Range loop - Write_Str (" "); - Write_Str (Args (J).all); + + -- Do not display the mapping file argument automatically + -- created when using a project file. + + if Main_Project = No_Project + or else Args (J)'Length /= 7 + Temp_File_Name'Length + or else Args (J)'First /= 1 + or else Args (J)(1 .. 7) /= "-gnatem" + then + Write_Str (" "); + Write_Str (Args (J).all); + end if; end loop; Write_Eol; @@ -2496,6 +2618,8 @@ package body Make is Compilation_Failures : Natural; + Total_Compilation_Failures : Natural := 0; + Is_Main_Unit : Boolean; -- Set to True by Compile_Sources if the Main_Source_File can be a -- main unit. @@ -2506,7 +2630,7 @@ package body Make is Executable : File_Name_Type := No_File; -- The file name of an executable - Non_Std_Executable : Boolean := False; + Non_Std_Executable : Boolean := False; -- Non_Std_Executable is set to True when there is a possibility -- that the linker will not choose the correct executable file name. @@ -2516,9 +2640,10 @@ package body Make is -- be rebuild (if we rebuild mains), even in the case when it is not -- really necessary, because it is too hard to decide. - Mapping_File_Name : Temp_File_Name; - -- The name of the temporary mapping file that is copmmunicated - -- to the compiler through a -gnatem switch, when using project files. + Current_Work_Dir : constant String_Access := + new String'(Get_Current_Dir); + -- The current working directory, used to modify some relative path + -- switches on the command line when a project file is used. begin Do_Compile_Step := True; @@ -2539,10 +2664,17 @@ package body Make is end if; if Opt.Verbose_Mode then + Targparm.Get_Target_Parameters; + Write_Eol; Write_Str ("GNATMAKE "); + + if Targparm.High_Integrity_Mode_On_Target then + Write_Str ("Pro High Integrity "); + end if; + Write_Str (Gnatvsn.Gnat_Version_String); - Write_Str (" Copyright 1995-2001 Free Software Foundation, Inc."); + Write_Str (" Copyright 1995-2002 Free Software Foundation, Inc."); Write_Eol; end if; @@ -2578,6 +2710,10 @@ package body Make is Do_Bind_Step := False; Do_Link_Step := False; + -- Set Unique_Compile if it was not already set + + Unique_Compile := True; + -- Put all the sources in the queue Insert_Project_Sources @@ -2608,7 +2744,7 @@ package body Make is end if; - -- If -l was specified behave as if -n was specified + -- If -M was specified, behave as if -n was specified if Opt.List_Dependencies then Opt.Do_Not_Execute := True; @@ -2830,6 +2966,43 @@ package body Make is Display_Commands (not Opt.Quiet_Output); + -- If we are using a project file, relative paths are forbidden in the + -- project file, but we add the current working directory for any + -- relative path on the command line. + + if Main_Project /= No_Project then + + for J in 1 .. Binder_Switches.Last loop + Test_If_Relative_Path + (Binder_Switches.Table (J), Parent => null); + end loop; + + for J in 1 .. Saved_Binder_Switches.Last loop + Test_If_Relative_Path + (Saved_Binder_Switches.Table (J), Parent => Current_Work_Dir); + end loop; + + for J in 1 .. Linker_Switches.Last loop + Test_If_Relative_Path + (Linker_Switches.Table (J), Parent => null); + end loop; + + for J in 1 .. Saved_Linker_Switches.Last loop + Test_If_Relative_Path + (Saved_Linker_Switches.Table (J), Parent => Current_Work_Dir); + end loop; + + for J in 1 .. Gcc_Switches.Last loop + Test_If_Relative_Path + (Gcc_Switches.Table (J), Parent => null); + end loop; + + for J in 1 .. Saved_Gcc_Switches.Last loop + Test_If_Relative_Path + (Saved_Gcc_Switches.Table (J), Parent => Current_Work_Dir); + end loop; + end if; + -- We now put in the Binder_Switches and Linker_Switches tables, -- the binder and linker switches of the command line that have been -- put in the Saved_ tables. If a project file was used, then the @@ -2866,39 +3039,16 @@ package body Make is -- in procedure Compile_Sources. The_Saved_Gcc_Switches := - new Argument_List (1 .. Saved_Gcc_Switches.Last + 2); + new Argument_List (1 .. Saved_Gcc_Switches.Last + 1); for J in 1 .. Saved_Gcc_Switches.Last loop The_Saved_Gcc_Switches (J) := Saved_Gcc_Switches.Table (J); - Test_If_Relative_Path (The_Saved_Gcc_Switches (J)); end loop; -- We never use gnat.adc when a project file is used - The_Saved_Gcc_Switches (The_Saved_Gcc_Switches'Last - 1) := - No_gnat_adc; - - -- Create a temporary mapping file and add the switch -gnatem - -- with its name to the compiler. - - Prj.Env.Create_Mapping_File (Name => Mapping_File_Name); The_Saved_Gcc_Switches (The_Saved_Gcc_Switches'Last) := - new String'("-gnatem" & Mapping_File_Name); - - -- Check if there are any relative search paths in the switches. - -- Fail if there is one. - - for J in 1 .. Gcc_Switches.Last loop - Test_If_Relative_Path (Gcc_Switches.Table (J)); - end loop; - - for J in 1 .. Binder_Switches.Last loop - Test_If_Relative_Path (Binder_Switches.Table (J)); - end loop; - - for J in 1 .. Linker_Switches.Last loop - Test_If_Relative_Path (Linker_Switches.Table (J)); - end loop; + No_gnat_adc; end if; @@ -2930,6 +3080,12 @@ package body Make is Saved_Maximum_Processes := Opt.Maximum_Processes; end if; + -- Allocate as many temporary mapping file names as the maximum + -- number of compilation processed. + + The_Mapping_File_Names := + new Temp_File_Names (1 .. Saved_Maximum_Processes); + -- If either -c, -b or -l has been specified, we will not necessarily -- execute all steps. @@ -2945,6 +3101,8 @@ package body Make is end if; end if; + Bad_Compilation.Init; + -- Here is where the make process is started -- We do the same process for each main @@ -3137,9 +3295,17 @@ package body Make is Write_Eol; end if; - if Compilation_Failures /= 0 then - List_Bad_Compilations; - raise Compilation_Failed; + Total_Compilation_Failures := + Total_Compilation_Failures + Compilation_Failures; + + if Total_Compilation_Failures /= 0 then + if Opt.Keep_Going then + goto Next_Main; + + else + List_Bad_Compilations; + raise Compilation_Failed; + end if; end if; -- Regenerate libraries, if any and if object files @@ -3192,7 +3358,7 @@ package body Make is -- 1) -n (Do_Not_Execute) specified - -- 2) -l (List_Dependencies) specified (also sets + -- 2) -M (List_Dependencies) specified (also sets -- Do_Not_Execute above, so this is probably superfluous). -- 3) -c (Compile_Only) specified, but not -b (Bind_Only) @@ -3499,31 +3665,33 @@ package body Make is end if; end loop Multiple_Main_Loop; + if Total_Compilation_Failures /= 0 then + List_Bad_Compilations; + raise Compilation_Failed; + end if; + -- Delete the temporary mapping file that was created if we are -- using project files. - if Main_Project /= No_Project then - declare - Success : Boolean; - - begin - Delete_File (Name => Mapping_File_Name, Success => Success); - end; - end if; + Delete_Mapping_Files; Exit_Program (E_Success); exception when Bind_Failed => + Delete_Mapping_Files; Osint.Fail ("*** bind failed."); when Compilation_Failed => + Delete_Mapping_Files; Exit_Program (E_Fatal); when Link_Failed => + Delete_Mapping_Files; Osint.Fail ("*** link failed."); when X : others => + Delete_Mapping_Files; Write_Line (Exception_Information (X)); Osint.Fail ("INTERNAL ERROR. Please report."); @@ -3561,6 +3729,27 @@ package body Make is Write_Eol; end Inform; + ----------------------- + -- Init_Mapping_File -- + ----------------------- + + procedure Init_Mapping_File (File_Name : in out Temp_File_Name) is + FD : File_Descriptor; + begin + if Main_Project /= No_Project then + Prj.Env.Create_Mapping_File (File_Name); + + else + Create_Temp_File (FD, File_Name); + + if FD = Invalid_FD then + Fail ("disk full"); + end if; + + Close (FD); + end if; + end Init_Mapping_File; + ------------ -- Init_Q -- ------------ @@ -3590,7 +3779,6 @@ package body Make is -- Package initializations. The order of calls is important here. Output.Set_Standard_Error; - Osint.Initialize (Osint.Make); Gcc_Switches.Init; Binder_Switches.Init; @@ -3867,6 +4055,8 @@ package body Make is Get_Name_String (ALI_File); Link_Args (Args'Last + 1) := new String'(Name_Buffer (1 .. Name_Len)); + GNAT.OS_Lib.Normalize_Arguments (Link_Args); + Display (Gnatlink.all, Link_Args); if Gnatlink_Path = null then @@ -3973,28 +4163,6 @@ package body Make is Set_Name_Table_Byte (Source_File, 1); end Mark; - ------------------- - -- Mark_Dir_Path -- - ------------------- - - procedure Mark_Dir_Path - (Path : String_Access; - Mark : Lib_Mark_Type) - is - Dir : String_Access; - - begin - if Path /= null then - Osint.Get_Next_Dir_In_Path_Init (Path); - - loop - Dir := Osint.Get_Next_Dir_In_Path (Path); - exit when Dir = null; - Mark_Directory (Dir.all, Mark); - end loop; - end if; - end Mark_Dir_Path; - -------------------- -- Mark_Directory -- -------------------- @@ -4029,19 +4197,20 @@ package body Make is ---------------------- function Object_File_Name (Source : String) return String is - Pos : Natural := Source'Last; - begin - while Pos >= Source'First and then - Source (Pos) /= '.' loop - Pos := Pos - 1; + -- If the source name has an extension, then replace it with + -- the object suffix. + + for Index in reverse Source'First + 1 .. Source'Last loop + if Source (Index) = '.' then + return Source (Source'First .. Index - 1) & Object_Suffix; + end if; end loop; - if Pos >= Source'First then - Pos := Pos - 1; - end if; + -- If there is no dot, or if it is the first character, just add the + -- object suffix. - return Source (Source'First .. Pos) & Object_Suffix; + return Source & Object_Suffix; end Object_File_Name; ------------------- @@ -4063,8 +4232,9 @@ package body Make is if Opt.Output_File_Name_Present and then not Output_File_Name_Seen then Output_File_Name_Seen := True; - if Argv (1) = Switch_Character or else Argv (1) = '-' then + if Argv (1) = '-' then Fail ("output file name missing after -o"); + else Add_Switch ("-o", Linker, And_Save => And_Save); @@ -4084,12 +4254,13 @@ package body Make is end if; end if; - -- Then check if we are dealing with a -cargs, -bargs or -largs + -- Then check if we are dealing with -cargs/-bargs/-largs - elsif (Argv (1) = Switch_Character or else Argv (1) = '-') - and then (Argv (2 .. Argv'Last) = "cargs" - or else Argv (2 .. Argv'Last) = "bargs" - or else Argv (2 .. Argv'Last) = "largs") + elsif Argv = "-bargs" + or else + Argv = "-cargs" + or else + Argv = "-largs" then if not File_Name_Seen then Fail ("-cargs, -bargs, -largs ", @@ -4110,8 +4281,7 @@ package body Make is -- executable. elsif Program_Args = Linker - and then (Argv (1) = Switch_Character or else Argv (1) = '-') - and then Argv (2 .. Argv'Last) = "o" + and then Argv = "-o" then Fail ("switch -o not allowed within a -largs. Use -o directly."); @@ -4141,7 +4311,7 @@ package body Make is Add_Switch (Argv, Program_Args, And_Save => And_Save); - -- Handle non-default compiler, binder, linker + -- Handle non-default compiler, binder, linker, and handle --RTS switch elsif Argv'Length > 2 and then Argv (1 .. 2) = "--" then if Argv'Length > 6 @@ -4207,13 +4377,60 @@ package body Make is end loop; end; + elsif Argv'Length >= 5 and then + Argv (1 .. 5) = "--RTS" + then + Add_Switch (Argv, Compiler, And_Save => And_Save); + Add_Switch (Argv, Binder, And_Save => And_Save); + + if Argv'Length <= 6 or else Argv (6) /= '=' then + Osint.Fail ("missing path for --RTS"); + + else + -- Valid --RTS switch + + Opt.No_Stdinc := True; + Opt.No_Stdlib := True; + Opt.RTS_Switch := True; + + declare + Src_Path_Name : String_Ptr := + Get_RTS_Search_Dir + (Argv (7 .. Argv'Last), Include); + Lib_Path_Name : String_Ptr := + Get_RTS_Search_Dir + (Argv (7 .. Argv'Last), Objects); + + begin + if Src_Path_Name /= null and then + Lib_Path_Name /= null + then + Add_Search_Dirs (Src_Path_Name, Include); + Add_Search_Dirs (Lib_Path_Name, Objects); + + elsif Src_Path_Name = null + and Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude and adalib directories"); + + elsif Src_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude directory"); + + elsif Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adalib directory"); + end if; + end; + end if; + else Fail ("unknown switch: ", Argv); end if; -- If we have seen a regular switch process it - elsif Argv (1) = Switch_Character or else Argv (1) = '-' then + elsif Argv (1) = '-' then if Argv'Length = 1 then Fail ("switch character cannot be followed by a blank"); @@ -4401,11 +4618,10 @@ package body Make is null; -- If -gnath is present, then generate the usage information - -- right now for the compiler, and do not pass this option - -- on to the compiler calls. + -- right now and do not pass this option on to the compiler calls. elsif Argv = "-gnath" then - null; + Usage; -- If -gnatc is specified, make sure the bind step and the link -- step are not executed. @@ -4440,11 +4656,12 @@ package body Make is -- By default all switches with more than one character -- or one character switches which are not in 'a' .. 'z' - -- (except 'M') are passed to the compiler, unless we are dealing - -- with a debug switch (starts with 'd') + -- (except 'C' and 'M') are passed to the compiler, unless we are + -- dealing with a debug switch (starts with 'd') elsif Argv (2) /= 'd' and then Argv (2 .. Argv'Last) /= "M" + and then Argv (2 .. Argv'Last) /= "C" and then (Argv'Length > 2 or else Argv (2) not in 'a' .. 'z') then Add_Switch (Argv, Compiler, And_Save => And_Save); @@ -4459,7 +4676,7 @@ package body Make is else File_Name_Seen := True; - Set_Main_File_Name (Argv); + Add_File (Argv); end if; end Scan_Make_Arg; @@ -4682,7 +4899,9 @@ package body Make is (Index => Name_Find, In_Array => Switches_Array); - if Switches = Nil_Variable_Value then + if Switches = Nil_Variable_Value + and then Allow_ALI + then Last := Source_File_Name'Length; while Name (Last) /= '.' loop @@ -4692,10 +4911,10 @@ package body Make is Name (Last + 1 .. Last + 3) := "ali"; Name_Len := Last + 3; Name_Buffer (1 .. Name_Len) := Name (1 .. Name_Len); - Switches := - Prj.Util.Value_Of - (Index => Name_Find, - In_Array => Switches_Array); + Switches := + Prj.Util.Value_Of + (Index => Name_Find, + In_Array => Switches_Array); end if; end if; end; @@ -4713,7 +4932,10 @@ package body Make is -- Test_If_Relative_Path -- --------------------------- - procedure Test_If_Relative_Path (Switch : String_Access) is + procedure Test_If_Relative_Path + (Switch : in out String_Access; + Parent : String_Access) + is begin if Switch /= null then @@ -4743,27 +4965,44 @@ package body Make is then Start := 4; + elsif Sw'Length >= 7 + and then Sw (2 .. 6) = "-RTS=" + then + Start := 7; else return; end if; if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then - Fail ("relative search path switches (""" & - Sw & """) are not allowed when using project files"); + if Parent = null then + Fail ("relative search path switches (""" & Sw & + """) are not allowed inside project files"); + + else + Switch := + new String' + (Sw (1 .. Start - 1) & + Parent.all & + Directory_Separator & + Sw (Start .. Sw'Last)); + end if; end if; end if; end; end if; end Test_If_Relative_Path; - ------------ - -- Unmark -- - ------------ + ----------- + -- Usage -- + ----------- - procedure Unmark (Source_File : File_Name_Type) is + procedure Usage is begin - Set_Name_Table_Byte (Source_File, 0); - end Unmark; + if Usage_Needed then + Usage_Needed := False; + Makeusg; + end if; + end Usage; ----------------- -- Verbose_Msg -- diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb index ec219b53eb1..051c8f16b80 100644 --- a/gcc/ada/makeusg.adb +++ b/gcc/ada/makeusg.adb @@ -32,15 +32,6 @@ with Usage; procedure Makeusg is - procedure Write_Switch_Char; - -- Write two spaces followed by appropriate switch character - - procedure Write_Switch_Char is - begin - Write_Str (" "); - Write_Char (Switch_Character); - end Write_Switch_Char; - -- Start of processing for Makeusg begin @@ -64,124 +55,111 @@ begin -- Line for -a - Write_Switch_Char; - Write_Str ("a Consider all files, even readonly ali files"); + Write_Str (" -a Consider all files, even readonly ali files"); Write_Eol; -- Line for -b - Write_Switch_Char; - Write_Str ("b Bind only"); + Write_Str (" -b Bind only"); Write_Eol; -- Line for -c - Write_Switch_Char; - Write_Str ("c Compile only"); + Write_Str (" -c Compile only"); + Write_Eol; + + -- Line for -C + + Write_Str (" -C Cache source mappings: " & + "invoke the compiler with a mapping file"); Write_Eol; -- Line for -f - Write_Switch_Char; - Write_Str ("f Force recompilations of non predefined units"); + Write_Str (" -f Force recompilations of non predefined units"); Write_Eol; -- Line for -i - Write_Switch_Char; - Write_Str ("i In place. Replace existing ali file, "); + Write_Str (" -i In place. Replace existing ali file, "); Write_Str ("or put it with source"); Write_Eol; -- Line for -jnnn - Write_Switch_Char; - Write_Str ("jnum Use nnn processes to compile"); + Write_Str (" -jnum Use nnn processes to compile"); Write_Eol; -- Line for -k - Write_Switch_Char; - Write_Str ("k Keep going after compilation errors"); + Write_Str (" -k Keep going after compilation errors"); Write_Eol; -- Line for -l - Write_Switch_Char; - Write_Str ("l Link only"); + Write_Str (" -l Link only"); Write_Eol; -- Line for -m - Write_Switch_Char; - Write_Str ("m Minimal recompilation"); + Write_Str (" -m Minimal recompilation"); Write_Eol; -- Line for -M - Write_Switch_Char; - Write_Str ("M List object file dependences for Makefile"); + Write_Str (" -M List object file dependences for Makefile"); Write_Eol; -- Line for -n - Write_Switch_Char; - Write_Str ("n Check objects up to date, output next file "); + Write_Str (" -n Check objects up to date, output next file "); Write_Str ("to compile if not"); Write_Eol; -- Line for -o - Write_Switch_Char; - Write_Str ("o name Choose an alternate executable name"); + Write_Str (" -o name Choose an alternate executable name"); Write_Eol; -- Line for -P - Write_Switch_Char; - Write_Str ("Pproj Use GNAT Project File proj"); + Write_Str (" -Pproj Use GNAT Project File proj"); Write_Eol; -- Line for -q - Write_Switch_Char; - Write_Str ("q Be quiet/terse"); + Write_Str (" -q Be quiet/terse"); Write_Eol; -- Line for -s - Write_Switch_Char; - Write_Str ("s Recompile if compiler switches have changed"); + Write_Str (" -s Recompile if compiler switches have changed"); Write_Eol; -- Line for -u - Write_Switch_Char; - Write_Str ("u Unique compilation. Only compile the given file."); + Write_Str (" -u Unique compilation. Only compile the given file."); Write_Eol; -- Line for -v - Write_Switch_Char; - Write_Str ("v Display reasons for all (re)compilations"); + Write_Str (" -v Display reasons for all (re)compilations"); Write_Eol; -- Line for -vPx - Write_Switch_Char; - Write_Str ("vPx Specify verbosity when parsing GNAT Project Files"); + Write_Str (" -vPx Specify verbosity when parsing GNAT Project Files"); Write_Eol; -- Line for -X - Write_Switch_Char; - Write_Str ("Xnm=val Specify an external reference for GNAT Project Files"); + Write_Str (" -Xnm=val Specify an external reference for GNAT " & + "Project Files"); Write_Eol; -- Line for -z - Write_Switch_Char; - Write_Str ("z No main subprogram (zero main)"); + Write_Str (" -z No main subprogram (zero main)"); Write_Eol; Write_Eol; @@ -202,60 +180,57 @@ begin -- Line for -aL - Write_Switch_Char; - Write_Str ("aLdir Skip missing library sources if ali in dir"); + Write_Str (" -aLdir Skip missing library sources if ali in dir"); Write_Eol; -- Line for -A - Write_Switch_Char; - Write_Str ("Adir like -aLdir -aIdir"); + Write_Str (" -Adir like -aLdir -aIdir"); Write_Eol; -- Line for -aO switch - Write_Switch_Char; - Write_Str ("aOdir Specify library/object files search path"); + Write_Str (" -aOdir Specify library/object files search path"); Write_Eol; -- Line for -aI switch - Write_Switch_Char; - Write_Str ("aIdir Specify source files search path"); + Write_Str (" -aIdir Specify source files search path"); Write_Eol; -- Line for -I switch - Write_Switch_Char; - Write_Str ("Idir Like -aIdir -aOdir"); + Write_Str (" -Idir Like -aIdir -aOdir"); Write_Eol; -- Line for -I- switch - Write_Switch_Char; - Write_Str ("I- Don't look for sources & library files"); + Write_Str (" -I- Don't look for sources & library files"); Write_Str (" in the default directory"); Write_Eol; -- Line for -L - Write_Switch_Char; - Write_Str ("Ldir Look for program libraries also in dir"); + Write_Str (" -Ldir Look for program libraries also in dir"); Write_Eol; -- Line for -nostdinc - Write_Switch_Char; - Write_Str ("nostdinc Don't look for sources"); + Write_Str (" -nostdinc Don't look for sources"); Write_Str (" in the system default directory"); Write_Eol; -- Line for -nostdlib - Write_Switch_Char; - Write_Str ("nostdlib Don't look for library files"); + Write_Str (" -nostdlib Don't look for library files"); Write_Str (" in the system default directory"); Write_Eol; + + -- Line for --RTS + + Write_Str (" --RTS=dir specify the default source and object search" + & " path"); + Write_Eol; Write_Eol; -- General Compiler, Binder, Linker switches @@ -266,20 +241,17 @@ begin -- Line for -cargs - Write_Switch_Char; - Write_Str ("cargs opts opts are passed to the compiler"); + Write_Str (" -cargs opts opts are passed to the compiler"); Write_Eol; -- Line for -bargs - Write_Switch_Char; - Write_Str ("bargs opts opts are passed to the binder"); + Write_Str (" -bargs opts opts are passed to the binder"); Write_Eol; -- Line for -largs - Write_Switch_Char; - Write_Str ("largs opts opts are passed to the linker"); + Write_Str (" -largs opts opts are passed to the linker"); Write_Eol; -- Add usage information for gcc diff --git a/gcc/ada/mdllfile.adb b/gcc/ada/mdll-fil.adb index 9aad7e117a0..20a8123b75c 100644 --- a/gcc/ada/mdllfile.adb +++ b/gcc/ada/mdll-fil.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ -- +-- $Revision$ -- -- -- --- Copyright (C) 1992-1999 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- -- @@ -30,7 +30,7 @@ with Ada.Strings.Fixed; -package body MDLL.Files is +package body MDLL.Fil is use Ada; @@ -38,9 +38,7 @@ package body MDLL.Files is -- Get_Ext -- ------------- - function Get_Ext (Filename : in String) - return String - is + function Get_Ext (Filename : String) return String is use Strings.Fixed; I : constant Natural := Index (Filename, ".", Strings.Backward); begin @@ -55,8 +53,7 @@ package body MDLL.Files is -- Is_Ali -- ------------ - function Is_Ali (Filename : in String) - return Boolean is + function Is_Ali (Filename : String) return Boolean is begin return Get_Ext (Filename) = ".ali"; end Is_Ali; @@ -65,9 +62,7 @@ package body MDLL.Files is -- Is_Obj -- ------------ - function Is_Obj (Filename : in String) - return Boolean - is + function Is_Obj (Filename : String) return Boolean is Ext : constant String := Get_Ext (Filename); begin return Ext = ".o" or else Ext = ".obj"; @@ -77,9 +72,10 @@ package body MDLL.Files is -- Ext_To -- ------------ - function Ext_To (Filename : in String; - New_Ext : in String := No_Ext) - return String + function Ext_To + (Filename : String; + New_Ext : String := No_Ext) + return String is use Strings.Fixed; I : constant Natural := Index (Filename, ".", Strings.Backward); @@ -95,4 +91,4 @@ package body MDLL.Files is end if; end Ext_To; -end MDLL.Files; +end MDLL.Fil; diff --git a/gcc/ada/mdllfile.ads b/gcc/ada/mdll-fil.ads index c7a14c238a4..3953012bb62 100644 --- a/gcc/ada/mdllfile.ads +++ b/gcc/ada/mdll-fil.ads @@ -28,7 +28,7 @@ -- Simple services used by GNATDLL to deal with Filename extension -package MDLL.Files is +package MDLL.Fil is No_Ext : constant String := ""; -- Used to mark the absence of an extension @@ -48,4 +48,4 @@ package MDLL.Files is return String; -- Return Filename with the extension change to New_Ext -end MDLL.Files; +end MDLL.Fil; diff --git a/gcc/ada/mdlltool.adb b/gcc/ada/mdll-utl.adb index c1ecc7f006d..75488ccf278 100644 --- a/gcc/ada/mdlltool.adb +++ b/gcc/ada/mdll-utl.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $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- -- @@ -30,11 +30,10 @@ with Ada.Text_IO; with Ada.Exceptions; -with Ada.Unchecked_Deallocation; with Sdefault; -package body MDLL.Tools is +package body MDLL.Utl is use Ada; use GNAT; @@ -51,20 +50,19 @@ package body MDLL.Tools is Gnatlink_Name : constant String := "gnatlink"; Gnatlink_Exec : OS_Lib.String_Access; - procedure Free is - new Ada.Unchecked_Deallocation (OS_Lib.Argument_List, - OS_Lib.Argument_List_Access); - - procedure Print_Command (Tool_Name : in String; - Arguments : in OS_Lib.Argument_List); + procedure Print_Command + (Tool_Name : String; + Arguments : OS_Lib.Argument_List); -- display the command runned when in Verbose mode ------------------- -- Print_Command -- ------------------- - procedure Print_Command (Tool_Name : in String; - Arguments : in OS_Lib.Argument_List) is + procedure Print_Command + (Tool_Name : String; + Arguments : OS_Lib.Argument_List) + is begin if Verbose then Text_IO.Put (Tool_Name); @@ -75,29 +73,18 @@ package body MDLL.Tools is end if; end Print_Command; - ----------------- - -- Delete_File -- - ----------------- - - procedure Delete_File (Filename : in String) is - File : constant String := Filename & ASCII.Nul; - Success : Boolean; - begin - OS_Lib.Delete_File (File'Address, Success); - end Delete_File; - ------------- -- Dlltool -- ------------- - procedure Dlltool (Def_Filename : in String; - DLL_Name : in String; - Library : in String; - Exp_Table : in String := ""; - Base_File : in String := ""; - Build_Import : in Boolean) + procedure Dlltool + (Def_Filename : String; + DLL_Name : String; + Library : String; + Exp_Table : String := ""; + Base_File : String := ""; + Build_Import : Boolean) is - Arguments : OS_Lib.Argument_List (1 .. 11); A : Positive; @@ -162,11 +149,12 @@ package body MDLL.Tools is -- Gcc -- --------- - procedure Gcc (Output_File : in String; - Files : in Argument_List; - Options : in Argument_List; - Base_File : in String := ""; - Build_Lib : in Boolean := False) + procedure Gcc + (Output_File : String; + Files : Argument_List; + Options : Argument_List; + Base_File : String := ""; + Build_Lib : Boolean := False) is use Sdefault; @@ -240,8 +228,9 @@ package body MDLL.Tools is -- Gnatbind -- -------------- - procedure Gnatbind (Alis : in Argument_List; - Args : in Argument_List := Null_Argument_List) + procedure Gnatbind + (Alis : Argument_List; + Args : Argument_List := Null_Argument_List) is Arguments : OS_Lib.Argument_List (1 .. 1 + Alis'Length + Args'Length); Success : Boolean; @@ -267,8 +256,9 @@ package body MDLL.Tools is -- Gnatlink -- -------------- - procedure Gnatlink (Ali : in String; - Args : in Argument_List := Null_Argument_List) + procedure Gnatlink + (Ali : String; + Args : Argument_List := Null_Argument_List) is Arguments : OS_Lib.Argument_List (1 .. 1 + Args'Length); Success : Boolean; @@ -343,4 +333,4 @@ package body MDLL.Tools is end Locate; -end MDLL.Tools; +end MDLL.Utl; diff --git a/gcc/ada/mdlltool.ads b/gcc/ada/mdll-utl.ads index 0e9b55c9aff..130e14cbee0 100644 --- a/gcc/ada/mdlltool.ads +++ b/gcc/ada/mdll-utl.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- --- Copyright (C) 1992-1999 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- -- @@ -28,39 +28,40 @@ -- Interface to externals tools used to build DLL and import libraries -package MDLL.Tools is +package MDLL.Utl is - procedure Delete_File (Filename : in String); - -- delete the file filename from the file system. + procedure Dlltool + (Def_Filename : String; + DLL_Name : String; + Library : String; + Exp_Table : String := ""; + Base_File : String := ""; + Build_Import : Boolean); + -- Run dlltool binary. + -- This tools is used to build an import library and an export table - procedure Dlltool (Def_Filename : in String; - DLL_Name : in String; - Library : in String; - Exp_Table : in String := ""; - Base_File : in String := ""; - Build_Import : in Boolean); - -- run dlltool binary. - -- this tools is used to build an import library and an export table + procedure Gcc + (Output_File : String; + Files : Argument_List; + Options : Argument_List; + Base_File : String := ""; + Build_Lib : Boolean := False); + -- Run gcc binary. - procedure Gcc (Output_File : in String; - Files : in Argument_List; - Options : in Argument_List; - Base_File : in String := ""; - Build_Lib : in Boolean := False); - -- run gcc binary. + procedure Gnatbind + (Alis : Argument_List; + Args : Argument_List := Null_Argument_List); + -- Run gnatbind binary to build the binder program. + -- it Runs the command : gnatbind -n alis... to build the binder program. - procedure Gnatbind (Alis : in Argument_List; - Args : in Argument_List := Null_Argument_List); - -- run gnatbind binary to build the binder program. - -- it runs the command : gnatbind -n alis... to build the binder program. - - procedure Gnatlink (Ali : in String; - Args : in Argument_List := Null_Argument_List); - -- run gnatlink binary. - -- it runs the command : gnatlink ali arg1 arg2... + procedure Gnatlink + (Ali : String; + Args : Argument_List := Null_Argument_List); + -- Run gnatlink binary. + -- It runs the command : gnatlink ali arg1 arg2... procedure Locate; - -- look for the needed tools in the path and record the full path for each + -- Look for the needed tools in the path and record the full path for each -- one in a variable. -end MDLL.Tools; +end MDLL.Utl; diff --git a/gcc/ada/mdll.adb b/gcc/ada/mdll.adb index c07768d7380..9f476b2b04d 100644 --- a/gcc/ada/mdll.adb +++ b/gcc/ada/mdll.adb @@ -31,8 +31,8 @@ with Ada.Text_IO; -with MDLL.Tools; -with MDLL.Files; +with MDLL.Utl; +with MDLL.Fil; package body MDLL is @@ -58,7 +58,7 @@ package body MDLL is use type OS_Lib.Argument_List; - Base_Filename : constant String := MDLL.Files.Ext_To (Lib_Filename); + Base_Filename : constant String := MDLL.Fil.Ext_To (Lib_Filename); Def_File : aliased String := Def_Filename; Jnk_File : aliased String := Base_Filename & ".jnk"; @@ -70,6 +70,7 @@ package body MDLL is Bas_Opt : aliased String := "-Wl,--base-file," & Bas_File; Lib_Opt : aliased String := "-mdll"; Out_Opt : aliased String := "-o"; + Adr_Opt : aliased String := "-Wl,--image-base=" & Lib_Address; All_Options : constant Argument_List := Options & Largs_Options; @@ -92,12 +93,13 @@ package body MDLL is --------------------- procedure Build_Reloc_DLL is - -- Objects plus the export table (.exp) file - Objects_Exp_File : OS_Lib.Argument_List + Objects_Exp_File : constant OS_Lib.Argument_List := Exp_File'Unchecked_Access & Ofiles; + Success : Boolean; + begin if not Quiet then Text_IO.Put_Line ("building relocatable DLL..."); @@ -112,50 +114,50 @@ package body MDLL is -- 1) Build base file with objects files. - Tools.Gcc (Output_File => Jnk_File, - Files => Ofiles, - Options => All_Options, - Base_File => Bas_File, - Build_Lib => True); + Utl.Gcc (Output_File => Jnk_File, + Files => Ofiles, + Options => All_Options, + Base_File => Bas_File, + Build_Lib => True); -- 2) Build exp from base file. - Tools.Dlltool (Def_File, Dll_File, Lib_File, - Base_File => Bas_File, - Exp_Table => Exp_File, - Build_Import => False); + Utl.Dlltool (Def_File, Dll_File, Lib_File, + Base_File => Bas_File, + Exp_Table => Exp_File, + Build_Import => False); -- 3) Build base file with exp file and objects files. - Tools.Gcc (Output_File => Jnk_File, - Files => Objects_Exp_File, - Options => All_Options, - Base_File => Bas_File, - Build_Lib => True); + Utl.Gcc (Output_File => Jnk_File, + Files => Objects_Exp_File, + Options => All_Options, + Base_File => Bas_File, + Build_Lib => True); -- 4) Build new exp from base file and the lib file (.a) - Tools.Dlltool (Def_File, Dll_File, Lib_File, - Base_File => Bas_File, - Exp_Table => Exp_File, - Build_Import => Build_Import); + Utl.Dlltool (Def_File, Dll_File, Lib_File, + Base_File => Bas_File, + Exp_Table => Exp_File, + Build_Import => Build_Import); -- 5) Build the dynamic library - Tools.Gcc (Output_File => Dll_File, - Files => Objects_Exp_File, - Options => All_Options, - Build_Lib => True); + Utl.Gcc (Output_File => Dll_File, + Files => Objects_Exp_File, + Options => Adr_Opt'Unchecked_Access & All_Options, + Build_Lib => True); - Tools.Delete_File (Exp_File); - Tools.Delete_File (Bas_File); - Tools.Delete_File (Jnk_File); + OS_Lib.Delete_File (Exp_File, Success); + OS_Lib.Delete_File (Bas_File, Success); + OS_Lib.Delete_File (Jnk_File, Success); exception when others => - Tools.Delete_File (Exp_File); - Tools.Delete_File (Bas_File); - Tools.Delete_File (Jnk_File); + OS_Lib.Delete_File (Exp_File, Success); + OS_Lib.Delete_File (Bas_File, Success); + OS_Lib.Delete_File (Jnk_File, Success); raise; end Build_Reloc_DLL; @@ -164,6 +166,7 @@ package body MDLL is ------------------------- procedure Ada_Build_Reloc_DLL is + Success : Boolean; begin if not Quiet then Text_IO.Put_Line ("Building relocatable DLL..."); @@ -178,7 +181,7 @@ package body MDLL is -- 1) Build base file with objects files. - Tools.Gnatbind (Afiles, Options & Bargs_Options); + Utl.Gnatbind (Afiles, Options & Bargs_Options); declare Params : OS_Lib.Argument_List := @@ -186,20 +189,19 @@ package body MDLL is Lib_Opt'Unchecked_Access & Bas_Opt'Unchecked_Access & Ofiles & All_Options; begin - Tools.Gnatlink (Afiles (Afiles'Last).all, - Params); + Utl.Gnatlink (Afiles (Afiles'Last).all, Params); end; -- 2) Build exp from base file. - Tools.Dlltool (Def_File, Dll_File, Lib_File, - Base_File => Bas_File, - Exp_Table => Exp_File, - Build_Import => False); + Utl.Dlltool (Def_File, Dll_File, Lib_File, + Base_File => Bas_File, + Exp_Table => Exp_File, + Build_Import => False); -- 3) Build base file with exp file and objects files. - Tools.Gnatbind (Afiles, Options & Bargs_Options); + Utl.Gnatbind (Afiles, Options & Bargs_Options); declare Params : OS_Lib.Argument_List := @@ -210,42 +212,41 @@ package body MDLL is Ofiles & All_Options; begin - Tools.Gnatlink (Afiles (Afiles'Last).all, - Params); + Utl.Gnatlink (Afiles (Afiles'Last).all, Params); end; -- 4) Build new exp from base file and the lib file (.a) - Tools.Dlltool (Def_File, Dll_File, Lib_File, - Base_File => Bas_File, - Exp_Table => Exp_File, - Build_Import => Build_Import); + Utl.Dlltool (Def_File, Dll_File, Lib_File, + Base_File => Bas_File, + Exp_Table => Exp_File, + Build_Import => Build_Import); -- 5) Build the dynamic library - Tools.Gnatbind (Afiles, Options & Bargs_Options); + Utl.Gnatbind (Afiles, Options & Bargs_Options); declare Params : OS_Lib.Argument_List := Out_Opt'Unchecked_Access & Dll_File'Unchecked_Access & Lib_Opt'Unchecked_Access & Exp_File'Unchecked_Access & + Adr_Opt'Unchecked_Access & Ofiles & All_Options; begin - Tools.Gnatlink (Afiles (Afiles'Last).all, - Params); + Utl.Gnatlink (Afiles (Afiles'Last).all, Params); end; - Tools.Delete_File (Exp_File); - Tools.Delete_File (Bas_File); - Tools.Delete_File (Jnk_File); + OS_Lib.Delete_File (Exp_File, Success); + OS_Lib.Delete_File (Bas_File, Success); + OS_Lib.Delete_File (Jnk_File, Success); exception when others => - Tools.Delete_File (Exp_File); - Tools.Delete_File (Bas_File); - Tools.Delete_File (Jnk_File); + OS_Lib.Delete_File (Exp_File, Success); + OS_Lib.Delete_File (Bas_File, Success); + OS_Lib.Delete_File (Jnk_File, Success); raise; end Ada_Build_Reloc_DLL; @@ -254,6 +255,7 @@ package body MDLL is ------------------------- procedure Build_Non_Reloc_DLL is + Success : Boolean; begin if not Quiet then Text_IO.Put_Line ("building non relocatable DLL..."); @@ -269,22 +271,22 @@ package body MDLL is -- Build exp table and the lib .a file. - Tools.Dlltool (Def_File, Dll_File, Lib_File, - Exp_Table => Exp_File, - Build_Import => Build_Import); + Utl.Dlltool (Def_File, Dll_File, Lib_File, + Exp_Table => Exp_File, + Build_Import => Build_Import); -- Build the DLL - Tools.Gcc (Output_File => Dll_File, - Files => Exp_File'Unchecked_Access & Ofiles, - Options => All_Options, - Build_Lib => True); + Utl.Gcc (Output_File => Dll_File, + Files => Exp_File'Unchecked_Access & Ofiles, + Options => Adr_Opt'Unchecked_Access & All_Options, + Build_Lib => True); - Tools.Delete_File (Exp_File); + OS_Lib.Delete_File (Exp_File, Success); exception when others => - Tools.Delete_File (Exp_File); + OS_Lib.Delete_File (Exp_File, Success); raise; end Build_Non_Reloc_DLL; @@ -295,6 +297,7 @@ package body MDLL is -- Build a non relocatable DLL with Ada code. procedure Ada_Build_Non_Reloc_DLL is + Success : Boolean; begin if not Quiet then Text_IO.Put_Line ("building non relocatable DLL..."); @@ -310,31 +313,31 @@ package body MDLL is -- Build exp table and the lib .a file. - Tools.Dlltool (Def_File, Dll_File, Lib_File, - Exp_Table => Exp_File, - Build_Import => Build_Import); + Utl.Dlltool (Def_File, Dll_File, Lib_File, + Exp_Table => Exp_File, + Build_Import => Build_Import); -- Build the DLL - Tools.Gnatbind (Afiles, Options & Bargs_Options); + Utl.Gnatbind (Afiles, Options & Bargs_Options); declare Params : OS_Lib.Argument_List := Out_Opt'Unchecked_Access & Dll_File'Unchecked_Access & Lib_Opt'Unchecked_Access & Exp_File'Unchecked_Access & + Adr_Opt'Unchecked_Access & Ofiles & All_Options; begin - Tools.Gnatlink (Afiles (Afiles'Last).all, - Params); + Utl.Gnatlink (Afiles (Afiles'Last).all, Params); end; - Tools.Delete_File (Exp_File); + OS_Lib.Delete_File (Exp_File, Success); exception when others => - Tools.Delete_File (Exp_File); + OS_Lib.Delete_File (Exp_File, Success); raise; end Ada_Build_Non_Reloc_DLL; @@ -371,7 +374,7 @@ package body MDLL is -- Build an import library. -- this is to build only a .a library to link against a DLL. - Base_Filename : constant String := MDLL.Files.Ext_To (Lib_Filename); + Base_Filename : constant String := MDLL.Fil.Ext_To (Lib_Filename); -------------------------- -- Build_Import_Library -- @@ -391,8 +394,8 @@ package body MDLL is " to use dynamic library " & Dll_File); end if; - Tools.Dlltool (Def_File, Dll_File, Lib_File, - Build_Import => True); + Utl.Dlltool (Def_File, Dll_File, Lib_File, + Build_Import => True); end Build_Import_Library; begin diff --git a/gcc/ada/memroot.adb b/gcc/ada/memroot.adb index d8db62b751b..0cca01293e3 100644 --- a/gcc/ada/memroot.adb +++ b/gcc/ada/memroot.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.16 $ +-- $Revision$ -- -- --- Copyright (C) 1997-2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 1997-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- -- @@ -574,23 +574,26 @@ package body Memroot is while Last >= 1 and then Line (1) = '#' and then not Main_Found loop if F <= BT_Depth then Find_Name; - Nam := Enter_Name (Line (Curs1 .. Curs2)); - Main_Found := Line (Curs1 .. Curs2) = "main"; + -- Skip the __gnat_malloc frame itself + if Line (Curs1 .. Curs2) /= "<__gnat_malloc>" then + Nam := Enter_Name (Line (Curs1 .. Curs2)); + Main_Found := Line (Curs1 .. Curs2) = "main"; - Find_File; + Find_File; - if No_File then - Fil := No_Name_Id; - Lin := No_Name_Id; - else - Fil := Enter_Name (Line (Curs1 .. Curs2)); + if No_File then + Fil := No_Name_Id; + Lin := No_Name_Id; + else + Fil := Enter_Name (Line (Curs1 .. Curs2)); - Find_Line; - Lin := Enter_Name (Line (Curs1 .. Curs2)); - end if; + Find_Line; + Lin := Enter_Name (Line (Curs1 .. Curs2)); + end if; - Frames (F) := Enter_Frame (Nam, Fil, Lin); - F := F + 1; + Frames (F) := Enter_Frame (Nam, Fil, Lin); + F := F + 1; + end if; end if; if No_File then diff --git a/gcc/ada/misc.c b/gcc/ada/misc.c index 78b04c8da2d..99e06fea7e5 100644 --- a/gcc/ada/misc.c +++ b/gcc/ada/misc.c @@ -6,9 +6,9 @@ * * * C Implementation File * * * - * $Revision: 1.18 $ + * $Revision$ * * - * Copyright (C) 1992-2001 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- * @@ -43,12 +43,13 @@ #include "errors.h" #include "diagnostic.h" #include "expr.h" +#include "libfuncs.h" #include "ggc.h" #include "flags.h" +#include "debug.h" #include "insn-codes.h" #include "insn-flags.h" #include "insn-config.h" -#include "optabs.h" #include "recog.h" #include "toplev.h" #include "output.h" @@ -70,6 +71,7 @@ #include "einfo.h" #include "ada-tree.h" #include "gigi.h" +#include "adadecode.h" extern FILE *asm_out_file; extern int save_argc; @@ -83,7 +85,7 @@ extern char **save_argv; #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE, -static char const gnat_tree_code_type[] = { +static const char gnat_tree_code_type[] = { 'x', #include "ada-tree.def" }; @@ -95,7 +97,7 @@ static char const gnat_tree_code_type[] = { #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH, -static int const gnat_tree_code_length[] = { +static const int gnat_tree_code_length[] = { 0, #include "ada-tree.def" }; @@ -105,7 +107,7 @@ static int const gnat_tree_code_length[] = { Used for printing out the tree and error messages. */ #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME, -static const char *gnat_tree_code_name[] = { +const char * const gnat_tree_code_name[] = { "@@dummy", #include "ada-tree.def" }; @@ -117,8 +119,9 @@ static int gnat_decode_option PARAMS ((int, char **)); static HOST_WIDE_INT gnat_get_alias_set PARAMS ((tree)); static void gnat_print_decl PARAMS ((FILE *, tree, int)); static void gnat_print_type PARAMS ((FILE *, tree, int)); -extern void gnat_init_decl_processing PARAMS ((void)); -static tree gnat_expand_constant PARAMS ((tree)); +static const char *gnat_printable_name PARAMS ((tree, int)); +static tree gnat_eh_runtime_type PARAMS ((tree)); +static int gnat_eh_type_covers PARAMS ((tree, tree)); /* Structure giving our language-specific hooks. */ @@ -140,8 +143,6 @@ static tree gnat_expand_constant PARAMS ((tree)); #define LANG_HOOKS_PRINT_DECL gnat_print_decl #undef LANG_HOOKS_PRINT_TYPE #define LANG_HOOKS_PRINT_TYPE gnat_print_type -#undef LANG_HOOKS_EXPAND_CONSTANT -#define LANG_HOOKS_EXPAND_CONSTANT gnat_expand_constant const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; @@ -158,21 +159,15 @@ static void internal_error_function PARAMS ((const char *, va_list *)); static rtx gnat_expand_expr PARAMS ((tree, rtx, enum machine_mode, enum expand_modifier)); static void gnat_adjust_rli PARAMS ((record_layout_info)); - -#if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO) -static char *convert_ada_name_to_qualified_name PARAMS ((char *)); -#endif -/* Routines Expected by gcc: */ - -/* For most front-ends, this is the parser for the language. For us, we - process the GNAT tree. */ - /* Declare functions we use as part of startup. */ extern void __gnat_initialize PARAMS((void)); extern void adainit PARAMS((void)); extern void _ada_gnat1drv PARAMS((void)); +/* For most front-ends, this is the parser for the language. For us, we + process the GNAT tree. */ + int yyparse () { @@ -195,7 +190,7 @@ yyparse () it cannot decode. This routine returns 1 if it is successful, otherwise it returns 0. */ -static int +int gnat_decode_option (argc, argv) int argc ATTRIBUTE_UNUSED; char **argv; @@ -244,6 +239,15 @@ gnat_decode_option (argc, argv) return 1; } + /* Handle the --RTS switch. The real option we get is -fRTS. This + modification is done by the driver program. */ + if (!strncmp (p, "-fRTS", 5)) + { + gnat_argv[gnat_argc] = p; + gnat_argc ++; + return 1; + } + /* Ignore -W flags since people may want to use the same flags for all languages. */ else if (p[0] == '-' && p[1] == 'W' && p[2] != 0) @@ -254,12 +258,12 @@ gnat_decode_option (argc, argv) /* Initialize for option processing. */ -static void +void gnat_init_options () { /* Initialize gnat_argv with save_argv size */ gnat_argv = (char **) xmalloc ((save_argc + 1) * sizeof (gnat_argv[0])); - gnat_argv [0] = save_argv[0]; /* name of the command */ + gnat_argv[0] = save_argv[0]; /* name of the command */ gnat_argc = 1; } @@ -310,7 +314,7 @@ lang_mark_tree (t) } } -/* Here we have the function to handle the compiler error processing in GCC. */ +/* Here is the function to handle the compiler error processing in GCC. */ static void internal_error_function (msgid, ap) @@ -345,13 +349,14 @@ static const char * gnat_init (filename) const char *filename; { -/* Performs whatever initialization steps needed by the language-dependent - lexical analyzer. + /* Performs whatever initialization steps needed by the language-dependent + lexical analyzer. - Define the additional tree codes here. This isn't the best place to put - it, but it's where g++ does it. */ + Define the additional tree codes here. This isn't the best place to put + it, but it's where g++ does it. */ lang_expand_expr = gnat_expand_expr; + decl_printable_name = gnat_printable_name; memcpy ((char *) (tree_code_type + (int) LAST_AND_UNUSED_TREE_CODE), (char *) gnat_tree_code_type, @@ -371,9 +376,9 @@ gnat_init (filename) gnat_init_decl_processing (); /* Add the input filename as the last argument. */ - gnat_argv [gnat_argc] = (char *) filename; + gnat_argv[gnat_argc] = (char *) filename; gnat_argc++; - gnat_argv [gnat_argc] = 0; + gnat_argv[gnat_argc] = 0; set_internal_error_function (internal_error_function); @@ -384,17 +389,36 @@ gnat_init (filename) lang_attribute_common = 0; set_lang_adjust_rli (gnat_adjust_rli); + return filename; +} -#if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO) - dwarf2out_set_demangle_name_func (convert_ada_name_to_qualified_name); -#endif - - if (filename == 0) - filename = ""; +/* If we are using the GCC mechanism for to process exception handling, we + have to register the personality routine for Ada and to initialize + various language dependent hooks. */ - return filename; +void +gnat_init_gcc_eh () +{ + /* We shouldn't do anything if the No_Exceptions_Handler pragma is set, + though. This could for instance lead to the emission of tables with + references to symbols (such as the Ada eh personality routine) within + libraries we won't link against. */ + if (No_Exception_Handlers_Set ()) + return; + + eh_personality_libfunc = init_one_libfunc ("__gnat_eh_personality"); + lang_eh_type_covers = gnat_eh_type_covers; + lang_eh_runtime_type = gnat_eh_runtime_type; + flag_exceptions = 1; + + init_eh (); +#ifdef DWARF2_UNWIND_INFO + if (dwarf2out_do_frame ()) + dwarf2out_frame_init (); +#endif } + /* If DECL has a cleanup, build and return that cleanup here. This is a callback called by expand_expr. */ @@ -483,9 +507,21 @@ gnat_print_type (file, node, indent) } } +static const char * +gnat_printable_name (decl, verbosity) + tree decl; + int verbosity ATTRIBUTE_UNUSED; +{ + const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl)); + char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60); + + __gnat_decode (coded_name, ada_name, 0); + + return (const char *) ada_name; +} + /* Expands GNAT-specific GCC tree nodes. The only ones we support - here are TRANSFORM_EXPR, UNCHECKED_CONVERT_EXPR, ALLOCATE_EXPR, - USE_EXPR and NULL_EXPR. */ + here are TRANSFORM_EXPR, ALLOCATE_EXPR, USE_EXPR and NULL_EXPR. */ static rtx gnat_expand_expr (exp, target, tmode, modifier) @@ -495,10 +531,8 @@ gnat_expand_expr (exp, target, tmode, modifier) enum expand_modifier modifier; { tree type = TREE_TYPE (exp); - tree inner_type; tree new; rtx result; - int align_ok; /* Update EXP to be the new expression to expand. */ @@ -509,121 +543,6 @@ gnat_expand_expr (exp, target, tmode, modifier) return const0_rtx; break; - case UNCHECKED_CONVERT_EXPR: - inner_type = TREE_TYPE (TREE_OPERAND (exp, 0)); - - /* The alignment is OK if the flag saying it is OK is set in either - type, if the inner type is already maximally aligned, if the - new type is no more strictly aligned than the old type, or - if byte accesses are not slow. */ - align_ok = (! SLOW_BYTE_ACCESS - || TYPE_ALIGN_OK_P (type) || TYPE_ALIGN_OK_P (inner_type) - || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT - || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)); - - /* If we're converting between an aggregate and non-aggregate type - and we have a MEM TARGET, we can't use it, since MEM_IN_STRUCT_P - would be set incorrectly. */ - if (target != 0 && GET_CODE (target) == MEM - && (MEM_IN_STRUCT_P (target) != AGGREGATE_TYPE_P (inner_type))) - target = 0; - - /* If the input and output are both the same mode (usually BLKmode), - just return the expanded input since we want just the bits. But - we can't do this if the output is more strictly aligned than - the input or if the type is BLKmode and the sizes differ. */ - if (TYPE_MODE (type) == TYPE_MODE (inner_type) - && align_ok - && ! (TYPE_MODE (type) == BLKmode - && ! operand_equal_p (TYPE_SIZE (type), - TYPE_SIZE (inner_type), 0))) - { - new = TREE_OPERAND (exp, 0); - - /* If the new type is less strictly aligned than the inner type, - make a new type with the less strict alignment just for - code generation purposes of this node. If it is a decl, - we can't change the type, so make a NOP_EXPR. */ - if (TYPE_ALIGN (type) != TYPE_ALIGN (inner_type)) - { - tree copy_type = copy_node (inner_type); - - TYPE_ALIGN (copy_type) = TYPE_ALIGN (type); - if (DECL_P (new)) - new = build1 (NOP_EXPR, copy_type, new); - else - { - /* If NEW is a constant, it might be coming from a CONST_DECL - and hence shared. */ - if (TREE_CONSTANT (new)) - new = copy_node (new); - - TREE_TYPE (new) = copy_type; - } - } - } - - /* If either mode is BLKmode, memory will be involved, so do this - via pointer punning. Likewise, this doesn't work if there - is an alignment issue. But we must do it for types that are known - to be aligned properly. */ - else if ((TYPE_MODE (type) == BLKmode - || TYPE_MODE (inner_type) == BLKmode) - && align_ok) - new = build_unary_op (INDIRECT_REF, NULL_TREE, - convert - (build_pointer_type (type), - build_unary_op (ADDR_EXPR, NULL_TREE, - TREE_OPERAND (exp, 0)))); - - /* Otherwise make a union of the two types, convert to the union, and - extract the other value. */ - else - { - tree union_type, in_field, out_field; - - /* If this is inside the LHS of an assignment, this would generate - bad code, so abort. */ - if (TREE_ADDRESSABLE (exp)) - gigi_abort (202); - - union_type = make_node (UNION_TYPE); - in_field = create_field_decl (get_identifier ("in"), - inner_type, union_type, 0, 0, 0, 0); - out_field = create_field_decl (get_identifier ("out"), - type, union_type, 0, 0, 0, 0); - - TYPE_FIELDS (union_type) = chainon (in_field, out_field); - layout_type (union_type); - - /* Though this is a "union", we can treat its size as that of - the output type in case the size of the input type is variable. - If the output size is a variable, use the input size. */ - TYPE_SIZE (union_type) = TYPE_SIZE (type); - TYPE_SIZE_UNIT (union_type) = TYPE_SIZE (type); - if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST - && TREE_CODE (TYPE_SIZE (inner_type)) == INTEGER_CST) - { - TYPE_SIZE (union_type) = TYPE_SIZE (inner_type); - TYPE_SIZE_UNIT (union_type) = TYPE_SIZE_UNIT (inner_type); - } - - new = build (COMPONENT_REF, type, - build1 (CONVERT_EXPR, union_type, - TREE_OPERAND (exp, 0)), - out_field); - } - - result = expand_expr (new, target, tmode, modifier); - - if (GET_CODE (result) == MEM) - { - /* Update so it looks like this is of the proper type. */ - set_mem_alias_set (result, 0); - set_mem_attributes (result, exp, 0); - } - return result; - case NULL_EXPR: expand_expr (TREE_OPERAND (exp, 0), const0_rtx, VOIDmode, 0); @@ -679,26 +598,6 @@ gnat_expand_expr (exp, target, tmode, modifier) return expand_expr (new, target, tmode, modifier); } -/* Transform a constant into a form that the language-independent code - can handle. */ - -static tree -gnat_expand_constant (exp) - tree exp; -{ - /* If this is an unchecked conversion that does not change the size of the - object and the object is not a CONSTRUCTOR return the operand since the - underlying constant is still the same. Otherwise, return our operand. */ - if (TREE_CODE (exp) == UNCHECKED_CONVERT_EXPR - && operand_equal_p (TYPE_SIZE_UNIT (TREE_TYPE (exp)), - TYPE_SIZE_UNIT (TREE_TYPE (TREE_OPERAND (exp, 0))), - 1) - && TREE_CODE (TREE_OPERAND (exp, 0)) != CONSTRUCTOR) - return TREE_OPERAND (exp, 0); - - return exp; -} - /* Adjusts the RLI used to layout a record after all the fields have been added. We only handle the packed case and cause it to use the alignment that will pad the record at the end. */ @@ -707,8 +606,17 @@ static void gnat_adjust_rli (rli) record_layout_info rli; { + unsigned int record_align = rli->unpadded_align; + tree field; + + /* If any fields have variable size, we need to force the record to be at + least as aligned as the alignment of that type. */ + for (field = TYPE_FIELDS (rli->t); field; field = TREE_CHAIN (field)) + if (TREE_CODE (DECL_SIZE_UNIT (field)) != INTEGER_CST) + record_align = MAX (record_align, DECL_ALIGN (field)); + if (TYPE_PACKED (rli->t)) - rli->record_align = rli->unpadded_align; + rli->record_align = record_align; } /* Make a TRANSFORM_EXPR to later expand GNAT_NODE into code. */ @@ -736,9 +644,8 @@ update_setjmp_buf (buf) #ifdef HAVE_save_stack_nonlocal if (HAVE_save_stack_nonlocal) - sa_mode = insn_data [(int) CODE_FOR_save_stack_nonlocal].operand[0].mode; + sa_mode = insn_data[(int) CODE_FOR_save_stack_nonlocal].operand[0].mode; #endif - #ifdef STACK_SAVEAREA_MODE sa_mode = STACK_SAVEAREA_MODE (SAVE_NONLOCAL); #endif @@ -760,6 +667,32 @@ update_setjmp_buf (buf) emit_stack_save (SAVE_NONLOCAL, &stack_save, NULL_RTX); } +/* These routines are used in conjunction with GCC exception handling. */ + +/* Map compile-time to run-time tree for GCC exception handling scheme. */ + +static tree +gnat_eh_runtime_type (type) + tree type; +{ + return type; +} + +/* Return true if type A catches type B. Callback for flow analysis from + the exception handling part of the back-end. */ + +static int +gnat_eh_type_covers (a, b) + tree a, b; +{ + /* a catches b if they represent the same exception id or if a + is an "others". + + ??? integer_zero_node for "others" is hardwired in too many places + currently. */ + return (a == b || a == integer_zero_node); +} + /* See if DECL has an RTL that is indirect via a pseudo-register or a memory location and replace it with an indirect reference if so. This improves the debugger's ability to display the value. */ @@ -861,27 +794,17 @@ insert_code_for (gnat_node) { rtx insns; + do_pending_stack_adjust (); start_sequence (); mark_all_temps_used (); gnat_to_code (gnat_node); + do_pending_stack_adjust (); insns = get_insns (); end_sequence (); emit_insns_after (insns, RTL_EXPR_RTL (get_gnu_tree (gnat_node))); } } -#if 0 - -/* Return the alignment for GNAT_TYPE. */ - -unsigned int -get_type_alignment (gnat_type) - Entity_Id gnat_type; -{ - return TYPE_ALIGN (gnat_to_gnu_type (gnat_type)) / BITS_PER_UNIT; -} -#endif - /* Get the alias set corresponding to a type or expression. */ static HOST_WIDE_INT @@ -893,6 +816,13 @@ gnat_get_alias_set (type) && TYPE_IS_PADDING_P (type)) return get_alias_set (TREE_TYPE (TYPE_FIELDS (type))); + /* If the type is an unconstrained array, use the type of the + self-referential array we make. */ + else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) + return + get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))))); + + return -1; } @@ -950,99 +880,11 @@ must_pass_by_ref (gnu_type) || (TYPE_SIZE (gnu_type) != 0 && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST)); } - -#if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO) - -/* Convert NAME, which is possibly an Ada name, back to standard Ada - notation for SGI Workshop. */ - -static char * -convert_ada_name_to_qualified_name (name) - char *name; -{ - int len = strlen (name); - char *new_name = xstrdup (name); - char *buf; - int i, start; - char *qual_name_suffix = 0; - char *p; - - if (len <= 3 || use_gnu_debug_info_extensions) - { - free (new_name); - return name; - } - - /* Find the position of the first "__" after the first character of - NAME. This is the same as calling strstr except that we can't assume - the host has that function. We start after the first character so - we don't eliminate leading "__": these are emitted only by C - programs and are not qualified names */ - for (p = (char *) index (&name[1], '_'); p != 0; - p = (char *) index (p+1, '_')) - if (p[1] == '_') - { - qual_name_suffix = p; - break; - } - - if (qual_name_suffix == 0) - { - free (new_name); - return name; - } - - start = qual_name_suffix - name; - buf = new_name + start; - - for (i = start; i < len; i++) - { - if (name[i] == '_' && name[i + 1] == '_') - { - if (islower (name[i + 2])) - { - *buf++ = '.'; - *buf++ = name[i + 2]; - i += 2; - } - else if (name[i + 2] == '_' && islower (name[i + 3])) - { - /* convert foo___c___XVN to foo.c___XVN */ - *buf++ = '.'; - *buf++ = name[i + 3]; - i += 3; - } - else if (name[i + 2] == 'T') - { - /* convert foo__TtypeS to foo.__TTypeS */ - *buf++ = '.'; - *buf++ = '_'; - *buf++ = '_'; - *buf++ = 'T'; - i += 3; - } - else - *buf++ = name[i]; - } - else - *buf++ = name[i]; - } - - *buf = 0; - return new_name; -} -#endif -/* Emit a label UNITNAME_LABEL and specify that it is part of source - file FILENAME. If this is being written for SGI's Workshop - debugger, and we are writing Dwarf2 debugging information, add - additional debug info. */ +/* This function returns the version of GCC being used. Here it's GCC 3. */ -void -emit_unit_label (unitname_label, filename) - char *unitname_label; - char *filename ATTRIBUTE_UNUSED; +int +gcc_version () { - ASM_GLOBALIZE_LABEL (asm_out_file, unitname_label); - ASM_OUTPUT_LABEL (asm_out_file, unitname_label); + return 3; } diff --git a/gcc/ada/mkdir.c b/gcc/ada/mkdir.c new file mode 100644 index 00000000000..a273d23561d --- /dev/null +++ b/gcc/ada/mkdir.c @@ -0,0 +1,53 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * M K D I R * + * * + * $Revision: 1.1 $ + * * + * C Implementation File * + * * + * Copyright (C) 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 you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion 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 file provides a portable binding to the mkdir() function */ + +#ifdef __vxworks +#include "vxWorks.h" +#endif /* __vxworks */ + +#include <sys/types.h> +#include <sys/stat.h> + +int +__gnat_mkdir (dir_name) + char *dir_name; +{ +#if defined (_WIN32) || defined (__vxworks) + return mkdir (dir_name); +#else + return mkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO); +#endif +} diff --git a/gcc/ada/mlib-tgt.adb b/gcc/ada/mlib-tgt.adb index 2a25aef1ae9..dd2ae15d883 100644 --- a/gcc/ada/mlib-tgt.adb +++ b/gcc/ada/mlib-tgt.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- -- Copyright (C) 2001, Ada Core Technologies, Inc. -- -- -- @@ -33,6 +33,8 @@ package body MLib.Tgt is + pragma Warnings (Off); -- stop warnings on unreferenced formals + ----------------- -- Archive_Ext -- ----------------- diff --git a/gcc/ada/mlib-utl.adb b/gcc/ada/mlib-utl.adb index 5b4f1f0fe46..36b465d27cb 100644 --- a/gcc/ada/mlib-utl.adb +++ b/gcc/ada/mlib-utl.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.3 $ +-- $Revision$ -- -- --- Copyright (C) 2001, Ada Core Technologies, Inc. -- +-- Copyright (C) 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- -- @@ -140,8 +140,7 @@ package body MLib.Utl is procedure Gcc (Output_File : String; Objects : Argument_List; - Options : Argument_List; - Base_File : String := "") + Options : Argument_List) is Arguments : OS_Lib.Argument_List (1 .. 7 + Objects'Length + Options'Length); @@ -163,6 +162,7 @@ package body MLib.Utl is A := A + 1; Arguments (A) := Out_Opt; + A := A + 1; Arguments (A) := Out_V; diff --git a/gcc/ada/mlib-utl.ads b/gcc/ada/mlib-utl.ads index 64330f0a7cd..dacf91929a4 100644 --- a/gcc/ada/mlib-utl.ads +++ b/gcc/ada/mlib-utl.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.2 $ +-- $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- -- @@ -37,8 +37,7 @@ package MLib.Utl is procedure Gcc (Output_File : String; Objects : Argument_List; - Options : Argument_List; - Base_File : String := ""); + Options : Argument_List); -- Invoke gcc to create a library. procedure Ar diff --git a/gcc/ada/mlib.adb b/gcc/ada/mlib.adb index db0cca90019..37c8ee3c4cd 100644 --- a/gcc/ada/mlib.adb +++ b/gcc/ada/mlib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.4 $ +-- $Revision$ -- -- -- Copyright (C) 1999-2001, Ada Core Technologies, Inc. -- -- -- @@ -46,6 +46,8 @@ package body MLib is Output_File : String; Output_Dir : String) is + pragma Warnings (Off, Afiles); + use GNAT.OS_Lib; begin diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 4fe8c1a74e5..1044be89ea8 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.86 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -78,7 +78,7 @@ package body Namet is pragma Inline (Hash); -- Compute hash code for name stored in Name_Buffer (length in Name_Len) - procedure Strip_Qualification_And_Package_Body_Suffix; + procedure Strip_Qualification_And_Suffixes; -- Given an encoded entity name in Name_Buffer, remove package body -- suffix as described for Strip_Package_Body_Suffix, and also remove -- all qualification, i.e. names followed by two underscores. The @@ -589,7 +589,7 @@ package body Namet is procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is begin Get_Decoded_Name_String (Id); - Strip_Qualification_And_Package_Body_Suffix; + Strip_Qualification_And_Suffixes; end Get_Unqualified_Decoded_Name_String; --------------------------------- @@ -599,7 +599,7 @@ package body Namet is procedure Get_Unqualified_Name_String (Id : Name_Id) is begin Get_Name_String (Id); - Strip_Qualification_And_Package_Body_Suffix; + Strip_Qualification_And_Suffixes; end Get_Unqualified_Name_String; ---------- @@ -1105,11 +1105,13 @@ package body Namet is end Store_Encoded_Character; - ------------------------------------------------- - -- Strip_Qualification_And_Package_Body_Suffix -- - ------------------------------------------------- + -------------------------------------- + -- Strip_Qualification_And_Suffixes -- + -------------------------------------- + + procedure Strip_Qualification_And_Suffixes is + J : Integer; - procedure Strip_Qualification_And_Package_Body_Suffix is begin -- Strip package body qualification string off end @@ -1124,18 +1126,43 @@ package body Namet is and then Name_Buffer (J) /= 'p'; end loop; - -- Find rightmost __ separator if one exists and strip it - -- and everything that precedes it from the name. + -- Find rightmost __ or $ separator if one exists - for J in reverse 2 .. Name_Len - 2 loop - if Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then - Name_Buffer (1 .. Name_Len - J - 1) := - Name_Buffer (J + 2 .. Name_Len); - Name_Len := Name_Len - J - 1; - exit; + J := Name_Len - 1; + while J > 1 loop + + -- If $ separator, homonym separator, so strip it and keep looking + + if Name_Buffer (J) = '$' then + Name_Len := J - 1; + J := Name_Len - 1; + + -- Else check for __ found + + elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then + + -- Found __ so see if digit follows, and if so, this is a + -- homonym separator, so strip it and keep looking. + + if Name_Buffer (J + 2) in '0' .. '9' then + Name_Len := J - 1; + J := Name_Len - 1; + + -- If not a homonym separator, then we simply strip the + -- separator and everything that precedes it, and we are done + + else + Name_Buffer (1 .. Name_Len - J - 1) := + Name_Buffer (J + 2 .. Name_Len); + Name_Len := Name_Len - J - 1; + exit; + end if; + + else + J := J - 1; end if; end loop; - end Strip_Qualification_And_Package_Body_Suffix; + end Strip_Qualification_And_Suffixes; --------------- -- Tree_Read -- diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 2517c5579a3..f22f182dde7 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.78 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -148,11 +148,12 @@ package Namet is procedure Get_Unqualified_Name_String (Id : Name_Id); -- Similar to the above except that qualification (as defined in unit -- Exp_Dbug) is removed (including both preceding __ delimited names, - -- and also the suffix used to indicate package body entities). Note - -- that names are not qualified until just before the call to gigi, so - -- this routine is only needed by processing that occurs after gigi has - -- been called. This includes all ASIS processing, since ASIS works on - -- the tree written after gigi has been called. + -- and also the suffixes used to indicate package body entities and to + -- distinguish between overloaded entities). Note that names are not + -- qualified until just before the call to gigi, so this routine is + -- only needed by processing that occurs after gigi has been called. + -- This includes all ASIS processing, since ASIS works on the tree + -- written after gigi has been called. procedure Get_Name_String_And_Append (Id : Name_Id); -- Like Get_Name_String but the resulting characters are appended to @@ -335,6 +336,7 @@ package Namet is -- the name table). If Id is Error_Name, or No_Name, no text is output. procedure wn (Id : Name_Id); + pragma Export (Ada, wn); -- Like Write_Name, but includes new line at end. Intended for use -- from the debugger only. diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h index feb69b713f2..7d53610172b 100644 --- a/gcc/ada/namet.h +++ b/gcc/ada/namet.h @@ -6,9 +6,9 @@ * * * C Header File * * * - * $Revision: 1.1 $ + * $Revision$ * * - * Copyright (C) 1992-2001 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- * @@ -67,7 +67,7 @@ INLINE char * Get_Name_String (Id) Name_Id Id; { - return Name_Chars_Ptr + Names_Ptr [Id - First_Name_Id].Name_Chars_Index + 1; + return Name_Chars_Ptr + Names_Ptr[Id - First_Name_Id].Name_Chars_Index + 1; } /* Get_Decoded_Name_String returns a null terminated C string in the same @@ -84,7 +84,7 @@ Get_Decoded_Name_String (Id) Name_Id Id; { namet__get_decoded_name_string (Id); - Name_Buffer [Name_Len] = 0; + Name_Buffer[Name_Len] = 0; return Name_Buffer; } @@ -93,20 +93,6 @@ Get_Decoded_Name_String (Id) cased. This is used fo rbuilding the enumeration literal table. */ extern void casing__set_all_upper_case PARAMS ((void)); -extern void namet__get_unqualified_decoded_name_string PARAMS ((Name_Id)); - -static char *Get_Upper_Decoded_Name_String PARAMS ((Name_Id)); - -INLINE char * -Get_Upper_Decoded_Name_String (Id) - Name_Id Id; -{ - namet__get_unqualified_decoded_name_string (Id); - if (Name_Buffer [0] != '\'') - casing__set_all_upper_case (); - Name_Buffer [Name_Len] = 0; - return Name_Buffer; -} /* The following routines and variables are not part of Namet, but we include the header here since it seems the best place for it. */ diff --git a/gcc/ada/nlists.h b/gcc/ada/nlists.h index 2080feac4d2..30bf8ee1ca6 100644 --- a/gcc/ada/nlists.h +++ b/gcc/ada/nlists.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * $Revision: 1.1 $ + * $Revision$ * * * Copyright (C) 1992-2001, Free Software Foundation, Inc. * * * @@ -45,16 +45,13 @@ struct List_Header /* The list headers are stored in an array. The pointer to this array is passed as a parameter to gigi and stored in the global variable - List_Headers_Ptr after adjusting it by subtracting List_First_Entry, - so that List_Id values can be used as subscripts. */ + List_Headers_Ptr. */ extern struct List_Header *List_Headers_Ptr; -/* The previous and next links for lists are held in two arrays, Next_Node - and Prev_Node. The pointers to these arrays are passed as parameters - to gigi and stored in the global variables Prev_Node_Ptr and Next_Node_Ptr - after adjusting them by subtracting First_Node_Id so that Node_Id values - can be used as subscripts. */ +/* The previous and next links for lists are held in two arrays, Next_Node and + Prev_Node. The pointers to these arrays are passed as parameters to gigi + and stored in the global variables Prev_Node_Ptr and Next_Node_Ptr. */ extern Node_Id *Next_Node_Ptr; extern Node_Id *Prev_Node_Ptr; @@ -67,11 +64,11 @@ INLINE Node_Id First (List) List_Id List; { - return List_Headers_Ptr [List].first; + return List_Headers_Ptr[List - First_List_Id].first; } #define First_Non_Pragma nlists__first_non_pragma -extern Node_Id First_Non_Pragma PARAMS((Node_Id)); +extern Node_Id First_Non_Pragma PARAMS ((Node_Id)); static Node_Id Last PARAMS ((List_Id)); @@ -79,11 +76,11 @@ INLINE Node_Id Last (List) List_Id List; { - return List_Headers_Ptr [List].last; + return List_Headers_Ptr[List - First_List_Id].last; } #define First_Non_Pragma nlists__first_non_pragma -extern Node_Id First_Non_Pragma PARAMS((List_Id)); +extern Node_Id First_Non_Pragma PARAMS ((List_Id)); static Node_Id Next PARAMS ((Node_Id)); @@ -91,11 +88,11 @@ INLINE Node_Id Next (Node) Node_Id Node; { - return Next_Node_Ptr [Node]; + return Next_Node_Ptr[Node - First_Node_Id]; } #define Next_Non_Pragma nlists__next_non_pragma -extern Node_Id Next_Non_Pragma PARAMS((List_Id)); +extern Node_Id Next_Non_Pragma PARAMS ((List_Id)); static Node_Id Prev PARAMS ((Node_Id)); @@ -103,12 +100,12 @@ INLINE Node_Id Prev (Node) Node_Id Node; { - return Prev_Node_Ptr [Node]; + return Prev_Node_Ptr[Node - First_Node_Id]; } #define Prev_Non_Pragma nlists__prev_non_pragma -extern Node_Id Prev_Non_Pragma PARAMS((Node_Id)); +extern Node_Id Prev_Non_Pragma PARAMS ((Node_Id)); static Boolean Is_Empty_List PARAMS ((List_Id)); static Boolean Is_Non_Empty_List PARAMS ((List_Id)); @@ -133,12 +130,12 @@ INLINE Boolean Is_List_Member (Node) Node_Id Node; { - return Nodes_Ptr [Node].U.K.in_list; + return Nodes_Ptr[Node - First_Node_Id].U.K.in_list; } INLINE List_Id List_Containing (Node) Node_Id Node; { - return Nodes_Ptr [Node].V.NX.link; + return Nodes_Ptr[Node - First_Node_Id].V.NX.link; } diff --git a/gcc/ada/nmake.adb b/gcc/ada/nmake.adb index b80f68685b2..858d5a8540e 100644 --- a/gcc/ada/nmake.adb +++ b/gcc/ada/nmake.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- Generated by xnmake revision 1.2 using -- --- sinfo.ads revision 1.6 -- --- nmake.adt revision 1.1 -- +-- Generated by xnmake revision 1.29 using -- +-- sinfo.ads revision 1.439 -- +-- nmake.adt revision 1.12 -- -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -270,13 +270,15 @@ package body Nmake is end Make_Range; function Make_Enumeration_Type_Definition (Sloc : Source_Ptr; - Literals : List_Id) + Literals : List_Id; + End_Label : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Enumeration_Type_Definition, Sloc); begin Set_Literals (N, Literals); + Set_End_Label (N, End_Label); return N; end Make_Enumeration_Type_Definition; @@ -663,7 +665,8 @@ package body Nmake is function Make_Attribute_Reference (Sloc : Source_Ptr; Prefix : Node_Id; Attribute_Name : Name_Id; - Expressions : List_Id := No_List) + Expressions : List_Id := No_List; + Must_Be_Byte_Aligned : Boolean := False) return Node_Id is N : constant Node_Id := @@ -672,6 +675,7 @@ package body Nmake is Set_Prefix (N, Prefix); Set_Attribute_Name (N, Attribute_Name); Set_Expressions (N, Expressions); + Set_Must_Be_Byte_Aligned (N, Must_Be_Byte_Aligned); return N; end Make_Attribute_Reference; @@ -2756,35 +2760,41 @@ package body Nmake is end Make_Itype_Reference; function Make_Raise_Constraint_Error (Sloc : Source_Ptr; - Condition : Node_Id := Empty) + Condition : Node_Id := Empty; + Reason : Uint) return Node_Id is N : constant Node_Id := New_Node (N_Raise_Constraint_Error, Sloc); begin Set_Condition (N, Condition); + Set_Reason (N, Reason); return N; end Make_Raise_Constraint_Error; function Make_Raise_Program_Error (Sloc : Source_Ptr; - Condition : Node_Id := Empty) + Condition : Node_Id := Empty; + Reason : Uint) return Node_Id is N : constant Node_Id := New_Node (N_Raise_Program_Error, Sloc); begin Set_Condition (N, Condition); + Set_Reason (N, Reason); return N; end Make_Raise_Program_Error; function Make_Raise_Storage_Error (Sloc : Source_Ptr; - Condition : Node_Id := Empty) + Condition : Node_Id := Empty; + Reason : Uint) return Node_Id is N : constant Node_Id := New_Node (N_Raise_Storage_Error, Sloc); begin Set_Condition (N, Condition); + Set_Reason (N, Reason); return N; end Make_Raise_Storage_Error; diff --git a/gcc/ada/nmake.ads b/gcc/ada/nmake.ads index d13f00f29c7..ab774ecf22c 100644 --- a/gcc/ada/nmake.ads +++ b/gcc/ada/nmake.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- Generated by xnmake revision 1.2 using -- --- sinfo.ads revision 1.6 -- --- nmake.adt revision 1.1 -- +-- Generated by xnmake revision 1.29 using -- +-- sinfo.ads revision 1.439 -- +-- nmake.adt revision 1.12 -- -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -178,7 +178,8 @@ package Nmake is pragma Inline (Make_Range); function Make_Enumeration_Type_Definition (Sloc : Source_Ptr; - Literals : List_Id) + Literals : List_Id; + End_Label : Node_Id := Empty) return Node_Id; pragma Inline (Make_Enumeration_Type_Definition); @@ -360,7 +361,8 @@ package Nmake is function Make_Attribute_Reference (Sloc : Source_Ptr; Prefix : Node_Id; Attribute_Name : Name_Id; - Expressions : List_Id := No_List) + Expressions : List_Id := No_List; + Must_Be_Byte_Aligned : Boolean := False) return Node_Id; pragma Inline (Make_Attribute_Reference); @@ -1301,17 +1303,20 @@ package Nmake is pragma Inline (Make_Itype_Reference); function Make_Raise_Constraint_Error (Sloc : Source_Ptr; - Condition : Node_Id := Empty) + Condition : Node_Id := Empty; + Reason : Uint) return Node_Id; pragma Inline (Make_Raise_Constraint_Error); function Make_Raise_Program_Error (Sloc : Source_Ptr; - Condition : Node_Id := Empty) + Condition : Node_Id := Empty; + Reason : Uint) return Node_Id; pragma Inline (Make_Raise_Program_Error); function Make_Raise_Storage_Error (Sloc : Source_Ptr; - Condition : Node_Id := Empty) + Condition : Node_Id := Empty; + Reason : Uint) return Node_Id; pragma Inline (Make_Raise_Storage_Error); diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index 933c8ec9403..4ddc3782253 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.29 $ +-- $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- -- @@ -147,6 +147,7 @@ package body Opt is Tree_Read_Bool (Ada_83_Config); Tree_Read_Bool (All_Errors_Mode); Tree_Read_Bool (Assertions_Enabled); + Tree_Read_Bool (Enable_Overflow_Checks); Tree_Read_Bool (Full_List); -- Read and check version string @@ -174,7 +175,7 @@ package body Opt is Tree_Read_Bool (No_Run_Time); Tree_Read_Data (Operating_Mode'Address, Operating_Mode_Type'Object_Size / Storage_Unit); - Tree_Read_Bool (Software_Overflow_Checking); + Tree_Read_Bool (Suppress_Checks); Tree_Read_Bool (Try_Semantics); Tree_Read_Data (Wide_Character_Encoding_Method'Address, WC_Encoding_Method'Object_Size / Storage_Unit); @@ -200,6 +201,7 @@ package body Opt is Tree_Write_Bool (Ada_83_Config); Tree_Write_Bool (All_Errors_Mode); Tree_Write_Bool (Assertions_Enabled); + Tree_Write_Bool (Enable_Overflow_Checks); Tree_Write_Bool (Full_List); Tree_Write_Int (Int (Gnat_Version_String'Length)); Tree_Write_Data (Gnat_Version_String'Address, @@ -213,7 +215,7 @@ package body Opt is Tree_Write_Bool (No_Run_Time); Tree_Write_Data (Operating_Mode'Address, Operating_Mode_Type'Object_Size / Storage_Unit); - Tree_Write_Bool (Software_Overflow_Checking); + Tree_Write_Bool (Suppress_Checks); Tree_Write_Bool (Try_Semantics); Tree_Write_Data (Wide_Character_Encoding_Method'Address, WC_Encoding_Method'Object_Size / Storage_Unit); diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 5dcc8c7de48..66e239f81a1 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -33,10 +33,10 @@ -- -- ------------------------------------------------------------------------------ --- This package contains global switches set by the initialization +-- This package contains global flags set by the initialization -- routine from the command line and referenced throughout the compiler, --- the binder or gnatmake. The comments indicate which options are used by --- which programs (GNAT, GNATBIND, GNATMAKE). +-- the binder, gnatmake or other GNAT tools. The comments indicate which +-- options are used by which programs (GNAT, GNATBIND, GNATMAKE, etc). with Hostparm; use Hostparm; with Types; use Types; @@ -56,7 +56,7 @@ package Opt is -- the default values. Ada_Bind_File : Boolean := True; - -- GNATBIND + -- GNATBIND, GNATLINK -- Set True if binder file to be generated in Ada rather than C Ada_95 : Boolean := True; @@ -70,20 +70,12 @@ package Opt is -- Set False if operating in Ada 95 mode Ada_Final_Suffix : constant String := "final"; - -- GNATBIND - -- The suffix of the name of the finalization procedure. This variable - -- may be modified by Gnatbind.Scan_Bind_Arg. - Ada_Final_Name : String_Ptr := new String'("ada" & Ada_Final_Suffix); -- GNATBIND -- The name of the procedure that performs the finalization at the end of -- execution. This variable may be modified by Gnatbind.Scan_Bind_Arg. Ada_Init_Suffix : constant String := "init"; - -- GNATBIND - -- The suffix of the name of the initialization procedure. This variable - -- may be modified by Gnatbind.Scan_Bind_Arg. - Ada_Init_Name : String_Ptr := new String'("ada" & Ada_Init_Suffix); -- GNATBIND -- The name of the procedure that performs initialization at the start @@ -117,6 +109,7 @@ package Opt is -- directly modified by gnatmake to affect the shared binder routines. Alternate_Main_Name : String_Ptr := null; + -- GNATBIND -- Set to non null when Bind_Alternate_Main_Name is True. This value -- is modified as needed by Gnatbind.Scan_Bind_Arg. @@ -131,8 +124,8 @@ package Opt is Bind_Alternate_Main_Name : Boolean := False; -- GNATBIND - -- Set to True if main should be called Alternate_Main_Name.all. This - -- variable may be set to True by Gnatbind.Scan_Bind_Arg. + -- True if main should be called Alternate_Main_Name.all. + -- This variable may be set to True by Gnatbind.Scan_Bind_Arg. Bind_Main_Program : Boolean := True; -- GNATBIND @@ -156,12 +149,12 @@ package Opt is Check_Object_Consistency : Boolean := False; -- GNATBIND, GNATMAKE -- Set to True to check whether every object file is consistent with - -- with its corresponding ada library information (ali) file. An object - -- file is inconsistent with the corresponding ali file if the object - -- file does not exist or if it has an older time stamp than the ali file. + -- its corresponding ada library information (ALI) file. An object + -- file is inconsistent with the corresponding ALI file if the object + -- file does not exist or if it has an older time stamp than the ALI file. -- Default above is for GNATBIND. GNATMAKE overrides this default to - -- True (see Make.Initialize) since we do not need to check source - -- consistencies in gnatmake in this sense. + -- True (see Make.Initialize) since we normally do need to check source + -- consistencies in gnatmake. Check_Only : Boolean := False; -- GNATBIND @@ -172,7 +165,7 @@ package Opt is -- Set to True to check readonly files during the make process. Check_Source_Files : Boolean := True; - -- GNATBIND + -- GNATBIND, GNATMAKE -- Set to True to enable consistency checking for any source files that -- are present (i.e. date must match the date in the library info file). -- Set to False for object file consistency check only. This flag is @@ -184,7 +177,13 @@ package Opt is Check_Unreferenced : Boolean := False; -- GNAT - -- Set to True to enable checking for unreferenced variables + -- Set to True to enable checking for unreferenced entities other + -- than formal parameters (for which see Check_Unreferenced_Formals) + + Check_Unreferenced_Formals : Boolean := False; + -- GNAT + -- Set True to check for unreferenced formals. This is turned + -- on by -gnatwa/wf/wu and turned off by -gnatwA/wF/wU. Check_Withs : Boolean := False; -- GNAT @@ -196,7 +195,7 @@ package Opt is -- Set to True to skip bind and link steps (except when Bind_Only is True) Compress_Debug_Names : Boolean := False; - -- GNATMAKE + -- GNAT -- Set to True if the option to compress debug information is set (-gnatC) Config_File : Boolean := True; @@ -211,6 +210,11 @@ package Opt is -- GNAT -- Set to True to activate warnings on constant conditions + Create_Mapping_File : Boolean := False; + -- GNATMAKE + -- Set to True (-C switch) to indicate that gnatmake + -- invokes the compiler with a mapping file (-gnatem compiler switch). + subtype Debug_Level_Value is Nat range 0 .. 3; Debugger_Level : Debug_Level_Value := 0; -- GNATBIND @@ -229,7 +233,7 @@ package Opt is Display_Compilation_Progress : Boolean := False; -- GNATMAKE -- Set True (-d switch) to display information on progress while compiling - -- files. Internal switch to be used in conjunction with an IDE such as + -- files. Internal flag to be used in conjunction with an IDE such as -- Glide. type Distribution_Stub_Mode_Type is @@ -271,12 +275,20 @@ package Opt is -- GNAT -- Set to True to generate full elaboration warnings (-gnatwl) + Enable_Overflow_Checks : Boolean := False; + -- GNAT + -- Set to True if -gnato (enable overflow checks) switch is set, + -- but not -gnatp. + type Exception_Mechanism_Type is (Setjmp_Longjmp, Front_End_ZCX, GCC_ZCX); + pragma Convention (C, Exception_Mechanism_Type); + Exception_Mechanism : Exception_Mechanism_Type := Setjmp_Longjmp; -- GNAT -- Set to the appropriate value depending on the default as given in -- system.ads (ZCX_By_Default, GCC_ZCX_Support, Front_End_ZCX_Support) - -- and the use of -gnatL -gnatZ (and -gnatdX) + -- and the use of -gnatL -gnatZ (and -gnatdX). The C convention is + -- there to make this variable accessible to gigi. Exception_Tracebacks : Boolean := False; -- GNATBIND @@ -284,6 +296,8 @@ package Opt is Extensions_Allowed : Boolean := False; -- GNAT + -- Set to True by switch -gnatX if GNAT specific language extensions + -- are allowed. For example, "with type" is a GNAT extension. type External_Casing_Type is ( As_Is, -- External names cased as they appear in the Ada source @@ -291,7 +305,8 @@ package Opt is Lowercase); -- External names forced to all lowercase letters External_Name_Imp_Casing : External_Casing_Type := Lowercase; - -- The setting of this switch determines the casing of external names + -- GNAT + -- The setting of this flag determines the casing of external names -- when the name is implicitly derived from an entity name (i.e. either -- no explicit External_Name or Link_Name argument is used, or, in the -- case of extended DEC pragmas, the external name is given using an @@ -299,7 +314,8 @@ package Opt is -- create Ada source programs that were case sensitive). External_Name_Exp_Casing : External_Casing_Type := As_Is; - -- The setting of this switch determines the casing of an external name + -- GNAT + -- The setting of this flag determines the casing of an external name -- specified explicitly with a string literal. As_Is means the string -- literal is used as given with no modification to the casing. If -- Lowercase or Uppercase is set, then the string is forced to all @@ -326,7 +342,7 @@ package Opt is Force_ALI_Tree_File : Boolean := False; -- GNAT - -- Force generation of ali file even if errors are encountered. + -- Force generation of ALI file even if errors are encountered. -- Also forces generation of tree file if -gnatt is also set. Force_Compilations : Boolean := False; @@ -337,7 +353,7 @@ package Opt is -- GNATBIND -- True if binding with forced RM elaboration order (-f switch set) -- Note: this is considered an obsolescent option, to be removed in - -- some future release. it is no longer documented. The proper way + -- some future release. It is no longer documented. The proper way -- to get this effect is to use -gnatE and suppress elab checks. Full_List : Boolean := False; @@ -350,11 +366,11 @@ package Opt is GNAT_Mode : Boolean := False; -- GNAT - -- True if compiling in GNAT system mode (-g switch set) + -- True if compiling in GNAT system mode (-gnatg switch) HLO_Active : Boolean := False; -- GNAT - -- True if High Level Optimizer is activated + -- True if High Level Optimizer is activated (-gnatH switch) Implementation_Unit_Warnings : Boolean := True; -- GNAT @@ -365,10 +381,12 @@ package Opt is -- GNAT -- This variable indicates the character set to be used for identifiers. -- The possible settings are: - -- '1' Latin-1 - -- '2' Latin-2 - -- '3' Latin-3 - -- '4' Latin-4 + -- '1' Latin-5 (ISO-8859-1) + -- '2' Latin-5 (ISO-8859-2) + -- '3' Latin-5 (ISO-8859-3) + -- '4' Latin-5 (ISO-8859-4) + -- '5' Latin-5 (ISO-8859-5, Cyrillic) + -- '9' Latin-5 (ISO-8859-9) -- 'p' PC (US, IBM page 437) -- '8' PC (European, IBM page 850) -- 'f' Full upper set (all distinct) @@ -438,19 +456,24 @@ package Opt is -- Set to True to skip compile and bind steps -- (except when Bind_Only is set to True). + List_Restrictions : Boolean := False; + -- GNATBIND + -- Set to True to list restrictions pragmas that could apply to partition + List_Units : Boolean := False; -- GNAT - -- List units in the active library + -- List units in the active library for a compilation (-gnatu switch) List_Dependencies : Boolean := False; -- GNATMAKE -- When True gnatmake verifies that the objects are up to date and - -- outputs the list of object dependencies. This list can be used - -- directly in a Makefile. + -- outputs the list of object dependencies (-M switch). + -- Output depends if -a switch is used or not. + -- This list can be used directly in a Makefile. List_Representation_Info : Int range 0 .. 3 := 0; -- GNAT - -- Set true by -gnatR switch to list representation information. + -- Set non-zero by -gnatR switch to list representation information. -- The settings are as follows: -- -- 0 = no listing of representation information (default as above) @@ -458,6 +481,29 @@ package Opt is -- 2 = list rep info for all user defined types and objects -- 3 = like 2, but variable fields are decoded symbolically + List_Representation_Info_To_File : Boolean := False; + -- GNAT + -- Set true by -gnatRs switch. Causes information from -gnatR/1/2/3 + -- to be written to file.rep (where file is the name of the source + -- file) instead of stdout. For example, if file x.adb is compiled + -- using -gnatR2s then representation info is written to x.adb.ref. + + type Creat_Repinfo_File_Proc is access procedure (Src : File_Name_Type); + type Write_Repinfo_Line_Proc is access procedure (Info : String); + type Close_Repinfo_File_Proc is access procedure; + -- Types used for procedure addresses below + + Creat_Repinfo_File_Access : Creat_Repinfo_File_Proc := null; + Write_Repinfo_Line_Access : Write_Repinfo_Line_Proc := null; + Close_Repinfo_File_Access : Close_Repinfo_File_Proc := null; + -- GNAT + -- These three locations are left null when operating in non-compiler + -- (e.g. ASIS mode), but when operating in compiler mode, they are + -- set to point to the three corresponding procedures in Osint. The + -- reason for this slightly strange interface is to prevent Repinfo + -- from dragging in Osint in ASIS mode, which would include a lot of + -- unwanted units in the ASIS build. + Locking_Policy : Character := ' '; -- GNAT -- Set to ' ' for the default case (no locking policy specified). @@ -495,11 +541,11 @@ package Opt is -- Set to True if minimal recompilation mode requested. No_Stdlib : Boolean := False; - -- GNATMAKE + -- GNATMAKE, GNATBIND, GNATFIND, GNATXREF -- Set to True if no default library search dirs added to search list. No_Stdinc : Boolean := False; - -- GNATMAKE + -- GNAT, GNATBIND, GNATMAKE, GNATFIND, GNATXREF -- Set to True if no default source search dirs added to search list. No_Main_Subprogram : Boolean := False; @@ -529,10 +575,11 @@ package Opt is -- after generating an error message. Output_File_Name_Present : Boolean := False; - -- GNATBIND, GNAT + -- GNATBIND, GNAT, GNATMAKE -- Set to True when the output C file name is given with option -o - -- for GNATBIND or when the object file name is given with option - -- -gnatO for GNAT. + -- for GNATBIND, when the object file name is given with option + -- -gnatO for GNAT or when the executable is given with option -o + -- for GNATMAKE. Output_Linker_Option_List : Boolean := False; -- GNATBIND @@ -564,7 +611,7 @@ package Opt is Queuing_Policy : Character := ' '; -- GNAT - -- Set to ' ' for the default case (no queuing policy specified). Reset to + -- Set to ' ' for the default case (no queuing policy specified). -- Reset to first character (uppercase) of locking policy name if a valid -- Queuing_Policy pragma is encountered. @@ -572,18 +619,15 @@ package Opt is -- GNATMAKE -- Set to True if the list of compilation commands should not be output. + RTS_Switch : Boolean := False; + -- GNAT, GNATMAKE, GNATBIND, GNATLS, GNATFIND, GNATXREF + -- Set to True when the --RTS switch is set + Shared_Libgnat : Boolean; -- GNATBIND -- Set to True if a shared libgnat is requested by using the -shared -- option for GNATBIND and to False when using the -static option. The - -- value of this switch is set by Gnatbind.Scan_Bind_Arg. - - Software_Overflow_Checking : Boolean; - -- GNAT - -- Set to True by Osint.Initialize if the target requires the software - -- approach to integer arithmetic overflow checking (i.e. the use of - -- double length arithmetic followed by a range check). Set to False - -- if the target implements hardware overflow checking. + -- value of this flag is set by Gnatbind.Scan_Bind_Arg. Stack_Checking_Enabled : Boolean; -- GNAT @@ -594,17 +638,6 @@ package Opt is -- in the gcc backend (see Frontend) and may be referenced throughout -- the compilation phases. - Strict_Math : aliased Boolean := False; - -- GNAT - -- This switch is set True if the current unit is to be compiled in - -- strict math mode. The effect is to cause certain library file name - -- substitutions to implement strict math semantics. See the routine - -- Adjust_File_Name_For_Configuration, and also the configuration - -- in the body of Opt. - -- - -- Note: currently this switch is always False. Eventually it will be - -- settable by a switch and a configuration pragma. - Style_Check : Boolean := False; -- GNAT -- Set True to perform style checks. Activates checks carried out @@ -618,9 +651,14 @@ package Opt is -- be located as Chars (Expression (System_Extend_Pragma_Arg)). Subunits_Missing : Boolean := False; + -- GNAT -- This flag is set true if missing subunits are detected with code -- generation active. This causes code generation to be skipped. + Suppress_Checks : Boolean := False; + -- GNAT + -- Set to True if -gnatp (suppress all checks) switch present. + Suppress_Options : Suppress_Record; -- GNAT -- Flags set True to suppress corresponding check, i.e. add an implicit @@ -629,6 +667,7 @@ package Opt is -- pragma. This variable is initialized by Osint.Initialize. Table_Factor : Int := 1; + -- GNAT -- Factor by which all initial table sizes set in Alloc are multiplied. -- Used in Table to calculate initial table sizes (the initial table -- size is the value in Alloc, used as the Table_Initial parameter @@ -643,34 +682,38 @@ package Opt is Tasking_Used : Boolean := False; -- Set True if any tasking construct is encountered. Used to activate the - -- output of the Q, L and T lines in ali files. + -- output of the Q, L and T lines in ALI files. Time_Slice_Set : Boolean := False; + -- GNATBIND -- Set True if a pragma Time_Slice is processed in the main unit, or - -- if the T switch is present to set a time slice value. + -- if the -gnatTnn switch is present to set a time slice value. Time_Slice_Value : Nat; + -- GNATBIND -- Time slice value. Valid only if Time_Slice_Set is True, i.e. if a -- Time_Slice pragma has been processed. Set to the time slice value -- in microseconds. Negative values are stored as zero, and the value -- is not larger than 1_000_000_000 (1000 seconds). Values larger than - -- this are reset to this maximum. + -- this are reset to this maximum. This can also be set with the -gnatTnn + -- switch. Tolerate_Consistency_Errors : Boolean := False; -- GNATBIND - -- Tolerate time stamp and other consistency errors. If this switch is - -- set true, then inconsistencies result in warnings rather than errors. + -- Tolerate time stamp and other consistency errors. If this flag is + -- set to True (-t), then inconsistencies result in warnings rather than + -- errors. Tree_Output : Boolean := False; -- GNAT - -- Set True to generate output tree file + -- Set to True (-gnatt) to generate output tree file Try_Semantics : Boolean := False; -- GNAT -- Flag set to force attempt at semantic analysis, even if parser errors -- occur. This will probably cause blowups at this stage in the game. On -- the other hand, most such blowups will be caught cleanly and simply - -- say compilation abandoned. + -- say compilation abandoned. This flag is set to True by -gnatq or -gnatQ. Unique_Error_Tag : Boolean := Tag_Errors; -- GNAT @@ -693,23 +736,26 @@ package Opt is Usage_Requested : Boolean := False; -- GNAT, GNATBIND, GNATMAKE - -- Set to True if h switch encountered requesting usage information + -- Set to True if -h (-gnath for the compiler) switch encountered + -- requesting usage information Use_VADS_Size : Boolean := False; -- GNAT -- Set to True if a valid pragma Use_VADS_Size is processed Validity_Checks_On : Boolean := True; + -- GNAT -- This flag determines if validity checking is on or off. The initial -- state is on, and the required default validity checks are active. The -- actual set of checks that is performed if Validity_Checks_On is set -- is defined by the switches in package Sem_Val. The Validity_Checks_On - -- switch is controlled by pragma Validity_Checks (On | Off), and also + -- flag is controlled by pragma Validity_Checks (On | Off), and also -- some generated compiler code (typically code that has to do with - -- validity check generation) is compiled with this switch set to False. + -- validity check generation) is compiled with this flag set to False. + -- This flag is set to False by the -gnatp switch. Verbose_Mode : Boolean := False; - -- GNAT, GNATBIND + -- GNAT, GNATBIND, GNATMAKE, GNATLINK, GNATLS, GNATCHOP, GNATNAME -- Set to True to get verbose mode (full error message text and location -- information sent to standard output, also header, copyright and summary) @@ -719,6 +765,11 @@ package Opt is -- in a manner inconsistent with unbiased rounding (round to even). Can -- be modified by use of -gnatwb/B. + Warn_On_Dereference : Boolean := False; + -- GNAT + -- Set to True to generate warnings for implicit dereferences for array + -- indexing and record component access. Modified by use of -gnatwd/D. + Warn_On_Hiding : Boolean := False; -- GNAT -- Set to True to generate warnings if a declared entity hides another @@ -745,12 +796,12 @@ package Opt is -- recognized in source programs regardless of the setting of this -- variable. The default setting causes only the brackets notation -- to be recognized. If this is the main unit, this setting also - -- controls the output of the W=? parameter in the ali file, which + -- controls the output of the W=? parameter in the ALI file, which -- is used to provide the default for Wide_Text_IO files. Xref_Active : Boolean := True; -- GNAT - -- Set if cross-referencing is enabled (i.e. xref info in ali files) + -- Set if cross-referencing is enabled (i.e. xref info in ALI files) Zero_Cost_Exceptions_Val : Boolean; Zero_Cost_Exceptions_Set : Boolean := False; @@ -759,7 +810,6 @@ package Opt is -- handling mode set by argument switches (-gnatZ/-gnatL). If the -- value is set by one of these switches, then Zero_Cost_Exceptions_Set -- is set to True, and Zero_Cost_Exceptions_Val indicates the setting. - -- This value is used to reset ZCX_By_Default_On_Target. ---------------------------- -- Configuration Settings -- @@ -776,7 +826,7 @@ package Opt is -- by the command line switch -gnat83, and possibly modified by the use -- of configuration pragmas Ada_95 and Ada_83 in the gnat.adc file. This -- switch is used to set the initial value for Ada_83 mode at the start - -- of analysis of a unit. Note however, that the setting of this switch + -- of analysis of a unit. Note however, that the setting of this flag -- is ignored for internal and predefined units (which are always compiled -- in Ada 95 mode). @@ -787,7 +837,7 @@ package Opt is Extensions_Allowed_Config : Boolean; -- GNAT - -- This is the switch that indicates whether extensions are allowed. + -- This is the flag that indicates whether extensions are allowed. -- It can be set True either by use of the -gnatX switch, or by use -- of the configuration pragma Extensions_Allowed (On). It is always -- set to True for internal GNAT units, since extensions are always @@ -799,9 +849,9 @@ package Opt is -- of external symbols for which an explicit external name is given. It -- can be set to Uppercase by the command line switch -gnatF, and further -- modified by the use of the configuration pragma External_Name_Casing - -- in the gnat.adc file. This switch is used to set the initial value + -- in the gnat.adc file. This flag is used to set the initial value -- for External_Name_Exp_Casing at the start of analyzing each unit. - -- Note however that the setting of this switch is ignored for internal + -- Note however that the setting of this flag is ignored for internal -- and predefined units (which are always compiled with As_Is mode). External_Name_Imp_Casing_Config : External_Casing_Type; @@ -810,9 +860,9 @@ package Opt is -- of external symbols where the external name is implicitly given. It -- can be set to Uppercase by the command line switch -gnatF, and further -- modified by the use of the configuration pragma External_Name_Casing - -- in the gnat.adc file. This switch is used to set the initial value + -- in the gnat.adc file. This flag is used to set the initial value -- for External_Name_Imp_Casing at the start of analyzing each unit. - -- Note however that the setting of this switch is ignored for internal + -- Note however that the setting of this flag is ignored for internal -- and predefined units (which are always compiled with Lowercase mode). Polling_Required_Config : Boolean; @@ -820,7 +870,7 @@ package Opt is -- This is the value of the configuration switch that controls polling -- mode. It can be set True by the command line switch -gnatP, and then -- further modified by the use of pragma Polling in the gnat.adc file. - -- This switch is used to set the initial value for Polling_Required + -- This flag is used to set the initial value for Polling_Required -- at the start of analyzing each unit. Use_VADS_Size_Config : Boolean; @@ -828,9 +878,9 @@ package Opt is -- This is the value of the configuration switch that controls the use -- of VADS_Size instead of Size whereever the attribute Size is used. -- It can be set True by the use of the pragma Use_VADS_Size in the - -- gnat.adc file. This switch is used to set the initial value for + -- gnat.adc file. This flag is used to set the initial value for -- Use_VADS_Size at the start of analyzing each unit. Note however that - -- the setting of this switch is ignored for internal and predefined + -- the setting of this flag is ignored for internal and predefined -- units (which are always compiled with the standard Size semantics). type Config_Switches_Type is private; diff --git a/gcc/ada/osint-b.adb b/gcc/ada/osint-b.adb new file mode 100644 index 00000000000..d793bd1ab23 --- /dev/null +++ b/gcc/ada/osint-b.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - B -- +-- -- +-- B o d y -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 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. -- +-- -- +-- 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 Hostparm; +with Namet; use Namet; +with Opt; use Opt; + +package body Osint.B is + + Binder_Output_Time_Stamps_Set : Boolean := False; + + Old_Binder_Output_Time_Stamp : Time_Stamp_Type; + New_Binder_Output_Time_Stamp : Time_Stamp_Type; + Recording_Time_From_Last_Bind : Boolean := False; + + ------------------------- + -- Close_Binder_Output -- + ------------------------- + + procedure Close_Binder_Output is + begin + Close (Output_FD); + + if Recording_Time_From_Last_Bind then + New_Binder_Output_Time_Stamp := File_Stamp (Output_File_Name); + Binder_Output_Time_Stamps_Set := True; + end if; + end Close_Binder_Output; + + -------------------------- + -- Create_Binder_Output -- + -------------------------- + + procedure Create_Binder_Output + (Output_File_Name : String; + Typ : Character; + Bfile : out Name_Id) + is + File_Name : String_Ptr; + Findex1 : Natural; + Findex2 : Natural; + Flength : Natural; + + begin + if Output_File_Name /= "" then + Name_Buffer (Output_File_Name'Range) := Output_File_Name; + Name_Buffer (Output_File_Name'Last + 1) := ASCII.NUL; + + if Typ = 's' then + Name_Buffer (Output_File_Name'Last) := 's'; + end if; + + Name_Len := Output_File_Name'Last; + + else + Name_Buffer (1) := 'b'; + File_Name := File_Names (Current_File_Name_Index); + + Findex1 := File_Name'First; + + -- The ali file might be specified by a full path name. However, + -- the binder generated file should always be created in the + -- current directory, so the path might need to be stripped away. + -- In addition to the default directory_separator allow the '/' to + -- act as separator since this is allowed in MS-DOS and OS2 ports. + + for J in reverse File_Name'Range loop + if File_Name (J) = Directory_Separator + or else File_Name (J) = '/' + then + Findex1 := J + 1; + exit; + end if; + end loop; + + Findex2 := File_Name'Last; + while File_Name (Findex2) /= '.' loop + Findex2 := Findex2 - 1; + end loop; + + Flength := Findex2 - Findex1; + + if Maximum_File_Name_Length > 0 then + + -- Make room for the extra two characters in "b?" + + while Int (Flength) > Maximum_File_Name_Length - 2 loop + Findex2 := Findex2 - 1; + Flength := Findex2 - Findex1; + end loop; + end if; + + Name_Buffer (3 .. Flength + 2) := File_Name (Findex1 .. Findex2 - 1); + Name_Buffer (Flength + 3) := '.'; + + -- C bind file, name is b_xxx.c + + if Typ = 'c' then + Name_Buffer (2) := '_'; + Name_Buffer (Flength + 4) := 'c'; + Name_Buffer (Flength + 5) := ASCII.NUL; + Name_Len := Flength + 4; + + -- Ada bind file, name is b~xxx.adb or b~xxx.ads + -- (with $ instead of ~ in VMS) + + else + if Hostparm.OpenVMS then + Name_Buffer (2) := '$'; + else + Name_Buffer (2) := '~'; + end if; + + Name_Buffer (Flength + 4) := 'a'; + Name_Buffer (Flength + 5) := 'd'; + Name_Buffer (Flength + 6) := Typ; + Name_Buffer (Flength + 7) := ASCII.NUL; + Name_Len := Flength + 6; + end if; + end if; + + Bfile := Name_Find; + + if Recording_Time_From_Last_Bind then + Old_Binder_Output_Time_Stamp := File_Stamp (Bfile); + end if; + + Create_File_And_Check (Output_FD, Text); + end Create_Binder_Output; + + -------------------- + -- More_Lib_Files -- + -------------------- + + function More_Lib_Files return Boolean renames More_Files; + + ------------------------ + -- Next_Main_Lib_File -- + ------------------------ + + function Next_Main_Lib_File return File_Name_Type renames Next_Main_File; + + -------------------------------- + -- Record_Time_From_Last_Bind -- + -------------------------------- + + procedure Record_Time_From_Last_Bind is + begin + Recording_Time_From_Last_Bind := True; + end Record_Time_From_Last_Bind; + + ------------------------- + -- Time_From_Last_Bind -- + ------------------------- + + function Time_From_Last_Bind return Nat is + Old_Y : Nat; + Old_M : Nat; + Old_D : Nat; + Old_H : Nat; + Old_Mi : Nat; + Old_S : Nat; + New_Y : Nat; + New_M : Nat; + New_D : Nat; + New_H : Nat; + New_Mi : Nat; + New_S : Nat; + + type Month_Data is array (Int range 1 .. 12) of Int; + Cumul : constant Month_Data := (0, 0, 3, 3, 4, 4, 5, 5, 5, 6, 6, 7); + -- Represents the difference in days from a period compared to the + -- same period if all months had 31 days, i.e: + -- + -- Cumul (m) = 31x(m-1) - (number of days from 01/01 to m/01) + + Res : Int; + + begin + if not Recording_Time_From_Last_Bind + or else not Binder_Output_Time_Stamps_Set + or else Old_Binder_Output_Time_Stamp = Empty_Time_Stamp + then + return Nat'Last; + end if; + + Split_Time_Stamp + (Old_Binder_Output_Time_Stamp, + Old_Y, Old_M, Old_D, Old_H, Old_Mi, Old_S); + + Split_Time_Stamp + (New_Binder_Output_Time_Stamp, + New_Y, New_M, New_D, New_H, New_Mi, New_S); + + Res := New_Mi - Old_Mi; + + -- 60 minutes in an hour + + Res := Res + 60 * (New_H - Old_H); + + -- 24 hours in a day + + Res := Res + 60 * 24 * (New_D - Old_D); + + -- Almost 31 days in a month + + Res := Res + 60 * 24 * + (31 * (New_M - Old_M) - Cumul (New_M) + Cumul (Old_M)); + + -- 365 days in a year + + Res := Res + 60 * 24 * 365 * (New_Y - Old_Y); + + return Res; + end Time_From_Last_Bind; + + ----------------------- + -- Write_Binder_Info -- + ----------------------- + + procedure Write_Binder_Info (Info : String) renames Write_Info; + +begin + Set_Program (Binder); +end Osint.B; diff --git a/gcc/ada/osint-b.ads b/gcc/ada/osint-b.ads new file mode 100644 index 00000000000..580974ce60e --- /dev/null +++ b/gcc/ada/osint-b.ads @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - B -- +-- -- +-- S p e c -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the low level, operating system routines used only +-- in the GNAT binder for command line processing and file input output. + +package Osint.B is + + procedure Record_Time_From_Last_Bind; + -- Trigger the computing of the time from the last bind of the same + -- program. + + function More_Lib_Files return Boolean; + -- Indicates whether more library information files remain to be processed. + -- Returns False right away if no source files, or if all source files + -- have been processed. + + function Next_Main_Lib_File return File_Name_Type; + -- This function returns the name of the next library info file specified + -- on the command line. It is an error to call Next_Main_Lib_File if no + -- more library information files exist (i.e. Next_Main_Lib_File may be + -- called only if a previous call to More_Lib_Files returned True). This + -- name is the simple name, excluding any directory information. + + function Time_From_Last_Bind return Nat; + -- This function give an approximate number of minute from the last bind. + -- It bases its computation on file stamp and therefore does gibe not + -- any meaningful result before the new output binder file is written. + -- So it returns Nat'last if: + -- + -- - it is the first bind of this specific program + -- - Record_Time_From_Last_Bind was not Called first + -- - Close_Binder_Output was not called first + -- + -- otherwise it returns the number of minutes from the last bind. The + -- computation does not try to be completely accurate and in particular + -- does not take leap years into account. + + ------------------- + -- Binder Output -- + ------------------- + + -- These routines are used by the binder to generate the C source file + -- containing the binder output. The format of this file is described + -- in the package Bindfmt. + + procedure Create_Binder_Output + (Output_File_Name : String; + Typ : Character; + Bfile : out Name_Id); + -- Creates the binder output file. Typ is one of + -- + -- 'c' create output file for case of generating C + -- 'b' create body file for case of generating Ada + -- 's' create spec file for case of generating Ada + -- + -- If Output_File_Name is null, then a default name is used based on + -- the name of the most recently accessed main source file name. If + -- Output_File_Name is non-null then it is the full path name of the + -- file to be output (in the case of Ada, it must have an extension + -- of adb, and the spec file is created by changing the last character + -- from b to s. On return, Bfile also contains the Name_Id for the + -- generated file name. + + procedure Write_Binder_Info (Info : String); + -- Writes the contents of the referenced string to the binder output file + -- created by a previous call to Create_Binder_Output. Info represents a + -- single line in the file, but does not contain any line termination + -- characters. The implementation of Write_Binder_Info is responsible + -- for adding necessary end of line and end of file control characters + -- as required by the operating system. + + procedure Close_Binder_Output; + -- Closes the file created by Create_Binder_Output, flushing any + -- buffers etc from writes by Write_Binder_Info. + +end Osint.B; diff --git a/gcc/ada/osint-c.adb b/gcc/ada/osint-c.adb new file mode 100644 index 00000000000..40198cd00fd --- /dev/null +++ b/gcc/ada/osint-c.adb @@ -0,0 +1,380 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - C -- +-- -- +-- B o d y -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 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. -- +-- -- +-- 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 Hostparm; +with Namet; use Namet; +with Opt; use Opt; +with Tree_IO; use Tree_IO; + +package body Osint.C is + + Output_Object_File_Name : String_Ptr; + -- Argument of -o compiler option, if given. This is needed to + -- verify consistency with the ALI file name. + + procedure Adjust_OS_Resource_Limits; + pragma Import (C, Adjust_OS_Resource_Limits, + "__gnat_adjust_os_resource_limits"); + -- Procedure to make system specific adjustments to make GNAT + -- run better. + + function Create_Auxiliary_File + (Src : File_Name_Type; + Suffix : String) + return File_Name_Type; + -- Common processing for Creat_Repinfo_File and Create_Debug_File. + -- Src is the file name used to create the required output file and + -- Suffix is the desired suffic (dg/rep for debug/repinfo file). + + procedure Set_Library_Info_Name; + -- Sets a default ali file name from the main compiler source name. + -- This is used by Create_Output_Library_Info, and by the version of + -- Read_Library_Info that takes a default file name. + + ---------------------- + -- Close_Debug_File -- + ---------------------- + + procedure Close_Debug_File is + begin + Close (Output_FD); + end Close_Debug_File; + + ------------------------------- + -- Close_Output_Library_Info -- + ------------------------------- + + procedure Close_Output_Library_Info is + begin + Close (Output_FD); + end Close_Output_Library_Info; + + ------------------------ + -- Close_Repinfo_File -- + ------------------------ + + procedure Close_Repinfo_File is + begin + Close (Output_FD); + end Close_Repinfo_File; + + --------------------------- + -- Create_Auxiliary_File -- + --------------------------- + + function Create_Auxiliary_File + (Src : File_Name_Type; + Suffix : String) + return File_Name_Type + is + Result : File_Name_Type; + + begin + Get_Name_String (Src); + + if Hostparm.OpenVMS then + Name_Buffer (Name_Len + 1) := '_'; + else + Name_Buffer (Name_Len + 1) := '.'; + end if; + + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; + Name_Len := Name_Len + Suffix'Length; + + if Output_Object_File_Name /= null then + + for Index in reverse Output_Object_File_Name'Range loop + + if Output_Object_File_Name (Index) = Directory_Separator then + declare + File_Name : constant String := Name_Buffer (1 .. Name_Len); + + begin + Name_Len := Index - Output_Object_File_Name'First + 1; + Name_Buffer (1 .. Name_Len) := + Output_Object_File_Name + (Output_Object_File_Name'First .. Index); + Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) := + File_Name; + Name_Len := Name_Len + File_Name'Length; + end; + + exit; + end if; + end loop; + end if; + + Result := Name_Find; + Name_Buffer (Name_Len + 1) := ASCII.NUL; + Create_File_And_Check (Output_FD, Text); + return Result; + end Create_Auxiliary_File; + + ----------------------- + -- Create_Debug_File -- + ----------------------- + + function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is + begin + return Create_Auxiliary_File (Src, "dg"); + end Create_Debug_File; + + -------------------------------- + -- Create_Output_Library_Info -- + -------------------------------- + + procedure Create_Output_Library_Info is + begin + Set_Library_Info_Name; + Create_File_And_Check (Output_FD, Text); + end Create_Output_Library_Info; + + -------------------------- + -- Creat_Repinfo_File -- + -------------------------- + + procedure Creat_Repinfo_File (Src : File_Name_Type) is + S : constant File_Name_Type := Create_Auxiliary_File (Src, "rep"); + pragma Warnings (Off, S); + + begin + return; + end Creat_Repinfo_File; + + --------------------------- + -- Debug_File_Eol_Length -- + --------------------------- + + function Debug_File_Eol_Length return Nat is + begin + -- There has to be a cleaner way to do this! ??? + + if Directory_Separator = '/' then + return 1; + else + return 2; + end if; + end Debug_File_Eol_Length; + + ----------------------- + -- More_Source_Files -- + ----------------------- + + function More_Source_Files return Boolean renames More_Files; + + ---------------------- + -- Next_Main_Source -- + ---------------------- + + function Next_Main_Source return File_Name_Type renames Next_Main_File; + + ----------------------- + -- Read_Library_Info -- + ----------------------- + + -- Version with default file name + + procedure Read_Library_Info + (Name : out File_Name_Type; + Text : out Text_Buffer_Ptr) + is + begin + Set_Library_Info_Name; + Name := Name_Find; + Text := Read_Library_Info (Name, Fatal_Err => False); + end Read_Library_Info; + + --------------------------- + -- Set_Library_Info_Name -- + --------------------------- + + procedure Set_Library_Info_Name is + Dot_Index : Natural; + + begin + Get_Name_String (Current_Main); + + -- Find last dot since we replace the existing extension by .ali. The + -- initialization to Name_Len + 1 provides for simply adding the .ali + -- extension if the source file name has no extension. + + Dot_Index := Name_Len + 1; + + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Dot_Index := J; + exit; + end if; + end loop; + + -- Make sure that the output file name matches the source file name. + -- To compare them, remove file name directories and extensions. + + if Output_Object_File_Name /= null then + -- Make sure there is a dot at Dot_Index. This may not be the case + -- if the source file name has no extension. + + Name_Buffer (Dot_Index) := '.'; + + declare + Name : constant String := Name_Buffer (1 .. Dot_Index); + Len : constant Natural := Dot_Index; + + begin + Name_Buffer (1 .. Output_Object_File_Name'Length) + := Output_Object_File_Name.all; + Dot_Index := 0; + + for J in reverse Output_Object_File_Name'Range loop + if Name_Buffer (J) = '.' then + Dot_Index := J; + exit; + end if; + end loop; + + pragma Assert (Dot_Index /= 0); + -- We check for the extension elsewhere + + if Name /= Name_Buffer (Dot_Index - Len + 1 .. Dot_Index) then + Fail ("incorrect object file name"); + end if; + end; + end if; + + Name_Buffer (Dot_Index) := '.'; + Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all; + Name_Buffer (Dot_Index + 4) := ASCII.NUL; + Name_Len := Dot_Index + 3; + end Set_Library_Info_Name; + + --------------------------------- + -- Set_Output_Object_File_Name -- + --------------------------------- + + procedure Set_Output_Object_File_Name (Name : String) is + Ext : constant String := Object_Suffix; + NL : constant Natural := Name'Length; + EL : constant Natural := Ext'Length; + + begin + -- Make sure that the object file has the expected extension. + + if NL <= EL + or else + (Name (NL - EL + Name'First .. Name'Last) /= Ext + and then Name (NL - 2 + Name'First .. Name'Last) /= ".o") + then + Fail ("incorrect object file extension"); + end if; + + Output_Object_File_Name := new String'(Name); + end Set_Output_Object_File_Name; + + ---------------- + -- Tree_Close -- + ---------------- + + procedure Tree_Close is + begin + Tree_Write_Terminate; + Close (Output_FD); + end Tree_Close; + + ----------------- + -- Tree_Create -- + ----------------- + + procedure Tree_Create is + Dot_Index : Natural; + + begin + Get_Name_String (Current_Main); + + -- If an object file has been specified, then the ALI file + -- will be in the same directory as the object file; + -- so, we put the tree file in this same directory, + -- even though no object file needs to be generated. + + if Output_Object_File_Name /= null then + Name_Len := Output_Object_File_Name'Length; + Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all; + end if; + + Dot_Index := 0; + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Dot_Index := J; + exit; + end if; + end loop; + + -- Should be impossible to not have an extension + + pragma Assert (Dot_Index /= 0); + + -- Change exctension to adt + + Name_Buffer (Dot_Index + 1) := 'a'; + Name_Buffer (Dot_Index + 2) := 'd'; + Name_Buffer (Dot_Index + 3) := 't'; + Name_Buffer (Dot_Index + 4) := ASCII.NUL; + Name_Len := Dot_Index + 3; + Create_File_And_Check (Output_FD, Binary); + + Tree_Write_Initialize (Output_FD); + end Tree_Create; + + ----------------------- + -- Write_Debug_Info -- + ----------------------- + + procedure Write_Debug_Info (Info : String) renames Write_Info; + + ------------------------ + -- Write_Library_Info -- + ------------------------ + + procedure Write_Library_Info (Info : String) renames Write_Info; + + ------------------------ + -- Write_Repinfo_Line -- + ------------------------ + + procedure Write_Repinfo_Line (Info : String) renames Write_Info; + +begin + + Adjust_OS_Resource_Limits; + Opt.Creat_Repinfo_File_Access := Creat_Repinfo_File'Access; + Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access; + Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access; + + Set_Program (Compiler); + +end Osint.C; diff --git a/gcc/ada/osint-c.ads b/gcc/ada/osint-c.ads new file mode 100644 index 00000000000..30984fae6f2 --- /dev/null +++ b/gcc/ada/osint-c.ads @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - C -- +-- -- +-- S p e c -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the low level, operating system routines used only +-- in the GNAT compiler for command line processing and file input output. + +package Osint.C is + + procedure Set_Output_Object_File_Name (Name : String); + -- Called by the subprogram processing the command line when an + -- output object file name is found. + + function More_Source_Files return Boolean; + -- Indicates whether more source file remain to be processed. Returns + -- False right away if no source files, or if all source files have + -- been processed. + + function Next_Main_Source return File_Name_Type; + -- This function returns the name of the next main source file specified + -- on the command line. It is an error to call Next_Main_Source if no more + -- source files exist (i.e. Next_Main_Source may be called only if a + -- previous call to More_Source_Files returned True). This name is the + -- simple file name (without any directory information). + + ------------------------------ + -- Debug Source File Output -- + ------------------------------ + + -- These routines are used by the compiler to generate the debug source + -- file for the Debug_Generated_Code (-gnatD switch) option. Note that + -- debug source file writing occurs at a completely different point in + -- the processing from library information output, or representation + -- output, so the code in the body can assume that no two of these + -- functions are ever used at the same time. + + function Create_Debug_File (Src : File_Name_Type) return File_Name_Type; + -- Given the simple name of a source file, this routine creates the + -- corresponding debug file, and returns its full name. + + procedure Write_Debug_Info (Info : String); + -- Writes contents of given string as next line of the current debug + -- source file created by the most recent call to Create_Debug_File. + -- Info does not contain end of line or other formatting characters. + + procedure Close_Debug_File; + -- Close current debug file created by the most recent call to + -- Create_Debug_File. + + function Debug_File_Eol_Length return Nat; + -- Returns the number of characters (1 for NL, 2 for CR/LF) written + -- at the end of each line by Write_Debug_Info. + + -------------------------------- + -- Representation File Output -- + -------------------------------- + + -- These routines are used by the compiler to generate the representation + -- information to a file if this option is specified (-gnatR?s switch). + -- Note that the writing of this file occurs at a completely different + -- point in the processing from library information output, or from + -- debug file output, so the code in the body can assume that no two + -- of these functions are ever used at the same time. + + -- Note: these routines are called from Repinfo, but are not called + -- directly, since we do not want Repinfo to depend on Osint. That + -- would cause a lot of unwanted junk to be dragged into ASIS. So + -- what we do is we have Initialize set the addresses of these three + -- procedures in appropriate variables in Repinfo, so that they can + -- be called indirectly without creating a dependence. + + procedure Creat_Repinfo_File (Src : File_Name_Type); + -- Given the simple name of a source file, this routine creates the + -- corresponding file to hold representation information + + procedure Write_Repinfo_Line (Info : String); + -- Writes contents of given string as next line of the current debug + -- source file created by the most recent call to Create_Repinfo_File. + -- Info does not contain end of line or other formatting characters. + + procedure Close_Repinfo_File; + -- Close current debug file created by the most recent call to + -- Create_Repinfo_File. + + -------------------------------- + -- Library Information Output -- + -------------------------------- + + -- These routines are used by the compiler to generate the library + -- information file for the main source file being compiled. See section + -- above for a discussion of how library information files are stored. + + procedure Create_Output_Library_Info; + -- Creates the output library information file for the source file which + -- is currently being compiled (i.e. the file which was most recently + -- returned by Next_Main_Source). + + procedure Write_Library_Info (Info : String); + -- Writes the contents of the referenced string to the library information + -- file for the main source file currently being compiled (i.e. the file + -- which was most recently opened with a call to Read_Next_File). Info + -- represents a single line in the file, but does not contain any line + -- termination characters. The implementation of Write_Library_Info is + -- responsible for adding necessary end of line and end of file control + -- characters to the generated file. + + procedure Close_Output_Library_Info; + -- Closes the file created by Create_Output_Library_Info, flushing any + -- buffers etc from writes by Write_Library_Info. + + procedure Read_Library_Info + (Name : out File_Name_Type; + Text : out Text_Buffer_Ptr); + -- The procedure version of Read_Library_Info is used from the compiler + -- to read an existing ali file associated with the main unit. If the + -- ALI file exists, then its file name is returned in Name, and its + -- text is returned in Text. If the file does not exist, then Text is + -- set to null. + + -------------------------------- + -- Semantic Tree Input-Output -- + -------------------------------- + + procedure Tree_Create; + -- Creates the tree output file for the source file which is currently + -- being compiled (i.e. the file which was most recently returned by + -- Next_Main_Source), and initializes Tree_IO.Tree_Write for output. + + procedure Tree_Close; + -- Closes the file previously opened by Tree_Create + +end Osint.C; diff --git a/gcc/ada/osint-l.adb b/gcc/ada/osint-l.adb new file mode 100644 index 00000000000..2f5cf12eff1 --- /dev/null +++ b/gcc/ada/osint-l.adb @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - L -- +-- -- +-- B o d y -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body Osint.L is + + -------------------- + -- More_Lib_Files -- + -------------------- + + function More_Lib_Files return Boolean renames More_Files; + + ------------------------ + -- Next_Main_Lib_File -- + ------------------------ + + function Next_Main_Lib_File return File_Name_Type renames Next_Main_File; + +begin + Set_Program (Gnatls); +end Osint.L; diff --git a/gcc/ada/osint-l.ads b/gcc/ada/osint-l.ads new file mode 100644 index 00000000000..1e8c8f4bef4 --- /dev/null +++ b/gcc/ada/osint-l.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - L -- +-- -- +-- S p e c -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the low level, operating system routines used only +-- in gnatls for command line processing and file input output. + +package Osint.L is + + function More_Lib_Files return Boolean; + -- Indicates whether more library information files remain to be processed. + -- Returns False right away if no source files, or if all source files + -- have been processed. + + function Next_Main_Lib_File return File_Name_Type; + -- This function returns the name of the next library info file specified + -- on the command line. It is an error to call Next_Main_Lib_File if no + -- more library information files exist (i.e. Next_Main_Lib_File may be + -- called only if a previous call to More_Lib_Files returned True). This + -- name is the simple name, excluding any directory information. + +end Osint.L; diff --git a/gcc/ada/osint-m.adb b/gcc/ada/osint-m.adb new file mode 100644 index 00000000000..3ff563fe789 --- /dev/null +++ b/gcc/ada/osint-m.adb @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - M -- +-- -- +-- B o d y -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body Osint.M is + + ----------------------- + -- More_Source_Files -- + ----------------------- + + function More_Source_Files return Boolean renames More_Files; + + ---------------------- + -- Next_Main_Source -- + ---------------------- + + function Next_Main_Source return File_Name_Type renames Next_Main_File; + + ---------------------- + -- Object_File_Name -- + ---------------------- + + function Object_File_Name (N : File_Name_Type) return File_Name_Type + renames Osint.Object_File_Name; + +begin + Set_Program (Make); +end Osint.M; diff --git a/gcc/ada/osint-m.ads b/gcc/ada/osint-m.ads new file mode 100644 index 00000000000..45d94f585eb --- /dev/null +++ b/gcc/ada/osint-m.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - M -- +-- -- +-- S p e c -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the low level, operating system routines used only +-- in gnatmake for command line processing and file input output. + +package Osint.M is + + function More_Source_Files return Boolean; + -- Indicates whether more source file remain to be processed. Returns + -- False right away if no source files, or if all source files have + -- been processed. + + function Next_Main_Source return File_Name_Type; + -- This function returns the name of the next main source file specified + -- on the command line. It is an error to call Next_Main_Source if no more + -- source files exist (i.e. Next_Main_Source may be called only if a + -- previous call to More_Source_Files returned True). This name is the + -- simple file name (without any directory information). + + function Object_File_Name (N : File_Name_Type) return File_Name_Type; + -- Constructs the name of the object file corresponding to library + -- file N. If N is a full file name than the returned file name will + -- also be a full file name. Note that no lookup in the library file + -- directories is done for this file. This routine merely constructs + -- the name. + +end Osint.M; diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 27857d02f06..95ec2d6062c 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -33,7 +33,6 @@ with Opt; use Opt; with Output; use Output; with Sdefault; use Sdefault; with Table; -with Tree_IO; use Tree_IO; with Unchecked_Conversion; @@ -42,6 +41,9 @@ with GNAT.HTable; package body Osint is + Running_Program : Program_Type := Unspecified; + Program_Set : Boolean := False; + ------------------------------------- -- Use of Name_Find and Name_Enter -- ------------------------------------- @@ -68,23 +70,12 @@ package body Osint is function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type; -- Convert OS format time to GNAT format time stamp - procedure Create_File_And_Check - (Fdesc : out File_Descriptor; - Fmode : Mode); - -- Create file whose name (NUL terminated) is in Name_Buffer (with the - -- length in Name_Len), and place the resulting descriptor in Fdesc. - -- Issue message and exit with fatal error if file cannot be created. - -- The Fmode parameter is set to either Text or Binary (see description - -- of GNAT.OS_Lib.Create_File). - - procedure Set_Library_Info_Name; - -- Sets a default ali file name from the main compiler source name. - -- This is used by Create_Output_Library_Info, and by the version of - -- Read_Library_Info that takes a default file name. - - procedure Write_Info (Info : String); - -- Implementation of Write_Binder_Info, Write_Debug_Info and - -- Write_Library_Info (identical) + function Concat (String_One : String; String_Two : String) return String; + -- Concatenates 2 strings and returns the result of the concatenation + + function Update_Path (Path : String_Ptr) return String_Ptr; + -- Update the specified path to replace the prefix with the location + -- where GNAT is installed. See the file prefix.c in GCC for details. procedure Write_With_Check (A : Address; N : Integer); -- Writes N bytes from buffer starting at address A to file whose FD is @@ -93,12 +84,6 @@ package body Osint is -- detected, the file being written is deleted, and a fatal error is -- signalled. - function More_Files return Boolean; - -- Implements More_Source_Files and More_Lib_Files. - - function Next_Main_File return File_Name_Type; - -- Implements Next_Main_Source and Next_Main_Lib_File. - function Locate_File (N : File_Name_Type; T : File_Type; @@ -125,42 +110,13 @@ package body Osint is -- Other Local Declarations -- ------------------------------ - ALI_Suffix : constant String_Ptr := new String'("ali"); - -- The suffix used for the library files (also known as ALI files). - - Object_Suffix : constant String := Get_Object_Suffix.all; - -- The suffix used for the object files. - EOL : constant Character := ASCII.LF; -- End of line character - Argument_Count : constant Integer := Arg_Count - 1; - -- Number of arguments (excluding program name) - - type File_Name_Array is array (Int range <>) of String_Ptr; - type File_Name_Array_Ptr is access File_Name_Array; - File_Names : File_Name_Array_Ptr := - new File_Name_Array (1 .. Int (Argument_Count) + 2); - -- As arguments are scanned in Initialize, file names are stored - -- in this array. The string does not contain a terminating NUL. - -- The array is "extensible" because when using project files, - -- there may be more file names than argument on the command line. - Number_File_Names : Int := 0; -- The total number of file names found on command line and placed in -- File_Names. - Current_File_Name_Index : Int := 0; - -- The index in File_Names of the last file opened by Next_Main_Source - -- or Next_Main_Lib_File. The value 0 indicates that no files have been - -- opened yet. - - Current_Main : File_Name_Type := No_File; - -- Used to save a simple file name between calls to Next_Main_Source and - -- Read_Source_File. If the file name argument to Read_Source_File is - -- No_File, that indicates that the file whose name was returned by the - -- last call to Next_Main_Source (and stored here) is to be read. - Look_In_Primary_Directory_For_Current_Main : Boolean := False; -- When this variable is True, Find_File will only look in -- the Primary_Directory for the Current_Main file. @@ -178,28 +134,6 @@ package body Osint is -- the latest source, library and object files opened by Read_Source_File -- and Read_Library_Info. - Old_Binder_Output_Time_Stamp : Time_Stamp_Type; - New_Binder_Output_Time_Stamp : Time_Stamp_Type; - Recording_Time_From_Last_Bind : Boolean := False; - Binder_Output_Time_Stamps_Set : Boolean := False; - - In_Binder : Boolean := False; - In_Compiler : Boolean := False; - In_Make : Boolean := False; - -- Exactly one of these flags is set True to indicate which program - -- is bound and executing with Osint, which is used by all these programs. - - Output_FD : File_Descriptor; - -- The file descriptor for the current library info, tree or binder output - - Output_File_Name : File_Name_Type; - -- File_Name_Type for name of open file whose FD is in Output_FD, the name - -- stored does not include the trailing NUL character. - - Output_Object_File_Name : String_Ptr; - -- Argument of -o compiler option, if given. This is needed to - -- verify consistency with the ALI file name. - ------------------ -- Search Paths -- ------------------ @@ -301,7 +235,8 @@ package body Osint is procedure Add_Search_Dir (Search_Dir : String_Access; Additional_Source_Dir : Boolean); - -- Needs documentation ??? + -- Add a source search dir or a library search dir, depending on the + -- value of Additional_Source_Dir. function Get_Libraries_From_Registry return String_Ptr; -- On Windows systems, get the list of installed standard libraries @@ -310,11 +245,6 @@ package body Osint is -- GNAT\Standard Libraries -- Return an empty string on other systems - function Update_Path (Path : String_Ptr) return String_Ptr; - -- Update the specified path to replace the prefix with - -- the location where GNAT is installed. See the file prefix.c - -- in GCC for more details. - -------------------- -- Add_Search_Dir -- -------------------- @@ -356,40 +286,6 @@ package body Osint is return Out_String; end Get_Libraries_From_Registry; - ----------------- - -- Update_Path -- - ----------------- - - function Update_Path (Path : String_Ptr) return String_Ptr is - - function C_Update_Path (Path, Component : Address) return Address; - pragma Import (C, C_Update_Path, "update_path"); - - function Strlen (Str : Address) return Integer; - pragma Import (C, Strlen, "strlen"); - - procedure Strncpy (X : Address; Y : Address; Length : Integer); - pragma Import (C, Strncpy, "strncpy"); - - In_Length : constant Integer := Path'Length; - In_String : String (1 .. In_Length + 1); - Component_Name : aliased String := "GNAT" & ASCII.NUL; - Result_Ptr : Address; - Result_Length : Integer; - Out_String : String_Ptr; - - begin - In_String (1 .. In_Length) := Path.all; - In_String (In_Length + 1) := ASCII.NUL; - Result_Ptr := C_Update_Path (In_String'Address, - Component_Name'Address); - Result_Length := Strlen (Result_Ptr); - - Out_String := new String (1 .. Result_Length); - Strncpy (Out_String.all'Address, Result_Ptr, Result_Length); - return Out_String; - end Update_Path; - -- Start of processing for Add_Default_Search_Dirs begin @@ -461,7 +357,7 @@ package body Osint is end loop; end if; - if not Opt.No_Stdlib then + if not Opt.No_Stdlib and not Opt.RTS_Switch then Search_Path := Read_Default_Search_Dirs (String_Access (Update_Path (Search_Dir_Prefix)), Objects_Search_File, @@ -511,6 +407,31 @@ package body Osint is Normalize_Directory_Name (Dir); end Add_Lib_Search_Dir; + --------------------- + -- Add_Search_Dirs -- + --------------------- + + procedure Add_Search_Dirs + (Search_Path : String_Ptr; + Path_Type : Search_File_Type) + is + Current_Search_Path : String_Access; + + begin + Get_Next_Dir_In_Path_Init (String_Access (Search_Path)); + loop + Current_Search_Path := + Get_Next_Dir_In_Path (String_Access (Search_Path)); + exit when Current_Search_Path = null; + + if Path_Type = Include then + Add_Src_Search_Dir (Current_Search_Path.all); + else + Add_Lib_Search_Dir (Current_Search_Path.all); + end if; + end loop; + end Add_Search_Dirs; + ------------------------ -- Add_Src_Search_Dir -- ------------------------ @@ -579,190 +500,18 @@ package body Osint is end if; end Canonical_Case_File_Name; - ------------------------- - -- Close_Binder_Output -- - ------------------------- - - procedure Close_Binder_Output is - begin - pragma Assert (In_Binder); - Close (Output_FD); + ------------ + -- Concat -- + ------------ - if Recording_Time_From_Last_Bind then - New_Binder_Output_Time_Stamp := File_Stamp (Output_File_Name); - Binder_Output_Time_Stamps_Set := True; - end if; - end Close_Binder_Output; - - ---------------------- - -- Close_Debug_File -- - ---------------------- + function Concat (String_One : String; String_Two : String) return String is + Buffer : String (1 .. String_One'Length + String_Two'Length); - procedure Close_Debug_File is begin - pragma Assert (In_Compiler); - Close (Output_FD); - end Close_Debug_File; - - ------------------------------- - -- Close_Output_Library_Info -- - ------------------------------- - - procedure Close_Output_Library_Info is - begin - pragma Assert (In_Compiler); - Close (Output_FD); - end Close_Output_Library_Info; - - -------------------------- - -- Create_Binder_Output -- - -------------------------- - - procedure Create_Binder_Output - (Output_File_Name : String; - Typ : Character; - Bfile : out Name_Id) - is - File_Name : String_Ptr; - Findex1 : Natural; - Findex2 : Natural; - Flength : Natural; - - begin - pragma Assert (In_Binder); - - if Output_File_Name /= "" then - Name_Buffer (Output_File_Name'Range) := Output_File_Name; - Name_Buffer (Output_File_Name'Last + 1) := ASCII.NUL; - - if Typ = 's' then - Name_Buffer (Output_File_Name'Last) := 's'; - end if; - - Name_Len := Output_File_Name'Last; - - else - Name_Buffer (1) := 'b'; - File_Name := File_Names (Current_File_Name_Index); - - Findex1 := File_Name'First; - - -- The ali file might be specified by a full path name. However, - -- the binder generated file should always be created in the - -- current directory, so the path might need to be stripped away. - -- In addition to the default directory_separator allow the '/' to - -- act as separator since this is allowed in MS-DOS and OS2 ports. - - for J in reverse File_Name'Range loop - if File_Name (J) = Directory_Separator - or else File_Name (J) = '/' - then - Findex1 := J + 1; - exit; - end if; - end loop; - - Findex2 := File_Name'Last; - while File_Name (Findex2) /= '.' loop - Findex2 := Findex2 - 1; - end loop; - - Flength := Findex2 - Findex1; - - if Maximum_File_Name_Length > 0 then - - -- Make room for the extra two characters in "b?" - - while Int (Flength) > Maximum_File_Name_Length - 2 loop - Findex2 := Findex2 - 1; - Flength := Findex2 - Findex1; - end loop; - end if; - - Name_Buffer (3 .. Flength + 2) := File_Name (Findex1 .. Findex2 - 1); - Name_Buffer (Flength + 3) := '.'; - - -- C bind file, name is b_xxx.c - - if Typ = 'c' then - Name_Buffer (2) := '_'; - Name_Buffer (Flength + 4) := 'c'; - Name_Buffer (Flength + 5) := ASCII.NUL; - Name_Len := Flength + 4; - - -- Ada bind file, name is b~xxx.adb or b~xxx.ads - -- (with $ instead of ~ in VMS) - - else - if Hostparm.OpenVMS then - Name_Buffer (2) := '$'; - else - Name_Buffer (2) := '~'; - end if; - - Name_Buffer (Flength + 4) := 'a'; - Name_Buffer (Flength + 5) := 'd'; - Name_Buffer (Flength + 6) := Typ; - Name_Buffer (Flength + 7) := ASCII.NUL; - Name_Len := Flength + 6; - end if; - end if; - - Bfile := Name_Find; - - if Recording_Time_From_Last_Bind then - Old_Binder_Output_Time_Stamp := File_Stamp (Bfile); - end if; - - Create_File_And_Check (Output_FD, Text); - end Create_Binder_Output; - - ----------------------- - -- Create_Debug_File -- - ----------------------- - - function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is - Result : File_Name_Type; - - begin - Get_Name_String (Src); - - if Hostparm.OpenVMS then - Name_Buffer (Name_Len + 1 .. Name_Len + 3) := "_dg"; - else - Name_Buffer (Name_Len + 1 .. Name_Len + 3) := ".dg"; - end if; - - Name_Len := Name_Len + 3; - - if Output_Object_File_Name /= null then - - for Index in reverse Output_Object_File_Name'Range loop - - if Output_Object_File_Name (Index) = Directory_Separator then - declare - File_Name : constant String := Name_Buffer (1 .. Name_Len); - - begin - Name_Len := Index - Output_Object_File_Name'First + 1; - Name_Buffer (1 .. Name_Len) := - Output_Object_File_Name - (Output_Object_File_Name'First .. Index); - Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) := - File_Name; - Name_Len := Name_Len + File_Name'Length; - end; - - exit; - end if; - end loop; - end if; - - Result := Name_Find; - Name_Buffer (Name_Len + 1) := ASCII.NUL; - Create_File_And_Check (Output_FD, Text); - return Result; - end Create_Debug_File; + Buffer (1 .. String_One'Length) := String_One; + Buffer (String_One'Length + 1 .. Buffer'Last) := String_Two; + return Buffer; + end Concat; --------------------------- -- Create_File_And_Check -- @@ -782,16 +531,6 @@ package body Osint is end Create_File_And_Check; -------------------------------- - -- Create_Output_Library_Info -- - -------------------------------- - - procedure Create_Output_Library_Info is - begin - Set_Library_Info_Name; - Create_File_And_Check (Output_FD, Text); - end Create_Output_Library_Info; - - -------------------------------- -- Current_Library_File_Stamp -- -------------------------------- @@ -818,21 +557,6 @@ package body Osint is return Current_Full_Source_Stamp; end Current_Source_File_Stamp; - --------------------------- - -- Debug_File_Eol_Length -- - --------------------------- - - function Debug_File_Eol_Length return Nat is - begin - -- There has to be a cleaner way to do this! ??? - - if Directory_Separator = '/' then - return 1; - else - return 2; - end if; - end Debug_File_Eol_Length; - ---------------------------- -- Dir_In_Obj_Search_Path -- ---------------------------- @@ -914,7 +638,11 @@ package body Osint is ---------- procedure Fail (S1 : String; S2 : String := ""; S3 : String := "") is + begin + -- We use Output in case there is a special output set up. + -- In this case Set_Standard_Error will have no immediate effect. + Set_Standard_Error; Osint.Write_Program_Name; Write_Str (": "); @@ -923,9 +651,6 @@ package body Osint is Write_Str (S3); Write_Eol; - -- ??? Using Output is ugly, should do direct writes - -- ??? shouldn't this go to standard error instead of stdout? - Exit_Program (E_Fatal); end Fail; @@ -1202,87 +927,175 @@ package body Osint is return Src_Search_Directories.Table (Primary_Directory); end Get_Primary_Src_Search_Directory; - ---------------- - -- Initialize -- - ---------------- + ------------------------- + -- Get_RTS_Search_Dir -- + ------------------------- - procedure Initialize (P : Program_Type) is - function Get_Default_Identifier_Character_Set return Character; - pragma Import (C, Get_Default_Identifier_Character_Set, - "__gnat_get_default_identifier_character_set"); - -- Function to determine the default identifier character set, - -- which is system dependent. See Opt package spec for a list of - -- the possible character codes and their interpretations. + function Get_RTS_Search_Dir + (Search_Dir : String; + File_Type : Search_File_Type) + return String_Ptr + is + procedure Get_Current_Dir + (Dir : System.Address; + Length : System.Address); + pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); + + Max_Path : Integer; + pragma Import (C, Max_Path, "max_path_len"); + -- Maximum length of a path name + + Current_Dir : String_Ptr; + Default_Search_Dir : String_Access; + Default_Suffix_Dir : String_Access; + Local_Search_Dir : String_Access; + Norm_Search_Dir : String_Access; + Result_Search_Dir : String_Access; + Search_File : String_Access; + Temp_String : String_Ptr; + + begin + -- Add a directory separator at the end of the directory if necessary + -- so that we can directly append a file to the directory + + if Search_Dir (Search_Dir'Last) /= Directory_Separator then + Local_Search_Dir := new String' + (Concat (Search_Dir, String' (1 => Directory_Separator))); + else + Local_Search_Dir := new String' (Search_Dir); + end if; - function Get_Maximum_File_Name_Length return Int; - pragma Import (C, Get_Maximum_File_Name_Length, - "__gnat_get_maximum_file_name_length"); - -- Function to get maximum file name length for system + if File_Type = Include then + Search_File := Include_Search_File; + Default_Suffix_Dir := new String'("adainclude"); + else + Search_File := Objects_Search_File; + Default_Suffix_Dir := new String' ("adalib"); + end if; - procedure Adjust_OS_Resource_Limits; - pragma Import (C, Adjust_OS_Resource_Limits, - "__gnat_adjust_os_resource_limits"); - -- Procedure to make system specific adjustments to make GNAT - -- run better. + Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all); - -- Start of processing for Initialize + if Is_Absolute_Path (Norm_Search_Dir.all) then - begin - Program := P; + -- We first verify if there is a directory Include_Search_Dir + -- containing default search directories - case Program is - when Binder => In_Binder := True; - when Compiler => In_Compiler := True; - when Make => In_Make := True; - end case; + Result_Search_Dir + := Read_Default_Search_Dirs (Norm_Search_Dir, + Search_File, + null); + Default_Search_Dir := new String' + (Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all)); + Free (Norm_Search_Dir); - if In_Compiler then - Adjust_OS_Resource_Limits; - end if; + if Result_Search_Dir /= null then + return String_Ptr (Result_Search_Dir); + elsif Is_Directory (Default_Search_Dir.all) then + return String_Ptr (Default_Search_Dir); + else + return null; + end if; - Src_Search_Directories.Init; - Lib_Search_Directories.Init; + else + -- Search in the current directory - Identifier_Character_Set := Get_Default_Identifier_Character_Set; - Maximum_File_Name_Length := Get_Maximum_File_Name_Length; + -- Get the current directory - -- Following should be removed by having above function return - -- Integer'Last as indication of no maximum instead of -1 ??? + declare + Buffer : String (1 .. Max_Path + 2); + Path_Len : Natural := Max_Path; - if Maximum_File_Name_Length = -1 then - Maximum_File_Name_Length := Int'Last; - end if; + begin + Get_Current_Dir (Buffer'Address, Path_Len'Address); - -- Start off by setting all suppress options to False, these will - -- be reset later (turning some on if -gnato is not specified, and - -- turning all of them on if -gnatp is specified). + if Buffer (Path_Len) /= Directory_Separator then + Path_Len := Path_Len + 1; + Buffer (Path_Len) := Directory_Separator; + end if; - Suppress_Options := (others => False); + Current_Dir := new String'(Buffer (1 .. Path_Len)); + end; - -- Set software overflow check flag. For now all targets require the - -- use of software overflow checks. Later on, this will have to be - -- specialized to the backend target. Also, if software overflow - -- checking mode is set, then the default for suppressing overflow - -- checks is True, since the software approach is expensive. + Norm_Search_Dir := + new String' + (Concat (Current_Dir.all, Local_Search_Dir.all)); - Software_Overflow_Checking := True; - Suppress_Options.Overflow_Checks := True; + Result_Search_Dir := + Read_Default_Search_Dirs + (String_Access (Update_Path (String_Ptr (Norm_Search_Dir))), + Search_File, + null); - -- Reserve the first slot in the search paths table. This is the - -- directory of the main source file or main library file and is - -- filled in by each call to Next_Main_Source/Next_Main_Lib_File with - -- the directory specified for this main source or library file. This - -- is the directory which is searched first by default. This default - -- search is inhibited by the option -I- for both source and library - -- files. + Default_Search_Dir := + new String' + (Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all)); - Src_Search_Directories.Set_Last (Primary_Directory); - Src_Search_Directories.Table (Primary_Directory) := new String'(""); + Free (Norm_Search_Dir); - Lib_Search_Directories.Set_Last (Primary_Directory); - Lib_Search_Directories.Table (Primary_Directory) := new String'(""); + if Result_Search_Dir /= null then + return String_Ptr (Result_Search_Dir); + + elsif Is_Directory (Default_Search_Dir.all) then + return String_Ptr (Default_Search_Dir); + + else + -- Search in Search_Dir_Prefix/Search_Dir + + Norm_Search_Dir := + new String' + (Concat (Search_Dir_Prefix.all, Local_Search_Dir.all)); + + Result_Search_Dir := + Read_Default_Search_Dirs + (String_Access (Update_Path (String_Ptr (Norm_Search_Dir))), + Search_File, + null); + + Default_Search_Dir := + new String' + (Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all)); + + Free (Norm_Search_Dir); - end Initialize; + if Result_Search_Dir /= null then + return String_Ptr (Result_Search_Dir); + + elsif Is_Directory (Default_Search_Dir.all) then + return String_Ptr (Default_Search_Dir); + + else + -- We finally search in Search_Dir_Prefix/rts-Search_Dir + + Temp_String := + new String'(Concat (Search_Dir_Prefix.all, "rts-")); + + Norm_Search_Dir := + new String' (Concat (Temp_String.all, Local_Search_Dir.all)); + + Result_Search_Dir := + Read_Default_Search_Dirs + (String_Access (Update_Path (String_Ptr (Norm_Search_Dir))), + Search_File, + null); + + Default_Search_Dir := + new String' + (Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all)); + Free (Norm_Search_Dir); + + if Result_Search_Dir /= null then + return String_Ptr (Result_Search_Dir); + + elsif Is_Directory (Default_Search_Dir.all) then + return String_Ptr (Default_Search_Dir); + + else + return null; + end if; + end if; + end if; + end if; + end Get_RTS_Search_Dir; ---------------------------- -- Is_Directory_Separator -- @@ -1330,7 +1143,7 @@ package body Osint is Get_Name_String (Source_File); Fptr := Name_Len + 1; - for J in reverse 1 .. Name_Len loop + for J in reverse 2 .. Name_Len loop if Name_Buffer (J) = '.' then Fptr := J; exit; @@ -1447,26 +1260,6 @@ package body Osint is return (Current_File_Name_Index < Number_File_Names); end More_Files; - -------------------- - -- More_Lib_Files -- - -------------------- - - function More_Lib_Files return Boolean is - begin - pragma Assert (In_Binder); - return More_Files; - end More_Lib_Files; - - ----------------------- - -- More_Source_Files -- - ----------------------- - - function More_Source_Files return Boolean is - begin - pragma Assert (In_Compiler or else In_Make); - return More_Files; - end More_Source_Files; - ------------------------------- -- Nb_Dir_In_Obj_Search_Path -- ------------------------------- @@ -1530,20 +1323,26 @@ package body Osint is Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1)); - if In_Compiler then - Src_Search_Directories.Table (Primary_Directory) := Dir_Name; - Look_In_Primary_Directory_For_Current_Main := True; + case Running_Program is - elsif In_Make then - Src_Search_Directories.Table (Primary_Directory) := Dir_Name; - if Fptr > File_Name'First then + when Compiler => + Src_Search_Directories.Table (Primary_Directory) := Dir_Name; Look_In_Primary_Directory_For_Current_Main := True; - end if; - else pragma Assert (In_Binder); - Dir_Name := Normalize_Directory_Name (Dir_Name.all); - Lib_Search_Directories.Table (Primary_Directory) := Dir_Name; - end if; + when Make => + Src_Search_Directories.Table (Primary_Directory) := Dir_Name; + + if Fptr > File_Name'First then + Look_In_Primary_Directory_For_Current_Main := True; + end if; + + when Binder | Gnatls => + Dir_Name := Normalize_Directory_Name (Dir_Name.all); + Lib_Search_Directories.Table (Primary_Directory) := Dir_Name; + + when Unspecified => + null; + end case; Name_Len := File_Name'Last - Fptr + 1; Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last); @@ -1553,7 +1352,7 @@ package body Osint is -- In the gnatmake case, the main file may have not have the -- extension. Try ".adb" first then ".ads" - if In_Make then + if Running_Program = Make then declare Orig_Main : File_Name_Type := Current_Main; @@ -1576,28 +1375,6 @@ package body Osint is return Current_Main; end Next_Main_File; - ------------------------ - -- Next_Main_Lib_File -- - ------------------------ - - function Next_Main_Lib_File return File_Name_Type is - begin - pragma Assert (In_Binder); - return Next_Main_File; - end Next_Main_Lib_File; - - ---------------------- - -- Next_Main_Source -- - ---------------------- - - function Next_Main_Source return File_Name_Type is - Main_File : File_Name_Type := Next_Main_File; - - begin - pragma Assert (In_Compiler or else In_Make); - return Main_File; - end Next_Main_Source; - ------------------------------ -- Normalize_Directory_Name -- ------------------------------ @@ -1962,18 +1739,6 @@ package body Osint is end Read_Library_Info; - -- Version with default file name - - procedure Read_Library_Info - (Name : out File_Name_Type; - Text : out Text_Buffer_Ptr) - is - begin - Set_Library_Info_Name; - Name := Name_Find; - Text := Read_Library_Info (Name, Fatal_Err => False); - end Read_Library_Info; - ---------------------- -- Read_Source_File -- ---------------------- @@ -2087,103 +1852,19 @@ package body Osint is end Read_Source_File; - -------------------------------- - -- Record_Time_From_Last_Bind -- - -------------------------------- - - procedure Record_Time_From_Last_Bind is - begin - Recording_Time_From_Last_Bind := True; - end Record_Time_From_Last_Bind; - - --------------------------- - -- Set_Library_Info_Name -- - --------------------------- - - procedure Set_Library_Info_Name is - Dot_Index : Natural; - - begin - pragma Assert (In_Compiler); - Get_Name_String (Current_Main); - - -- Find last dot since we replace the existing extension by .ali. The - -- initialization to Name_Len + 1 provides for simply adding the .ali - -- extension if the source file name has no extension. - - Dot_Index := Name_Len + 1; - for J in reverse 1 .. Name_Len loop - if Name_Buffer (J) = '.' then - Dot_Index := J; - exit; - end if; - end loop; - - -- Make sure that the output file name matches the source file name. - -- To compare them, remove file name directories and extensions. - - if Output_Object_File_Name /= null then - declare - Name : constant String := Name_Buffer (1 .. Dot_Index); - Len : constant Natural := Dot_Index; - - begin - Name_Buffer (1 .. Output_Object_File_Name'Length) - := Output_Object_File_Name.all; - Dot_Index := 0; - - for J in reverse Output_Object_File_Name'Range loop - if Name_Buffer (J) = '.' then - Dot_Index := J; - exit; - end if; - end loop; - - pragma Assert (Dot_Index /= 0); - -- We check for the extension elsewhere - - if Name /= Name_Buffer (Dot_Index - Len + 1 .. Dot_Index) then - Fail ("incorrect object file name"); - end if; - end; - end if; - - Name_Buffer (Dot_Index) := '.'; - Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all; - Name_Buffer (Dot_Index + 4) := ASCII.NUL; - Name_Len := Dot_Index + 3; - end Set_Library_Info_Name; - - --------------------------------- - -- Set_Output_Object_File_Name -- - --------------------------------- - - procedure Set_Output_Object_File_Name (Name : String) is - Ext : constant String := Object_Suffix; - NL : constant Natural := Name'Length; - EL : constant Natural := Ext'Length; + ----------------- + -- Set_Program -- + ----------------- + procedure Set_Program (P : Program_Type) is begin - -- Make sure that the object file has the expected extension. - - if NL <= EL - or else Name (NL - EL + Name'First .. Name'Last) /= Ext - then - Fail ("incorrect object file extension"); + if Program_Set then + Fail ("Set_Program called twice"); end if; - Output_Object_File_Name := new String'(Name); - end Set_Output_Object_File_Name; - - ------------------------ - -- Set_Main_File_Name -- - ------------------------ - - procedure Set_Main_File_Name (Name : String) is - begin - Number_File_Names := Number_File_Names + 1; - File_Names (Number_File_Names) := new String'(Name); - end Set_Main_File_Name; + Program_Set := True; + Running_Program := P; + end Set_Program; ---------------------- -- Smart_File_Stamp -- @@ -2263,26 +1944,22 @@ package body Osint is begin Get_Name_String (Name); - declare - S : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); - Fptr : Natural := S'First; + for J in reverse 1 .. Name_Len - 1 loop + -- If we find the last directory separator - begin - for J in reverse S'Range loop - if Is_Directory_Separator (S (J)) then - Fptr := J + 1; - exit; - end if; - end loop; + if Is_Directory_Separator (Name_Buffer (J)) then + -- Return the part of Name that follows this last directory + -- separator. - if Fptr = S'First then - return Name; + Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len); + Name_Len := Name_Len - J; + return Name_Find; end if; + end loop; - Name_Buffer (1 .. S'Last - Fptr + 1) := S (Fptr .. S'Last); - Name_Len := S'Last - Fptr + 1; - return Name_Find; - end; + -- There were no directory separator, just return Name + + return Name; end Strip_Directory; ------------------ @@ -2293,7 +1970,11 @@ package body Osint is begin Get_Name_String (Name); - for J in reverse 1 .. Name_Len loop + for J in reverse 2 .. Name_Len loop + + -- If we found the last '.', return the part of Name that precedes + -- this '.'. + if Name_Buffer (J) = '.' then Name_Len := J - 1; return Name_Enter; @@ -2303,71 +1984,6 @@ package body Osint is return Name; end Strip_Suffix; - ------------------------- - -- Time_From_Last_Bind -- - ------------------------- - - function Time_From_Last_Bind return Nat is - Old_Y : Nat; - Old_M : Nat; - Old_D : Nat; - Old_H : Nat; - Old_Mi : Nat; - Old_S : Nat; - New_Y : Nat; - New_M : Nat; - New_D : Nat; - New_H : Nat; - New_Mi : Nat; - New_S : Nat; - - type Month_Data is array (Int range 1 .. 12) of Int; - Cumul : constant Month_Data := (0, 0, 3, 3, 4, 4, 5, 5, 5, 6, 6, 7); - -- Represents the difference in days from a period compared to the - -- same period if all months had 31 days, i.e: - -- - -- Cumul (m) = 31x(m-1) - (number of days from 01/01 to m/01) - - Res : Int; - - begin - if not Recording_Time_From_Last_Bind - or else not Binder_Output_Time_Stamps_Set - or else Old_Binder_Output_Time_Stamp = Empty_Time_Stamp - then - return Nat'Last; - end if; - - Split_Time_Stamp - (Old_Binder_Output_Time_Stamp, - Old_Y, Old_M, Old_D, Old_H, Old_Mi, Old_S); - - Split_Time_Stamp - (New_Binder_Output_Time_Stamp, - New_Y, New_M, New_D, New_H, New_Mi, New_S); - - Res := New_Mi - Old_Mi; - - -- 60 minutes in an hour - - Res := Res + 60 * (New_H - Old_H); - - -- 24 hours in a day - - Res := Res + 60 * 24 * (New_D - Old_D); - - -- Almost 31 days in a month - - Res := Res + 60 * 24 * - (31 * (New_M - Old_M) - Cumul (New_M) + Cumul (Old_M)); - - -- 365 days in a year - - Res := Res + 60 * 24 * 365 * (New_Y - Old_Y); - - return Res; - end Time_From_Last_Bind; - --------------------------- -- To_Canonical_Dir_Spec -- --------------------------- @@ -2637,61 +2253,39 @@ package body Osint is return Return_Val; end To_Path_String_Access; - ---------------- - -- Tree_Close -- - ---------------- - - procedure Tree_Close is - begin - pragma Assert (In_Compiler); - Tree_Write_Terminate; - Close (Output_FD); - end Tree_Close; - ----------------- - -- Tree_Create -- + -- Update_Path -- ----------------- - procedure Tree_Create is - Dot_Index : Natural; - - begin - pragma Assert (In_Compiler); - Get_Name_String (Current_Main); + function Update_Path (Path : String_Ptr) return String_Ptr is - -- If an object file has been specified, then the ALI file - -- will be in the same directory as the object file; - -- so, we put the tree file in this same directory, - -- even though no object file needs to be generated. + function C_Update_Path (Path, Component : Address) return Address; + pragma Import (C, C_Update_Path, "update_path"); - if Output_Object_File_Name /= null then - Name_Len := Output_Object_File_Name'Length; - Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all; - end if; - - Dot_Index := 0; - for J in reverse 1 .. Name_Len loop - if Name_Buffer (J) = '.' then - Dot_Index := J; - exit; - end if; - end loop; - - -- Should be impossible to not have an extension + function Strlen (Str : Address) return Integer; + pragma Import (C, Strlen, "strlen"); - pragma Assert (Dot_Index /= 0); + procedure Strncpy (X : Address; Y : Address; Length : Integer); + pragma Import (C, Strncpy, "strncpy"); - -- Change exctension to adt + In_Length : constant Integer := Path'Length; + In_String : String (1 .. In_Length + 1); + Component_Name : aliased String := "GNAT" & ASCII.NUL; + Result_Ptr : Address; + Result_Length : Integer; + Out_String : String_Ptr; - Name_Buffer (Dot_Index + 1) := 'a'; - Name_Buffer (Dot_Index + 2) := 'd'; - Name_Buffer (Dot_Index + 3) := 't'; - Name_Buffer (Dot_Index + 4) := ASCII.NUL; - Name_Len := Dot_Index + 3; - Create_File_And_Check (Output_FD, Binary); + begin + In_String (1 .. In_Length) := Path.all; + In_String (In_Length + 1) := ASCII.NUL; + Result_Ptr := C_Update_Path (In_String'Address, + Component_Name'Address); + Result_Length := Strlen (Result_Ptr); - Tree_Write_Initialize (Output_FD); - end Tree_Create; + Out_String := new String (1 .. Result_Length); + Strncpy (Out_String.all'Address, Result_Ptr, Result_Length); + return Out_String; + end Update_Path; ---------------- -- Write_Info -- @@ -2699,29 +2293,10 @@ package body Osint is procedure Write_Info (Info : String) is begin - pragma Assert (In_Binder or In_Compiler); Write_With_Check (Info'Address, Info'Length); Write_With_Check (EOL'Address, 1); end Write_Info; - ----------------------- - -- Write_Binder_Info -- - ----------------------- - - procedure Write_Binder_Info (Info : String) renames Write_Info; - - ----------------------- - -- Write_Debug_Info -- - ----------------------- - - procedure Write_Debug_Info (Info : String) renames Write_Info; - - ------------------------ - -- Write_Library_Info -- - ------------------------ - - procedure Write_Library_Info (Info : String) renames Write_Info; - ------------------------ -- Write_Program_Name -- ------------------------ @@ -2774,4 +2349,58 @@ package body Osint is end if; end Write_With_Check; +---------------------------- +-- Package Initialization -- +---------------------------- + +begin + Initialization : declare + + function Get_Default_Identifier_Character_Set return Character; + pragma Import (C, Get_Default_Identifier_Character_Set, + "__gnat_get_default_identifier_character_set"); + -- Function to determine the default identifier character set, + -- which is system dependent. See Opt package spec for a list of + -- the possible character codes and their interpretations. + + function Get_Maximum_File_Name_Length return Int; + pragma Import (C, Get_Maximum_File_Name_Length, + "__gnat_get_maximum_file_name_length"); + -- Function to get maximum file name length for system + + begin + Src_Search_Directories.Init; + Lib_Search_Directories.Init; + + Identifier_Character_Set := Get_Default_Identifier_Character_Set; + Maximum_File_Name_Length := Get_Maximum_File_Name_Length; + + -- Following should be removed by having above function return + -- Integer'Last as indication of no maximum instead of -1 ??? + + if Maximum_File_Name_Length = -1 then + Maximum_File_Name_Length := Int'Last; + end if; + + -- Start off by setting all suppress options to False, these will + -- be reset later (turning some on if -gnato is not specified, and + -- turning all of them on if -gnatp is specified). + + Suppress_Options := (others => False); + + -- Reserve the first slot in the search paths table. This is the + -- directory of the main source file or main library file and is + -- filled in by each call to Next_Main_Source/Next_Main_Lib_File with + -- the directory specified for this main source or library file. This + -- is the directory which is searched first by default. This default + -- search is inhibited by the option -I- for both source and library + -- files. + + Src_Search_Directories.Set_Last (Primary_Directory); + Src_Search_Directories.Table (Primary_Directory) := new String'(""); + + Lib_Search_Directories.Set_Last (Primary_Directory); + Lib_Search_Directories.Table (Primary_Directory) := new String'(""); + end Initialization; + end Osint; diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index be387392295..5f3eb15afa1 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -28,21 +28,15 @@ -- This package contains the low level, operating system routines used in -- the GNAT compiler and binder for command line processing and file input --- output. The specification is suitable for use with MS-DOS, Unix, and --- similar systems. Note that for input source and library information --- files, the line terminator may be either CR/LF or LF alone, and the --- DOS-style EOF (16#1A#) character marking the end of the text in a --- file may be used in all systems including Unix. This allows for more --- convenient processing of DOS files in a Unix environment. +-- output. with GNAT.OS_Lib; use GNAT.OS_Lib; with System; use System; with Types; use Types; -package Osint is +pragma Elaborate (GNAT.OS_Lib); - procedure Set_Main_File_Name (Name : String); - -- Set the main file name for Gnatmake. +package Osint is function Normalize_Directory_Name (Directory : String) return String_Ptr; -- Verify and normalize a directory name. If directory name is invalid, @@ -55,29 +49,24 @@ package Osint is (N : File_Name_Type; T : File_Type) return File_Name_Type; - -- Finds a source or library file depending on the value of T following - -- the directory search order rules unless N is the name of the file - -- just read with Next_Main_File and already contains directiory - -- information, in which case just look in the Primary_Directory. - -- Returns File_Name_Type of the full file name if found, No_File if - -- file not found. Note that for the special case of gnat.adc, only the - -- compilation environment directory is searched, i.e. the directory - -- where the ali and object files are written. Another special case is - -- when Debug_Generated_Code is set and the file name ends on ".dg", - -- in which case we look for the generated file only in the current - -- directory, since that is where it is always built. - - function Get_Switch_Character return Character; - pragma Import (C, Get_Switch_Character, "__gnat_get_switch_character"); - Switch_Character : constant Character := Get_Switch_Character; - -- Set to the default switch character (note that minus is always an - -- acceptable alternative switch character) + -- Finds a source, library or config file depending on the value + -- of T following the directory search order rules unless N is the + -- name of the file just read with Next_Main_File and already + -- contains directiory information, in which case just look in the + -- Primary_Directory. Returns File_Name_Type of the full file name + -- if found, No_File if file not found. Note that for the special + -- case of gnat.adc, only the compilation environment directory is + -- searched, i.e. the directory where the ali and object files are + -- written. Another special case is when Debug_Generated_Code is + -- set and the file name ends on ".dg", in which case we look for + -- the generated file only in the current directory, since that is + -- where it is always built. function Get_File_Names_Case_Sensitive return Int; pragma Import (C, Get_File_Names_Case_Sensitive, - "__gnat_get_file_names_case_sensitive"); + "__gnat_get_file_names_case_sensitive"); File_Names_Case_Sensitive : constant Boolean := - Get_File_Names_Case_Sensitive /= 0; + Get_File_Names_Case_Sensitive /= 0; -- Set to indicate whether the operating system convention is for file -- names to be case sensitive (e.g., in Unix, set True), or non case -- sensitive (e.g., in OS/2, set False). @@ -97,29 +86,6 @@ package Osint is -- Called by the subprogram processing the command line for each -- file name found. - procedure Set_Output_Object_File_Name (Name : String); - -- Called by the subprogram processing the command line when an - -- output object file name is found. - - type Program_Type is (Compiler, Binder, Make); - Program : Program_Type; - -- Program currently running (set by Initialize below) - - procedure Initialize (P : Program_Type); - -- This routine scans parameters and initializes for the first call to - -- Next_Main_Source (Compiler or Make) or Next_Main_Lib_File (Binder). - -- It also resets any of the variables in package Opt in response to - -- command switch settings. - -- - -- Initialize may terminate execution if the parameters are invalid or some - -- other fatal error is encountered. The interface is set up to - -- accommodate scanning a series of files (e.g. as the result of - -- wild card references in DOS, or an expanded list of source files - -- in Unix). Of course it is perfectly possible to ignore this in - -- the implementation and provide for opening only one file. - -- The parameter P is the program (Compiler, Binder or Make) that is - -- actually running. - procedure Find_Program_Name; -- Put simple name of current program being run (excluding the directory -- path) in Name_Buffer, with the length in Name_Len. @@ -133,29 +99,32 @@ package Osint is -- Name_Buffer and Name_Len. procedure Write_Program_Name; - -- Writes name of program as invoked to standard output + -- Writes name of program as invoked to the current output + -- (normally standard output). procedure Fail (S1 : String; S2 : String := ""; S3 : String := ""); + pragma No_Return (Fail); -- Outputs error messages S1 & S2 & S3 preceded by the name of the - -- executing program and exits with E_Fatal. + -- executing program and exits with E_Fatal. The output goes to + -- standard error, except if special output is in effect (see Output). function Is_Directory_Separator (C : Character) return Boolean; -- Returns True if C is a directory separator function Get_Directory (Name : File_Name_Type) return File_Name_Type; -- Get the prefix directory name (if any) from Name. The last separator - -- is preserved. Return No_File if there is no directory part in the - -- name. + -- is preserved. Return the normalized current directory if there is no + -- directory part in the name. function Is_Readonly_Library (File : File_Name_Type) return Boolean; -- Check if this library file is a read-only file. function Strip_Directory (Name : File_Name_Type) return File_Name_Type; -- Strips the prefix directory name (if any) from Name. Returns the - -- stripped name. + -- stripped name. Name cannot end with a directory separator. function Strip_Suffix (Name : File_Name_Type) return File_Name_Type; - -- Strips the suffix (the '.' and whatever comes after it) from Name. + -- Strips the suffix (the last '.' and whatever comes after it) from Name. -- Returns the stripped name. function Executable_Name (Name : File_Name_Type) return File_Name_Type; @@ -170,33 +139,18 @@ package Osint is -- opened, or Name = No_File, and all blank time stamp is returned (this is -- not an error situation). - procedure Record_Time_From_Last_Bind; - -- Trigger the computing of the time from the last bind of the same - -- program. - - function Time_From_Last_Bind return Nat; - -- This function give an approximate number of minute from the last bind. - -- It bases its computation on file stamp and therefore does gibe not - -- any meaningful result before the new output binder file is written. - -- So it returns Nat'last if - -- - it is the first bind of this specific program - -- - Record_Time_From_Last_Bind was not Called first - -- - Close_Binder_Output was not called first - -- otherwise returns the number of minutes - -- till the last bind. The computation does not try to be completely - -- accurate and in particular does not take leap years into account. - type String_Access_List is array (Positive range <>) of String_Access; -- Deferenced type used to return a list of file specs in -- To_Canonical_File_List. type String_Access_List_Access is access all String_Access_List; - -- Type used to return a String_Access_List without dragging in secondary + -- Type used to return a String_Access_List without dragging in secondary -- stack. function To_Canonical_File_List - (Wildcard_Host_File : String; Only_Dirs : Boolean) - return String_Access_List_Access; + (Wildcard_Host_File : String; + Only_Dirs : Boolean) + return String_Access_List_Access; -- Expand a wildcard host syntax file or directory specification (e.g. on -- a VMS host, any file or directory spec that contains: -- "*", or "%", or "...") @@ -206,7 +160,7 @@ package Osint is function To_Canonical_Dir_Spec (Host_Dir : String; Prefix_Style : Boolean) - return String_Access; + return String_Access; -- Convert a host syntax directory specification (e.g. on a VMS host: -- "SYS$DEVICE:[DIR]") to canonical (Unix) syntax (e.g. "/sys$device/dir"). -- If Prefix_Style then make it a valid file specification prefix. @@ -217,14 +171,14 @@ package Osint is function To_Canonical_File_Spec (Host_File : String) - return String_Access; + return String_Access; -- Convert a host syntax file specification (e.g. on a VMS host: -- "SYS$DEVICE:[DIR]FILE.EXT;69 to canonical (Unix) syntax (e.g. -- "/sys$device/dir/file.ext.69"). function To_Canonical_Path_Spec (Host_Path : String) - return String_Access; + return String_Access; -- Convert a host syntax Path specification (e.g. on a VMS host: -- "SYS$DEVICE:[BAR],DISK$USER:[FOO] to canonical (Unix) syntax (e.g. -- "/sys$device/foo:disk$user/foo"). @@ -232,14 +186,14 @@ package Osint is function To_Host_Dir_Spec (Canonical_Dir : String; Prefix_Style : Boolean) - return String_Access; + return String_Access; -- Convert a canonical syntax directory specification to host syntax. -- The Prefix_Style flag is currently ignored but should be set to -- False. function To_Host_File_Spec (Canonical_File : String) - return String_Access; + return String_Access; -- Convert a canonical syntax file specification to host syntax. ------------------------- @@ -267,9 +221,17 @@ package Osint is -- name, and calls to the function return successive directory names, -- with a null pointer marking the end of the list. + type Search_File_Type is (Include, Objects); + + procedure Add_Search_Dirs + (Search_Path : String_Ptr; + Path_Type : Search_File_Type); + -- These procedure adds all the search directories that are in Search_Path + -- in the proper file search path (library or source) + function Get_Primary_Src_Search_Directory return String_Ptr; -- Retrieved the primary directory (directory containing the main source - -- file for Gnatmake. + -- file for Gnatmake. function Nb_Dir_In_Src_Search_Path return Natural; function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr; @@ -279,23 +241,44 @@ package Osint is function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr; -- Functions to access the directory names in the Object search path - Include_Search_File : constant String_Access - := new String'("ada_source_path"); - Objects_Search_File : constant String_Access - := new String'("ada_object_path"); - - -- Files containg the default include or objects search directories. + Include_Search_File : constant String_Access := + new String'("ada_source_path"); + Objects_Search_File : constant String_Access := + new String'("ada_object_path"); + -- Names of the files containg the default include or objects search + -- directories. These files, located in Sdefault.Search_Dir_Prefix, do + -- not necessarily exist. function Read_Default_Search_Dirs - (Search_Dir_Prefix : String_Access; - Search_File : String_Access; + (Search_Dir_Prefix : String_Access; + Search_File : String_Access; Search_Dir_Default_Name : String_Access) - return String_Access; + return String_Access; -- Read and return the default search directories from the file located -- in Search_Dir_Prefix (as modified by update_path) and named Search_File. -- If no such file exists or an error occurs then instead return the -- Search_Dir_Default_Name (as modified by update_path). + function Get_RTS_Search_Dir + (Search_Dir : String; + File_Type : Search_File_Type) + return String_Ptr; + -- This function retrieves the paths to the search (resp. lib) dirs and + -- return them. The search dir can be absolute or relative. If the search + -- dir contains Include_Search_File (resp. Object_Search_File), then this + -- function reads and returns the default search directories from the file. + -- Otherwise, if the directory is absolute, it will try to find 'adalib' + -- (resp. 'adainclude'). If found, null is returned. If the directory is + -- relative, the following directories for the directories 'adalib' and + -- 'adainclude' will be scanned: + -- + -- - current directory (from which the tool has been spawned) + -- - $GNAT_ROOT/gcc/gcc-lib/$targ/$vers/ + -- - $GNAT_ROOT/gcc/gcc-lib/$targ/$vers/rts- + -- + -- The scan will stop as soon as the directory being searched for (adalib + -- or adainclude) is found. If the scan fails, null is returned. + ----------------------- -- Source File Input -- ----------------------- @@ -304,18 +287,6 @@ package Osint is -- source files and the subsidiary source files (e.g. with'ed units), and -- also by the binder to check presence/time stamps of sources. - function More_Source_Files return Boolean; - -- Indicates whether more source file remain to be processed. Returns - -- False right away if no source files, or if all source files have - -- been processed. - - function Next_Main_Source return File_Name_Type; - -- This function returns the name of the next main source file specified - -- on the command line. It is an error to call Next_Main_Source if no more - -- source files exist (i.e. Next_Main_Source may be called only if a - -- previous call to More_Source_Files returned True). This name is the - -- simple file name (without any directory information). - procedure Read_Source_File (N : File_Name_Type; Lo : Source_Ptr; @@ -436,18 +407,6 @@ package Osint is -- These subprograms are used by the binder to read library information -- files, see section above for representation of these files. - function More_Lib_Files return Boolean; - -- Indicates whether more library information files remain to be processed. - -- Returns False right away if no source files, or if all source files - -- have been processed. - - function Next_Main_Lib_File return File_Name_Type; - -- This function returns the name of the next library info file specified - -- on the command line. It is an error to call Next_Main_Lib_File if no - -- more library information files exist (i.e. Next_Main_Lib_File may be - -- called only if a previous call to More_Lib_Files returned True). This - -- name is the simple name, excluding any directory information. - function Read_Library_Info (Lib_File : File_Name_Type; Fatal_Err : Boolean := False) @@ -477,15 +436,6 @@ package Osint is -- behaves as if it did not find Lib_File (namely if Fatal_Err is -- False, null is returned). - procedure Read_Library_Info - (Name : out File_Name_Type; - Text : out Text_Buffer_Ptr); - -- The procedure version of Read_Library_Info is used from the compiler - -- to read an existing ali file associated with the main unit. If the - -- ALI file exists, then its file name is returned in Name, and its - -- text is returned in Text. If the file does not exist, then Text is - -- set to null. - function Full_Library_Info_Name return File_Name_Type; function Full_Object_File_Name return File_Name_Type; -- Returns the full name of the library/object file most recently read @@ -511,39 +461,6 @@ package Osint is -- file directory lookup penalty is incurred every single time this -- routine is called. - function Object_File_Name (N : File_Name_Type) return File_Name_Type; - -- Constructs the name of the object file corresponding to library - -- file N. If N is a full file name than the returned file name will - -- also be a full file name. Note that no lookup in the library file - -- directories is done for this file. This routine merely constructs - -- the name. - - -------------------------------- - -- Library Information Output -- - -------------------------------- - - -- These routines are used by the compiler to generate the library - -- information file for the main source file being compiled. See section - -- above for a discussion of how library information files are stored. - - procedure Create_Output_Library_Info; - -- Creates the output library information file for the source file which - -- is currently being compiled (i.e. the file which was most recently - -- returned by Next_Main_Source). - - procedure Write_Library_Info (Info : String); - -- Writes the contents of the referenced string to the library information - -- file for the main source file currently being compiled (i.e. the file - -- which was most recently opened with a call to Read_Next_File). Info - -- represents a single line in the file, but does not contain any line - -- termination characters. The implementation of Write_Library_Info is - -- responsible for adding necessary end of line and end of file control - -- characters to the generated file. - - procedure Close_Output_Library_Info; - -- Closes the file created by Create_Output_Library_Info, flushing any - -- buffers etc from writes by Write_Library_Info. - function Lib_File_Name (Source_File : File_Name_Type) return File_Name_Type; -- Given the name of a source file, returns the name of the corresponding -- library information file. This may be the name of the object file, or @@ -553,83 +470,6 @@ package Osint is -- compiler to determine the proper library information names to be placed -- in the generated library information file. - ------------------------------ - -- Debug Source File Output -- - ------------------------------ - - -- These routines are used by the compiler to generate the debug source - -- file for the Debug_Generated_Code (-gnatD switch) option. Note that - -- debug source file writing occurs at a completely different point in - -- the processing from library information output, so the code in the - -- body can assume these functions are never used at the same time. - - function Create_Debug_File (Src : File_Name_Type) return File_Name_Type; - -- Given the simple name of a source file, this routine creates the - -- corresponding debug file, and returns its full name. - - procedure Write_Debug_Info (Info : String); - -- Writes contents of given string as next line of the current debug - -- source file created by the most recent call to Get_Debug_Name. Info - -- does not contain any end of line or other formatting characters. - - procedure Close_Debug_File; - -- Close current debug file created by the most recent call to - -- Get_Debug_Name. - - function Debug_File_Eol_Length return Nat; - -- Returns the number of characters (1 for NL, 2 for CR/LF) written - -- at the end of each line by Write_Debug_Info. - - -------------------------------- - -- Semantic Tree Input-Output -- - -------------------------------- - - procedure Tree_Create; - -- Creates the tree output file for the source file which is currently - -- being compiled (i.e. the file which was most recently returned by - -- Next_Main_Source), and initializes Tree_IO.Tree_Write for output. - - procedure Tree_Close; - -- Closes the file previously opened by Tree_Create - - ------------------- - -- Binder Output -- - ------------------- - - -- These routines are used by the binder to generate the C source file - -- containing the binder output. The format of this file is described - -- in the package Bindfmt. - - procedure Create_Binder_Output - (Output_File_Name : String; - Typ : Character; - Bfile : out Name_Id); - -- Creates the binder output file. Typ is one of - -- - -- 'c' create output file for case of generating C - -- 'b' create body file for case of generating Ada - -- 's' create spec file for case of generating Ada - -- - -- If Output_File_Name is null, then a default name is used based on - -- the name of the most recently accessed main source file name. If - -- Output_File_Name is non-null then it is the full path name of the - -- file to be output (in the case of Ada, it must have an extension - -- of adb, and the spec file is created by changing the last character - -- from b to s. On return, Bfile also contains the Name_Id for the - -- generated file name. - - procedure Write_Binder_Info (Info : String); - -- Writes the contents of the referenced string to the binder output file - -- created by a previous call to Create_Binder_Output. Info represents a - -- single line in the file, but does not contain any line termination - -- characters. The implementation of Write_Binder_Info is responsible - -- for adding necessary end of line and end of file control characters - -- as required by the operating system. - - procedure Close_Binder_Output; - -- Closes the file created by Create_Binder_Output, flushing any - -- buffers etc from writes by Write_Binder_Info. - ----------------- -- Termination -- ----------------- @@ -644,6 +484,7 @@ package Osint is E_Abort); -- Internally detected compiler error procedure Exit_Program (Exit_Code : Exit_Code_Type); + pragma No_Return (Exit_Program); -- A call to Exit_Program terminates execution with the given status. -- A status of zero indicates normal completion, a non-zero status -- indicates abnormal termination. @@ -668,4 +509,75 @@ package Osint is pragma Import (C, Len_Arg, "__gnat_len_arg"); -- Get length of argument +private + + ALI_Suffix : constant String_Ptr := new String'("ali"); + -- The suffix used for the library files (also known as ALI files). + + Current_Main : File_Name_Type := No_File; + -- Used to save a simple file name between calls to Next_Main_Source and + -- Read_Source_File. If the file name argument to Read_Source_File is + -- No_File, that indicates that the file whose name was returned by the + -- last call to Next_Main_Source (and stored here) is to be read. + + Object_Suffix : constant String := Get_Object_Suffix.all; + -- The suffix used for the object files. + + Output_FD : File_Descriptor; + -- The file descriptor for the current library info, tree or binder output + + Output_File_Name : File_Name_Type; + -- File_Name_Type for name of open file whose FD is in Output_FD, the name + -- stored does not include the trailing NUL character. + + Argument_Count : constant Integer := Arg_Count - 1; + -- Number of arguments (excluding program name) + + type File_Name_Array is array (Int range <>) of String_Ptr; + type File_Name_Array_Ptr is access File_Name_Array; + File_Names : File_Name_Array_Ptr := + new File_Name_Array (1 .. Int (Argument_Count) + 2); + -- As arguments are scanned in Initialize, file names are stored + -- in this array. The string does not contain a terminating NUL. + -- The array is "extensible" because when using project files, + -- there may be more file names than argument on the command line. + + Current_File_Name_Index : Int := 0; + -- The index in File_Names of the last file opened by Next_Main_Source + -- or Next_Main_Lib_File. The value 0 indicates that no files have been + -- opened yet. + + procedure Create_File_And_Check + (Fdesc : out File_Descriptor; + Fmode : Mode); + -- Create file whose name (NUL terminated) is in Name_Buffer (with the + -- length in Name_Len), and place the resulting descriptor in Fdesc. + -- Issue message and exit with fatal error if file cannot be created. + -- The Fmode parameter is set to either Text or Binary (see description + -- of GNAT.OS_Lib.Create_File). + + type Program_Type is (Compiler, Binder, Make, Gnatls, Unspecified); + -- Program currently running + procedure Set_Program (P : Program_Type); + -- Indicates to the body of Osint the program currently running. + -- This procedure is called by the child packages of Osint. + -- A check is made that this procedure is not called several times. + + function More_Files return Boolean; + -- Implements More_Source_Files and More_Lib_Files. + + function Next_Main_File return File_Name_Type; + -- Implements Next_Main_Source and Next_Main_Lib_File. + + function Object_File_Name (N : File_Name_Type) return File_Name_Type; + -- Constructs the name of the object file corresponding to library + -- file N. If N is a full file name than the returned file name will + -- also be a full file name. Note that no lookup in the library file + -- directories is done for this file. This routine merely constructs + -- the name. + + procedure Write_Info (Info : String); + -- Implementation of Write_Binder_Info, Write_Debug_Info and + -- Write_Library_Info (identical) + end Osint; diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb index af23afc6db9..4c2f148fbf7 100644 --- a/gcc/ada/output.adb +++ b/gcc/ada/output.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.43 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- @@ -40,6 +40,33 @@ package body Output is Current_FD : File_Descriptor := Standout; -- File descriptor for current output + Special_Output_Proc : Output_Proc := null; + -- Record argument to last call to Set_Special_Output. If this is + -- non-null, then we are in special output mode. + + ------------------------- + -- Line Buffer Control -- + ------------------------- + + -- Note: the following buffer and column position are maintained by + -- the subprograms defined in this package, and are not normally + -- directly modified or accessed by a client. However, a client is + -- permitted to modify these values, using the knowledge that only + -- Write_Eol actually generates any output. + + Buffer_Max : constant := 8192; + Buffer : String (1 .. Buffer_Max + 1); + -- Buffer used to build output line. We do line buffering because it + -- is needed for the support of the debug-generated-code option (-gnatD). + -- Historically it was first added because on VMS, line buffering is + -- needed with certain file formats. So in any case line buffering must + -- be retained for this purpose, even if other reasons disappear. Note + -- any attempt to write more output to a line than can fit in the buffer + -- will be silently ignored. + + Next_Column : Pos range 1 .. Buffer'Length + 1 := 1; + -- Column about to be written. + ----------------------- -- Local_Subprograms -- ----------------------- @@ -47,34 +74,87 @@ package body Output is procedure Flush_Buffer; -- Flush buffer if non-empty and reset column counter + --------------------------- + -- Cancel_Special_Output -- + --------------------------- + + procedure Cancel_Special_Output is + begin + Special_Output_Proc := null; + end Cancel_Special_Output; + ------------------ -- Flush_Buffer -- ------------------ procedure Flush_Buffer is - Len : constant Natural := Natural (Column - 1); + Len : constant Natural := Natural (Next_Column - 1); begin if Len /= 0 then - if Len /= Write (Current_FD, Buffer'Address, Len) then - Set_Standard_Error; - Write_Line ("fatal error: disk full"); - OS_Exit (2); + + -- If Special_Output_Proc has been set, then use it + + if Special_Output_Proc /= null then + Special_Output_Proc.all (Buffer (1 .. Len)); + + -- If output is not set, then output to either standard output + -- or standard error. + + elsif Len /= Write (Current_FD, Buffer'Address, Len) then + + -- If there are errors with standard error, just quit + + if Current_FD = Standerr then + OS_Exit (2); + + -- Otherwise, set the output to standard error before + -- reporting a failure and quitting. + + else + Current_FD := Standerr; + Next_Column := 1; + Write_Line ("fatal error: disk full"); + OS_Exit (2); + end if; end if; - Column := 1; + -- Buffer is now empty + + Next_Column := 1; end if; end Flush_Buffer; + ------------ + -- Column -- + ------------ + + function Column return Nat is + begin + return Next_Column; + end Column; + + ------------------------ + -- Set_Special_Output -- + ------------------------ + + procedure Set_Special_Output (P : Output_Proc) is + begin + Special_Output_Proc := P; + end Set_Special_Output; + ------------------------ -- Set_Standard_Error -- ------------------------ procedure Set_Standard_Error is begin - Flush_Buffer; + if Special_Output_Proc = null then + Flush_Buffer; + Next_Column := 1; + end if; + Current_FD := Standerr; - Column := 1; end Set_Standard_Error; ------------------------- @@ -83,9 +163,12 @@ package body Output is procedure Set_Standard_Output is begin - Flush_Buffer; + if Special_Output_Proc = null then + Flush_Buffer; + Next_Column := 1; + end if; + Current_FD := Standout; - Column := 1; end Set_Standard_Output; ------- @@ -155,9 +238,9 @@ package body Output is procedure Write_Char (C : Character) is begin - if Column < Buffer'Length then - Buffer (Natural (Column)) := C; - Column := Column + 1; + if Next_Column < Buffer'Length then + Buffer (Natural (Next_Column)) := C; + Next_Column := Next_Column + 1; end if; end Write_Char; @@ -167,8 +250,8 @@ package body Output is procedure Write_Eol is begin - Buffer (Natural (Column)) := ASCII.LF; - Column := Column + 1; + Buffer (Natural (Next_Column)) := ASCII.LF; + Next_Column := Next_Column + 1; Flush_Buffer; end Write_Eol; diff --git a/gcc/ada/output.ads b/gcc/ada/output.ads index bc61989fd87..a6605297e32 100644 --- a/gcc/ada/output.ads +++ b/gcc/ada/output.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.28 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -42,41 +42,47 @@ with Types; use Types; package Output is pragma Elaborate_Body (Output); - ------------------------- - -- Line Buffer Control -- - ------------------------- - - -- Note: the following buffer and column position are maintained by - -- the subprograms defined in this package, and are not normally - -- directly modified or accessed by a client. However, a client is - -- permitted to modify these values, using the knowledge that only - -- Write_Eol actually generates any output. - - Buffer_Max : constant := 8192; - Buffer : String (1 .. Buffer_Max + 1); - -- Buffer used to build output line. We do line buffering because it - -- is needed for the support of the debug-generated-code option (-gnatD). - -- Historically it was first added because on VMS, line buffering is - -- needed with certain file formats. So in any case line buffering must - -- be retained for this purpose, even if other reasons disappear. Note - -- any attempt to write more output to a line than can fit in the buffer - -- will be silently ignored. - - Column : Pos range 1 .. Buffer'Length + 1 := 1; - -- Column about to be written. + type Output_Proc is access procedure (S : String); + -- This type is used for the Set_Special_Output procedure. If this + -- procedure is called, then instead of lines being written to + -- standard error or standard output, a call is made to the given + -- procedure for each line, passing the line with an end of line + -- character (which is a single ASCII.LF character, even in systems + -- which normally use CR/LF or some other sequence for line end). ----------------- -- Subprograms -- ----------------- + procedure Set_Special_Output (P : Output_Proc); + -- Sets subsequent output to call procedure P. If P is null, then + -- the call cancels the effect of a previous call, reverting the + -- output to standard error or standard output depending on the + -- mode at the time of previous call. Any exception generated by + -- by calls to P is simply propagated to the caller of the routine + -- causing the write operation. + + procedure Cancel_Special_Output; + -- Cancels the effect of a call to Set_Special_Output, if any. + -- The output is then directed to standard error or standard output + -- depending on the last call to Set_Standard_Error or Set_Standard_Output. + -- It is never an error to call Cancel_Special_Output. It has the same + -- effect as calling Set_Special_Output (null). + procedure Set_Standard_Error; -- Sets subsequent output to appear on the standard error file (whatever - -- that might mean for the host operating system, if anything). + -- that might mean for the host operating system, if anything) when + -- no special output is in effect. When a special output is in effect, + -- the output will appear on standard error only after special output + -- has been cancelled. procedure Set_Standard_Output; -- Sets subsequent output to appear on the standard output file (whatever - -- that might mean for the host operating system, if anything). This is - -- the default mode before any call to either of the Set procedures. + -- that might mean for the host operating system, if anything) when + -- no special output is in effect. When a special output is in effect, + -- the output will appear on standard output only after special output + -- has been cancelled. Output to standard output is the default mode + -- before any call to either of the Set procedures. procedure Write_Char (C : Character); -- Write one character to the standard output file. Note that the @@ -102,6 +108,11 @@ pragma Elaborate_Body (Output); procedure Write_Line (S : String); -- Equivalent to Write_Str (S) followed by Write_Eol; + function Column return Nat; + pragma Inline (Column); + -- Returns the number of the column about to be written (e.g. a value + -- of 1 means the current line is empty). + -------------------------- -- Debugging Procedures -- -------------------------- diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index 0eeacead811..bade8aae77b 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.35 $ -- +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -223,6 +223,26 @@ package body Ch2 is Semicolon_Loc : Source_Ptr; Ident_Node : Node_Id; Assoc_Node : Node_Id; + Result : Node_Id; + + procedure Skip_Pragma_Semicolon; + -- Skip past semicolon at end of pragma + + --------------------------- + -- Skip_Pragma_Semicolon -- + --------------------------- + + procedure Skip_Pragma_Semicolon is + begin + if Token /= Tok_Semicolon then + T_Semicolon; + Resync_Past_Semicolon; + else + Scan; -- past semicolon + end if; + end Skip_Pragma_Semicolon; + + -- Start of processing for P_Pragma begin Pragma_Node := New_Node (N_Pragma, Token_Ptr); @@ -285,20 +305,26 @@ package body Ch2 is Semicolon_Loc := Token_Ptr; - if Token /= Tok_Semicolon then - T_Semicolon; - Resync_Past_Semicolon; + -- Now we have two tasks left, we need to scan out the semicolon + -- following the pragma, and we have to call Par.Prag to process + -- the pragma. Normally we do them in this order, however, there + -- is one exception namely pragma Style_Checks where we like to + -- skip the semicolon after processing the pragma, since that way + -- the style checks for the scanning of the semicolon follow the + -- settings of the pragma. + + -- You might think we could just unconditionally do things in + -- the opposite order, but there are other pragmas, notably the + -- case of pragma Source_File_Name, which assume the semicolon + -- is already scanned out. + + if Chars (Pragma_Node) = Name_Style_Checks then + Result := Par.Prag (Pragma_Node, Semicolon_Loc); + Skip_Pragma_Semicolon; + return Result; else - Scan; -- past semicolon - end if; - - if Is_Pragma_Name (Chars (Pragma_Node)) then + Skip_Pragma_Semicolon; return Par.Prag (Pragma_Node, Semicolon_Loc); - - else - -- Unrecognized pragma, warning generated in Sem_Prag - - return Pragma_Node; end if; exception diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index afecf24892c..7dd82b250d1 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -415,6 +415,13 @@ package body Ch3 is when Tok_Left_Paren => Typedef_Node := P_Enumeration_Type_Definition; + + End_Labl := + Make_Identifier (Token_Ptr, + Chars => Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label (Typedef_Node, End_Labl); TF_Semicolon; exit; @@ -473,6 +480,13 @@ package body Ch3 is Typedef_Node := P_Record_Definition; Set_Tagged_Present (Typedef_Node, True); Set_Limited_Present (Typedef_Node, True); + + End_Labl := + Make_Identifier (Token_Ptr, + Chars => Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label (Typedef_Node, End_Labl); end if; else @@ -489,6 +503,13 @@ package body Ch3 is else Typedef_Node := P_Record_Definition; Set_Tagged_Present (Typedef_Node, True); + + End_Labl := + Make_Identifier (Token_Ptr, + Chars => Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label (Typedef_Node, End_Labl); end if; end if; @@ -2976,7 +2997,7 @@ package body Ch3 is end if; if Token = Tok_Comma then - Error_Msg_SC (""","" should be ""|"""); + Error_Msg_SC (""","" should be ""'|"""); else exit when Token /= Tok_Vertical_Bar; end if; diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index fb31c34e5c6..46866ec6e5d 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- @@ -595,7 +595,20 @@ package body Ch5 is Scan; -- past semicolon Statement_Required := False; - -- Else we have a missing semicolon + -- A slash following an identifier or a selected + -- component in this situation is most likely a + -- period (have a look at the keyboard :-) + + elsif Token = Tok_Slash + and then (Nkind (Name_Node) = N_Identifier + or else + Nkind (Name_Node) = N_Selected_Component) + then + Error_Msg_SC ("""/"" should be ""."""); + Statement_Required := False; + raise Error_Resync; + + -- Else we have a missing semicolon else TF_Semicolon; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 9a41ffd0c06..7ab1c350aa7 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -54,7 +54,6 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is function Arg1 return Node_Id; function Arg2 return Node_Id; function Arg3 return Node_Id; - function Arg4 return Node_Id; -- Obtain specified Pragma_Argument_Association. It is allowable to call -- the routine for the argument one past the last present argument, but -- that is the only case in which a non-present argument can be referenced. @@ -113,15 +112,6 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is return Next (Arg2); end Arg3; - ---------- - -- Arg4 -- - ---------- - - function Arg4 return Node_Id is - begin - return Next (Arg3); - end Arg4; - --------------------- -- Check_Arg_Count -- --------------------- @@ -215,6 +205,14 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is begin Error_Msg_Name_1 := Pragma_Name; + -- Ignore unrecognized pragma. We let Sem post the warning for this, since + -- it is a semantic error, not a syntactic one (we have already checked + -- the syntax for the unrecognized pragma as required by (RM 2.8(11)). + + if not Is_Pragma_Name (Chars (Pragma_Node)) then + return Pragma_Node; + end if; + -- Count number of arguments. This loop also checks if any of the arguments -- are Error, indicating a syntax error as they were parsed. If so, we -- simply return, because we get into trouble with cascaded errors if we @@ -527,6 +525,14 @@ begin and then Nkind (Selector_Name (Expr1)) = N_Identifier) then + if Nkind (Expr1) = N_Identifier + and then Chars (Expr1) = Name_System + then + Error_Msg_N + ("pragma Source_File_Name may not be used for System", Arg1); + return Error; + end if; + Check_Arg_Count (2); Check_Optional_Identifier (Arg1, Name_Unit_Name); @@ -830,6 +836,7 @@ begin Pragma_Atomic | Pragma_Atomic_Components | Pragma_Attach_Handler | + Pragma_Convention_Identifier | Pragma_CPP_Class | Pragma_CPP_Constructor | Pragma_CPP_Virtual | @@ -927,6 +934,8 @@ begin Pragma_Title | Pragma_Unchecked_Union | Pragma_Unimplemented_Unit | + Pragma_Universal_Data | + Pragma_Unreferenced | Pragma_Unreserve_All_Interrupts | Pragma_Unsuppress | Pragma_Use_VADS_Size | diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb index 4d49e7af738..e3f619c8f45 100644 --- a/gcc/ada/par-tchk.adb +++ b/gcc/ada/par-tchk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.37 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -427,13 +427,13 @@ package body Tchk is -- place to suggest the possibility of a "C" confusion :-) elsif Token = Tok_Vertical_Bar then - Error_Msg_SC ("unexpected occurrence of ""|"", did you mean OR'?"); + Error_Msg_SC ("unexpected occurrence of ""'|"", did you mean OR'?"); Resync_Past_Semicolon; -- Otherwise we really do have a missing semicolon else - Error_Msg_AP ("missing "";"""); + Error_Msg_AP ("|missing "";"""); return; end if; diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index f8082b64ee6..c681863b8b4 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.64 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- @@ -360,6 +360,8 @@ package body Util is ----------------------- procedure Discard_Junk_List (L : List_Id) is + pragma Warnings (Off, L); + begin null; end Discard_Junk_List; @@ -369,6 +371,8 @@ package body Util is ----------------------- procedure Discard_Junk_Node (N : Node_Id) is + pragma Warnings (Off, N); + begin null; end Discard_Junk_Node; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 5ecce52393f..5399e2b9a2d 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -974,7 +974,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- of implementation defined pragmas. The second parameter records the -- location of the semicolon following the pragma (this is needed for -- correct processing of the List and Page pragmas). The returned value - -- is a copy of Pragma_Node, or Error if an error is found. + -- is a copy of Pragma_Node, or Error if an error is found. Note that + -- at the point where Prag is called, the right paren ending the pragma + -- has been scanned out, and except in the case of pragma Style_Checks, + -- so has the following semicolon. For Style_Checks, the caller delays + -- the scanning of the semicolon so that it will be scanned using the + -- settings from the Style_Checks pragma preceding it. ------------------------- -- Subsidiary Routines -- @@ -1054,7 +1059,7 @@ begin if Configuration_Pragmas then declare - Ecount : constant Int := Errors_Detected; + Ecount : constant Int := Total_Errors_Detected; Pragmas : List_Id := Empty_List; P_Node : Node_Id; @@ -1070,7 +1075,7 @@ begin else P_Node := P_Pragma; - if Errors_Detected > Ecount then + if Total_Errors_Detected > Ecount then return Error_List; end if; diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index b9ed55b6eb6..d835341043f 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -127,6 +127,17 @@ package body Prj.Attr is "Pgnatstub#" & "LVswitches#" & + -- package Ide + + "Pide#" & + "SVremote_host#" & + "Sacompiler_command#" & + "SVdebugger_command#" & + "SVgnatlist#" & + "SVvcs_kind#" & + "SVvcs_file_check#" & + "SVvcs_log_check#" & + "#"; ---------------- diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 55bfb44bdb1..ff6591fd8bd 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -26,17 +26,19 @@ -- -- ------------------------------------------------------------------------------ -with Errout; use Errout; -with Prj.Strt; -with Prj.Tree; use Prj.Tree; -with Scans; use Scans; -with Sinfo; use Sinfo; -with Types; use Types; -with Prj.Attr; use Prj.Attr; +with Errout; use Errout; +with Namet; use Namet; +with Prj.Strt; use Prj.Strt; +with Prj.Tree; use Prj.Tree; +with Scans; use Scans; +with Sinfo; use Sinfo; +with Types; use Types; +with Prj.Attr; use Prj.Attr; package body Prj.Dect is type Zone is (In_Project, In_Package, In_Case_Construction); + -- Needs a comment ??? procedure Parse_Attribute_Declaration (Attribute : out Project_Node_Id; @@ -67,16 +69,14 @@ package body Prj.Dect is -- Parse a package declaration procedure Parse_String_Type_Declaration - (String_Type : out Project_Node_Id; - Current_Project : Project_Node_Id; - First_Attribute : Attribute_Node_Id); + (String_Type : out Project_Node_Id; + Current_Project : Project_Node_Id); -- type <name> is ( <literal_string> { , <literal_string> } ) ; procedure Parse_Variable_Declaration - (Variable : out Project_Node_Id; - First_Attribute : Attribute_Node_Id; - Current_Project : Project_Node_Id; - Current_Package : Project_Node_Id); + (Variable : out Project_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id); -- Parse a variable assignment -- <variable_Name> := <expression>; OR -- <variable_Name> : <string_type_Name> := <string_expression>; @@ -96,6 +96,7 @@ package body Prj.Dect is Declarations := Default_Project_Node (Of_Kind => N_Project_Declaration); Set_Location_Of (Declarations, To => Token_Ptr); Set_Modified_Project_Of (Declarations, To => Extends); + Set_Project_Declaration_Of (Current_Project, Declarations); Parse_Declarative_Items (Declarations => First_Declarative_Item, In_Zone => In_Project, @@ -132,12 +133,6 @@ package body Prj.Dect is Set_Name_Of (Attribute, To => Token_Name); Set_Location_Of (Attribute, To => Token_Ptr); - if Attributes.Table (Current_Attribute).Kind_2 = - Case_Insensitive_Associative_Array - then - Set_Case_Insensitive (Attribute, To => True); - end if; - while Current_Attribute /= Empty_Attribute and then Attributes.Table (Current_Attribute).Name /= Token_Name @@ -146,7 +141,15 @@ package body Prj.Dect is end loop; if Current_Attribute = Empty_Attribute then - Error_Msg ("undefined attribute", Token_Ptr); + Error_Msg ("undefined attribute """ & + Get_Name_String (Name_Of (Attribute)) & + """", + Token_Ptr); + + elsif Attributes.Table (Current_Attribute).Kind_2 = + Case_Insensitive_Associative_Array + then + Set_Case_Insensitive (Attribute, To => True); end if; Scan; @@ -156,7 +159,10 @@ package body Prj.Dect is if Current_Attribute /= Empty_Attribute and then Attributes.Table (Current_Attribute).Kind_2 = Single then - Error_Msg ("this attribute cannot be an associative array", + Error_Msg ("the attribute """ & + Get_Name_String + (Attributes.Table (Current_Attribute).Name) & + """ cannot be an associative array", Location_Of (Attribute)); end if; @@ -179,7 +185,10 @@ package body Prj.Dect is and then Attributes.Table (Current_Attribute).Kind_2 /= Single then - Error_Msg ("this attribute need to be an associative array", + Error_Msg ("the attribute """ & + Get_Name_String + (Attributes.Table (Current_Attribute).Name) & + """ needs to be an associative array", Location_Of (Attribute)); end if; end if; @@ -199,7 +208,7 @@ package body Prj.Dect is Expression : Project_Node_Id := Empty_Node; begin - Prj.Strt.Parse_Expression + Parse_Expression (Expression => Expression, Current_Project => Current_Project, Current_Package => Current_Package); @@ -211,7 +220,10 @@ package body Prj.Dect is Expression_Kind_Of (Expression) then Error_Msg - ("wrong expression kind for the attribute", + ("wrong expression kind for attribute """ & + Get_Name_String + (Attributes.Table (Current_Attribute).Name) & + """", Expression_Location); end if; end; @@ -229,19 +241,19 @@ package body Prj.Dect is Current_Project : Project_Node_Id; Current_Package : Project_Node_Id) is - Current_Item : Project_Node_Id := Empty_Node; - Next_Item : Project_Node_Id := Empty_Node; - First_Case_Item : Boolean := True; + Current_Item : Project_Node_Id := Empty_Node; + Next_Item : Project_Node_Id := Empty_Node; + First_Case_Item : Boolean := True; Variable_Location : Source_Ptr := No_Location; - String_Type : Project_Node_Id := Empty_Node; + String_Type : Project_Node_Id := Empty_Node; - Case_Variable : Project_Node_Id := Empty_Node; + Case_Variable : Project_Node_Id := Empty_Node; First_Declarative_Item : Project_Node_Id := Empty_Node; - First_Choice : Project_Node_Id := Empty_Node; + First_Choice : Project_Node_Id := Empty_Node; begin Case_Construction := @@ -258,7 +270,7 @@ package body Prj.Dect is if Token = Tok_Identifier then Variable_Location := Token_Ptr; - Prj.Strt.Parse_Variable_Reference + Parse_Variable_Reference (Variable => Case_Variable, Current_Project => Current_Project, Current_Package => Current_Package); @@ -275,7 +287,10 @@ package body Prj.Dect is String_Type := String_Type_Of (Case_Variable); if String_Type = Empty_Node then - Error_Msg ("this variable is not typed", Variable_Location); + Error_Msg ("variable """ & + Get_Name_String (Name_Of (Case_Variable)) & + """ is not typed", + Variable_Location); end if; end if; @@ -288,7 +303,7 @@ package body Prj.Dect is Scan; end if; - Prj.Strt.Start_New_Case_Construction (String_Type); + Start_New_Case_Construction (String_Type); When_Loop : @@ -339,7 +354,7 @@ package body Prj.Dect is exit When_Loop; else - Prj.Strt.Parse_Choice_List (First_Choice => First_Choice); + Parse_Choice_List (First_Choice => First_Choice); Set_First_Choice_Of (Current_Item, To => First_Choice); Expect (Tok_Arrow, "=>"); @@ -357,7 +372,7 @@ package body Prj.Dect is end if; end loop When_Loop; - Prj.Strt.End_Case_Construction; + End_Case_Construction; Expect (Tok_End, "end case"); @@ -417,7 +432,6 @@ package body Prj.Dect is Parse_Variable_Declaration (Current_Declaration, - First_Attribute => First_Attribute, Current_Project => Current_Project, Current_Package => Current_Package); @@ -452,8 +466,7 @@ package body Prj.Dect is Parse_String_Type_Declaration (String_Type => Current_Declaration, - Current_Project => Current_Project, - First_Attribute => First_Attribute); + Current_Project => Current_Project); when Tok_Case => @@ -535,7 +548,10 @@ package body Prj.Dect is end loop; if Current_Package = Empty_Package then - Error_Msg ("not an allowed package name", Token_Ptr); + Error_Msg ("""" & + Get_Name_String (Name_Of (Package_Declaration)) & + """ is not an allowed package name", + Token_Ptr); else Set_Package_Id_Of (Package_Declaration, To => Current_Package); @@ -552,7 +568,10 @@ package body Prj.Dect is if Current /= Empty_Node then Error_Msg - ("package declared twice in the same project", Token_Ptr); + ("package """ & + Get_Name_String (Name_Of (Package_Declaration)) & + """ is declared twice in the same project", + Token_Ptr); else -- Add the package to the project list @@ -569,11 +588,12 @@ package body Prj.Dect is -- Scan past the package name Scan; - end if; if Token = Tok_Renames then + -- Scan past "renames" + Scan; Expect (Tok_Identifier, "identifier"); @@ -593,7 +613,9 @@ package body Prj.Dect is end loop; if Clause = Empty_Node then - Error_Msg ("not an imported project", Token_Ptr); + Error_Msg ("""" & + Get_Name_String (Project_Name) & + """ is not an imported project", Token_Ptr); else Set_Project_Of_Renamed_Package_Of (Package_Declaration, To => The_Project); @@ -629,7 +651,9 @@ package body Prj.Dect is if Current = Empty_Node then Error_Msg - ("not a package declared by the project", + ("""" & + Get_Name_String (Token_Name) & + """ is not a package declared by the project", Token_Ptr); end if; end; @@ -696,8 +720,7 @@ package body Prj.Dect is procedure Parse_String_Type_Declaration (String_Type : out Project_Node_Id; - Current_Project : Project_Node_Id; - First_Attribute : Attribute_Node_Id) + Current_Project : Project_Node_Id) is Current : Project_Node_Id := Empty_Node; First_String : Project_Node_Id := Empty_Node; @@ -726,7 +749,10 @@ package body Prj.Dect is end loop; if Current /= Empty_Node then - Error_Msg ("duplicate string type name", Token_Ptr); + Error_Msg ("duplicate string type name """ & + Get_Name_String (Token_Name) & + """", + Token_Ptr); else Current := First_Variable_Of (Current_Project); while Current /= Empty_Node @@ -736,7 +762,9 @@ package body Prj.Dect is end loop; if Current /= Empty_Node then - Error_Msg ("already a variable name", Token_Ptr); + Error_Msg ("""" & + Get_Name_String (Token_Name) & + """ is already a variable name", Token_Ptr); else Set_Next_String_Type (String_Type, To => First_String_Type_Of (Current_Project)); @@ -761,7 +789,7 @@ package body Prj.Dect is Scan; end if; - Prj.Strt.Parse_String_Type_List (First_String => First_String); + Parse_String_Type_List (First_String => First_String); Set_First_Literal_String (String_Type, To => First_String); Expect (Tok_Right_Paren, ")"); @@ -778,7 +806,6 @@ package body Prj.Dect is procedure Parse_Variable_Declaration (Variable : out Project_Node_Id; - First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id) is @@ -850,7 +877,11 @@ package body Prj.Dect is if The_Project_Name_And_Node = Tree_Private_Part.No_Project_Name_And_Node then - Error_Msg ("unknown project", Project_Location); + Error_Msg ("unknown project """ & + Get_Name_String + (Project_String_Type_Name) & + """", + Project_Location); Current := Empty_Node; else Current := @@ -867,7 +898,10 @@ package body Prj.Dect is end loop; if Current = Empty_Node then - Error_Msg ("unknown string type", Type_Location); + Error_Msg ("unknown string type """ & + Get_Name_String (String_Type_Name) & + """", + Type_Location); else Set_String_Type_Of (Variable, To => Current); @@ -887,7 +921,7 @@ package body Prj.Dect is Expression_Location := Token_Ptr; - Prj.Strt.Parse_Expression + Parse_Expression (Expression => Expression, Current_Project => Current_Project, Current_Package => Current_Package); @@ -936,7 +970,9 @@ package body Prj.Dect is if Expression_Kind_Of (The_Variable) /= Expression_Kind_Of (Variable) then - Error_Msg ("wrong expression kind for the variable", + Error_Msg ("wrong expression kind for variable """ & + Get_Name_String (Name_Of (The_Variable)) & + """", Expression_Location); end if; end if; diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index fd5109bb05c..82cb70a22e0 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -40,7 +40,6 @@ with Table; package body Prj.Env is type Naming_Id is new Nat; - No_Naming : constant Naming_Id := 0; Ada_Path_Buffer : String_Access := new String (1 .. 1_000); -- A buffer where values for ADA_INCLUDE_PATH @@ -62,6 +61,8 @@ package body Prj.Env is Global_Configuration_Pragmas : Name_Id; Local_Configuration_Pragmas : Name_Id; + Fill_Mapping_File : Boolean := True; + ----------------------- -- Local Subprograms -- ----------------------- @@ -74,6 +75,10 @@ package body Prj.Env is -- Returns the path name of the spec of a unit. -- Compute it first, if necessary. + procedure Add_To_Path (Source_Dirs : String_List_Id); + -- Add to Ada_Path_Buffer all the source directories in string list + -- Source_Dirs, if any. Increment Ada_Path_Length. + procedure Add_To_Path (Path : String); -- Add Path to global variable Ada_Path_Buffer -- Increment Ada_Path_Length @@ -85,12 +90,10 @@ package body Prj.Env is function Ada_Include_Path (Project : Project_Id) return String_Access is procedure Add (Project : Project_Id); - -- Add all the source directories of a project to the path, - -- only if this project has not been visited. - -- Call itself recursively for projects being modified, - -- and imported projects. - -- Add the project to the list Seen if this is the first time - -- we call Add for this project. + -- Add all the source directories of a project to the path only if + -- this project has not been visited. Calls itself recursively for + -- projects being modified, and imported projects. Adds the project + -- to the list Seen if this is the call to Add for this project. --------- -- Add -- @@ -98,8 +101,7 @@ package body Prj.Env is procedure Add (Project : Project_Id) is begin - -- If Seen is empty, then the project cannot have been - -- visited. + -- If Seen is empty, then the project cannot have been visited if not Projects.Table (Project).Seen then Projects.Table (Project).Seen := True; @@ -108,29 +110,10 @@ package body Prj.Env is Data : Project_Data := Projects.Table (Project); List : Project_List := Data.Imported_Projects; - Current : String_List_Id := Data.Source_Dirs; - Source_Dir : String_Element; - begin -- Add to path all source directories of this project - while Current /= Nil_String loop - if Ada_Path_Length > 0 then - Add_To_Path (Path => (1 => Path_Separator)); - end if; - - Source_Dir := String_Elements.Table (Current); - String_To_Name_Buffer (Source_Dir.Value); - - declare - New_Path : constant String := - Name_Buffer (1 .. Name_Len); - begin - Add_To_Path (New_Path); - end; - - Current := Source_Dir.Next; - end loop; + Add_To_Path (Data.Source_Dirs); -- Call Add to the project being modified, if any @@ -146,7 +129,6 @@ package body Prj.Env is end loop; end; end if; - end Add; -- Start of processing for Ada_Include_Path @@ -170,6 +152,21 @@ package body Prj.Env is return Projects.Table (Project).Include_Path; end Ada_Include_Path; + function Ada_Include_Path + (Project : Project_Id; + Recursive : Boolean) + return String + is + begin + if Recursive then + return Ada_Include_Path (Project).all; + else + Ada_Path_Length := 0; + Add_To_Path (Projects.Table (Project).Source_Dirs); + return Ada_Path_Buffer (1 .. Ada_Path_Length); + end if; + end Ada_Include_Path; + ---------------------- -- Ada_Objects_Path -- ---------------------- @@ -177,15 +174,13 @@ package body Prj.Env is function Ada_Objects_Path (Project : Project_Id; Including_Libraries : Boolean := True) - return String_Access is - + return String_Access + is procedure Add (Project : Project_Id); - -- Add all the object directory of a project to the path, - -- only if this project has not been visited. - -- Call itself recursively for projects being modified, - -- and imported projects. - -- Add the project to the list Seen if this is the first time - -- we call Add for this project. + -- Add all the object directories of a project to the path only if + -- this project has not been visited. Calls itself recursively for + -- projects being modified, and imported projects. Adds the project + -- to the list Seen if this is the first call to Add for this project. --------- -- Add -- @@ -193,7 +188,6 @@ package body Prj.Env is procedure Add (Project : Project_Id) is begin - -- If this project has not been seen yet if not Projects.Table (Project).Seen then @@ -281,6 +275,30 @@ package body Prj.Env is -- Add_To_Path -- ----------------- + procedure Add_To_Path (Source_Dirs : String_List_Id) is + Current : String_List_Id := Source_Dirs; + Source_Dir : String_Element; + + begin + while Current /= Nil_String loop + if Ada_Path_Length > 0 then + Add_To_Path (Path => (1 => Path_Separator)); + end if; + + Source_Dir := String_Elements.Table (Current); + String_To_Name_Buffer (Source_Dir.Value); + + declare + New_Path : constant String := + Name_Buffer (1 .. Name_Len); + begin + Add_To_Path (New_Path); + end; + + Current := Source_Dir.Next; + end loop; + end Add_To_Path; + procedure Add_To_Path (Path : String) is begin -- If Ada_Path_Buffer is too small, double it @@ -654,13 +672,11 @@ package body Prj.Env is Last : Natural; begin - -- Add an ASCII.LF to the string. As this gnat.adc - -- is supposed to be used only by the compiler, we don't - -- care about the characters for the end of line. - -- The truth is we could have put a space, but it is - -- more convenient to be able to read gnat.adc during - -- development. And the development was done under UNIX. - -- Hence the ASCII.LF. + -- Add an ASCII.LF to the string. As this gnat.adc is supposed to + -- be used only by the compiler, we don't care about the characters + -- for the end of line. In fact we could have put a space, but + -- it is more convenient to be able to read gnat.adc during + -- development, for which the ASCII.LF is fine. S0 (1 .. S'Length) := S; S0 (S0'Last) := ASCII.LF; @@ -678,7 +694,6 @@ package body Prj.Env is -- Start of processing for Create_Config_Pragmas_File begin - if not Projects.Table (For_Project).Config_Checked then -- Remove any memory of processed naming schemes, if any @@ -744,11 +759,11 @@ package body Prj.Env is end if; if Global_Attribute_Present then - if File /= Invalid_FD or else Local_Attribute_Present then Copy_File (Global_Attribute.Value); + else String_To_Name_Buffer (Global_Attribute.Value); Projects.Table (For_Project).Config_File_Name := Name_Find; @@ -756,7 +771,6 @@ package body Prj.Env is end if; if Local_Attribute_Present then - if File /= Invalid_FD then Copy_File (Local_Attribute.Value); @@ -764,7 +778,6 @@ package body Prj.Env is String_To_Name_Buffer (Local_Attribute.Value); Projects.Table (For_Project).Config_File_Name := Name_Find; end if; - end if; if File /= Invalid_FD then @@ -783,9 +796,7 @@ package body Prj.Env is end if; Projects.Table (For_Project).Config_Checked := True; - end if; - end Create_Config_Pragmas_File; ------------------------- @@ -797,8 +808,8 @@ package body Prj.Env is The_Unit_Data : Unit_Data; Data : File_Name_Data; - procedure Put (S : String); - -- Put a line in the mapping file + procedure Put_Name_Buffer; + -- Put the line contained in the Name_Buffer in the mapping file procedure Put_Data (Spec : Boolean); -- Put the mapping of the spec or body contained in Data in the file @@ -808,16 +819,18 @@ package body Prj.Env is -- Put -- --------- - procedure Put (S : String) is + procedure Put_Name_Buffer is Last : Natural; begin - Last := Write (File, S'Address, S'Length); + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ASCII.LF; + Last := Write (File, Name_Buffer (1)'Address, Name_Len); - if Last /= S'Length then + if Last /= Name_Len then Osint.Fail ("Disk full"); end if; - end Put; + end Put_Name_Buffer; -------------- -- Put_Data -- @@ -825,19 +838,31 @@ package body Prj.Env is procedure Put_Data (Spec : Boolean) is begin - Put (Get_Name_String (The_Unit_Data.Name)); + -- Line with the unit name + + Get_Name_String (The_Unit_Data.Name); + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := '%'; + Name_Len := Name_Len + 1; if Spec then - Put ("%s"); + Name_Buffer (Name_Len) := 's'; else - Put ("%b"); + Name_Buffer (Name_Len) := 'b'; end if; - Put (S => (1 => ASCII.LF)); - Put (Get_Name_String (Data.Name)); - Put (S => (1 => ASCII.LF)); - Put (Get_Name_String (Data.Path)); - Put (S => (1 => ASCII.LF)); + Put_Name_Buffer; + + -- Line with the file nale + + Get_Name_String (Data.Name); + Put_Name_Buffer; + + -- Line with the path name + + Get_Name_String (Data.Path); + Put_Name_Buffer; + end Put_Data; -- Start of processing for Create_Mapping_File @@ -855,32 +880,34 @@ package body Prj.Env is Write_Line (""""); end if; - -- For all units in table Units + if Fill_Mapping_File then + -- For all units in table Units - for Unit in 1 .. Units.Last loop - The_Unit_Data := Units.Table (Unit); + for Unit in 1 .. Units.Last loop + The_Unit_Data := Units.Table (Unit); - -- If the unit has a valid name + -- If the unit has a valid name - if The_Unit_Data.Name /= No_Name then - Data := The_Unit_Data.File_Names (Specification); + if The_Unit_Data.Name /= No_Name then + Data := The_Unit_Data.File_Names (Specification); - -- If there is a spec, put it mapping in the file + -- If there is a spec, put it mapping in the file - if Data.Name /= No_Name then - Put_Data (Spec => True); - end if; + if Data.Name /= No_Name then + Put_Data (Spec => True); + end if; - Data := The_Unit_Data.File_Names (Body_Part); + Data := The_Unit_Data.File_Names (Body_Part); - -- If there is a body (or subunit) put its mapping in the file + -- If there is a body (or subunit) put its mapping in the file - if Data.Name /= No_Name then - Put_Data (Spec => False); - end if; + if Data.Name /= No_Name then + Put_Data (Spec => False); + end if; - end if; - end loop; + end if; + end loop; + end if; GNAT.OS_Lib.Close (File); @@ -1045,7 +1072,6 @@ package body Prj.Env is end if; end; end if; - end loop; -- We don't know this file name, return an empty string @@ -1324,6 +1350,7 @@ package body Prj.Env is procedure Initialize is Global : constant String := "global_configuration_pragmas"; Local : constant String := "local_configuration_pragmas"; + begin -- Put the standard GNAT naming scheme in the Namings table @@ -1523,6 +1550,15 @@ package body Prj.Env is Write_Line ("end of List of Sources."); end Print_Sources; + --------------------------------------------- + -- Set_Mapping_File_Initial_State_To_Empty -- + --------------------------------------------- + + procedure Set_Mapping_File_Initial_State_To_Empty is + begin + Fill_Mapping_File := False; + end Set_Mapping_File_Initial_State_To_Empty; + ----------------------- -- Spec_Path_Name_Of -- ----------------------- diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index 36687b46b1e..299f453c0ea 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.ads @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -43,6 +43,10 @@ package Prj.Env is -- Create a temporary mapping file. For each unit, put the mapping of -- its spec and or body to its file name and path name in this file. + procedure Set_Mapping_File_Initial_State_To_Empty; + -- When creating a mapping file, create an empty map. This case occurs + -- when run time source files are found in the project files. + procedure Create_Config_Pragmas_File (For_Project : Project_Id; Main_Project : Project_Id); @@ -58,6 +62,16 @@ package Prj.Env is -- Get the ADA_INCLUDE_PATH of a Project file. For the first call, compute -- it and cache it. + function Ada_Include_Path + (Project : Project_Id; + Recursive : Boolean) + return String; + -- Get the ADA_INCLUDE_PATH of a Project file. If Recursive it True, + -- get all the source directories of the imported and modified project + -- files (recursively). If Recursive is False, just get the path for the + -- source directories of Project. Note: the resulting String may be empty + -- if there is no source directory in the project file. + function Ada_Objects_Path (Project : Project_Id; Including_Libraries : Boolean := True) diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 9f11f6f0170..317699fc75a 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 2000-2001 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- -- @@ -26,29 +26,34 @@ -- -- ------------------------------------------------------------------------------ +with Errout; +with Hostparm; +with MLib.Tgt; +with Namet; use Namet; +with Osint; use Osint; +with Output; use Output; +with Prj.Com; use Prj.Com; +with Prj.Env; use Prj.Env; +with Prj.Util; use Prj.Util; +with Snames; use Snames; +with Stringt; use Stringt; +with Types; use Types; + with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Strings; use Ada.Strings; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; -with Errout; use Errout; + with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.OS_Lib; use GNAT.OS_Lib; -with MLib.Tgt; -with Namet; use Namet; -with Osint; use Osint; -with Output; use Output; -with Prj.Com; use Prj.Com; -with Prj.Util; use Prj.Util; -with Snames; use Snames; -with Stringt; use Stringt; -with Types; use Types; package body Prj.Nmsc is - Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator; + Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator; - Error_Report : Put_Line_Access := null; + Error_Report : Put_Line_Access := null; + Current_Project : Project_Id := No_Project; procedure Check_Ada_Naming_Scheme (Naming : Naming_Data); -- Check that the package Naming is correct. @@ -76,17 +81,20 @@ package body Prj.Nmsc is -- specific SFN pragma is needed. If the file name corresponds to no -- unit, then Unit_Name will be No_Name. - function Is_Illegal_Append (This : String) return Boolean; - -- Returns True if the string This cannot be used as - -- a Specification_Append, a Body_Append or a Separate_Append. + function Is_Illegal_Suffix + (Suffix : String; + Dot_Replacement_Is_A_Single_Dot : Boolean) + return Boolean; + -- Returns True if the string Suffix cannot be used as + -- a spec suffix, a body suffix or a separate suffix. procedure Record_Source - (File_Name : Name_Id; - Path_Name : Name_Id; - Project : Project_Id; - Data : in out Project_Data; - Location : Source_Ptr; - Current_Source : in out String_List_Id); + (File_Name : Name_Id; + Path_Name : Name_Id; + Project : Project_Id; + Data : in out Project_Data; + Location : Source_Ptr; + Current_Source : in out String_List_Id); -- Put a unit in the list of units of a project, if the file name -- corresponds to a valid unit name. @@ -107,13 +115,6 @@ package body Prj.Nmsc is -- Returns the path name of a (non project) file. -- Returns an empty string if file cannot be found. - function Path_Name_Of - (File_Name : String_Id; - Directory : String_Id) - return String; - -- Same as above except that Directory is a String_Id instead - -- of a Name_Id. - --------------- -- Ada_Check -- --------------- @@ -164,7 +165,7 @@ package body Prj.Nmsc is Check_Ada_Name (Element.Index, Unit_Name); if Unit_Name = No_Name then - Error_Msg_Name_1 := Element.Index; + Errout.Error_Msg_Name_1 := Element.Index; Error_Msg ("{ is not a valid unit name.", Element.Value.Location); @@ -255,12 +256,12 @@ package body Prj.Nmsc is -- duplicate unit name. Record_Source - (File_Name => File_Name, - Path_Name => Path_Name, - Project => Project, - Data => Data, - Location => No_Location, - Current_Source => Current_Source); + (File_Name => File_Name, + Path_Name => Path_Name, + Project => Project, + Data => Data, + Location => No_Location, + Current_Source => Current_Source); else if Current_Verbosity = High then @@ -309,13 +310,21 @@ package body Prj.Nmsc is Source_Dir : String_List_Id := Data.Source_Dirs; Element : String_Element; Path_Name : GNAT.OS_Lib.String_Access; - Found : Boolean := False; File : Name_Id; + Path : Name_Id; + + Found : Boolean := False; + Fname : String := File_Name; begin + Canonical_Case_File_Name (Fname); + Name_Len := Fname'Length; + Name_Buffer (1 .. Name_Len) := Fname; + File := Name_Find; + if Current_Verbosity = High then Write_Str (" Checking """); - Write_Str (File_Name); + Write_Str (Fname); Write_Line ("""."); end if; @@ -332,7 +341,7 @@ package body Prj.Nmsc is Path_Name := Locate_Regular_File - (File_Name, + (Fname, Get_Name_String (Element.Value)); if Path_Name /= null then @@ -340,22 +349,19 @@ package body Prj.Nmsc is Write_Line ("OK"); end if; - Name_Len := File_Name'Length; - Name_Buffer (1 .. Name_Len) := File_Name; - File := Name_Find; Name_Len := Path_Name'Length; Name_Buffer (1 .. Name_Len) := Path_Name.all; + Path := Name_Find; - -- Register the source. Report an error if the file does not - -- correspond to a source. + -- Register the source if it is an Ada compilation unit.. Record_Source - (File_Name => File, - Path_Name => Name_Find, - Project => Project, - Data => Data, - Location => Location, - Current_Source => Current_Source); + (File_Name => File, + Path_Name => Path, + Project => Project, + Data => Data, + Location => Location, + Current_Source => Current_Source); Found := True; exit; @@ -368,6 +374,14 @@ package body Prj.Nmsc is end if; end loop; + -- It is an error if a source file names in a source list or + -- in a source list file is not found. + + if not Found then + Errout.Error_Msg_Name_1 := File; + Error_Msg ("source file { cannot be found", Location); + end if; + end Get_Path_Name_And_Record_Source; --------------------------- @@ -383,8 +397,6 @@ package body Prj.Nmsc is Last : Natural; Current_Source : String_List_Id := Nil_String; - Nmb_Errors : constant Nat := Errors_Detected; - begin if Current_Verbosity = High then Write_Str ("Opening """); @@ -403,7 +415,9 @@ package body Prj.Nmsc is Prj.Util.Get_Line (File, Line, Last); -- If the line is not empty and does not start with "--", - -- then it must contains a file name. + -- then it should contain a file name. However, if the + -- file name does not exist, it may be for another language + -- and we don't fail. if Last /= 0 and then (Last = 1 or else Line (1 .. 2) /= "--") @@ -412,7 +426,6 @@ package body Prj.Nmsc is (File_Name => Line (1 .. Last), Location => Location, Current_Source => Current_Source); - exit when Nmb_Errors /= Errors_Detected; end if; end loop; @@ -433,7 +446,8 @@ package body Prj.Nmsc is begin Language_Independent_Check (Project, Report_Error); - Error_Report := Report_Error; + Error_Report := Report_Error; + Current_Project := Project; Data := Projects.Table (Project); Languages := Prj.Util.Value_Of (Name_Languages, Data.Decl.Attributes); @@ -609,7 +623,7 @@ package body Prj.Nmsc is else Name_Len := Casing_Image'Length; Name_Buffer (1 .. Name_Len) := Casing_Image; - Error_Msg_Name_1 := Name_Find; + Errout.Error_Msg_Name_1 := Name_Find; Error_Msg ("{ is not a correct Casing", Casing_String.Location); @@ -806,7 +820,7 @@ package body Prj.Nmsc is begin if Source_File_Path_Name'Length = 0 then String_To_Name_Buffer (Source_List_File.Value); - Error_Msg_Name_1 := Name_Find; + Errout.Error_Msg_Name_1 := Name_Find; Error_Msg ("file with sources { does not exist", Source_List_File.Location); @@ -989,25 +1003,31 @@ package body Prj.Nmsc is -- - start with an alphanumeric -- - start with an '_' followed by an alphanumeric - if Is_Illegal_Append (Specification_Suffix) then - Error_Msg_Name_1 := Naming.Current_Spec_Suffix; + if Is_Illegal_Suffix + (Specification_Suffix, Dot_Replacement = ".") + then + Errout.Error_Msg_Name_1 := Naming.Current_Spec_Suffix; Error_Msg ("{ is illegal for Specification_Suffix", Naming.Spec_Suffix_Loc); end if; - if Is_Illegal_Append (Implementation_Suffix) then - Error_Msg_Name_1 := Naming.Current_Impl_Suffix; + if Is_Illegal_Suffix + (Implementation_Suffix, Dot_Replacement = ".") + then + Errout.Error_Msg_Name_1 := Naming.Current_Impl_Suffix; Error_Msg - ("% is illegal for Implementation_Suffix", + ("{ is illegal for Implementation_Suffix", Naming.Impl_Suffix_Loc); end if; if Implementation_Suffix /= Separate_Suffix then - if Is_Illegal_Append (Separate_Suffix) then - Error_Msg_Name_1 := Naming.Separate_Suffix; + if Is_Illegal_Suffix + (Separate_Suffix, Dot_Replacement = ".") + then + Errout.Error_Msg_Name_1 := Naming.Separate_Suffix; Error_Msg - ("{ is illegal for Separate_Append", + ("{ is illegal for Separate_Suffix", Naming.Sep_Suffix_Loc); end if; end if; @@ -1124,11 +1144,9 @@ package body Prj.Nmsc is Add ('"'); case Msg_Name is - when 1 => Add (Error_Msg_Name_1); - - when 2 => Add (Error_Msg_Name_2); - - when 3 => Add (Error_Msg_Name_3); + when 1 => Add (Errout.Error_Msg_Name_1); + when 2 => Add (Errout.Error_Msg_Name_2); + when 3 => Add (Errout.Error_Msg_Name_3); when others => null; end case; @@ -1141,7 +1159,7 @@ package body Prj.Nmsc is end loop; - Error_Report (Error_Buffer (1 .. Error_Last)); + Error_Report (Error_Buffer (1 .. Error_Last), Current_Project); end Error_Msg; --------------------- @@ -1252,6 +1270,13 @@ package body Prj.Nmsc is First : Positive := File'First; Last : Natural := File'Last; + Standard_GNAT : Boolean := + Naming.Current_Spec_Suffix = + Default_Ada_Spec_Suffix + and then + Naming.Current_Impl_Suffix = + Default_Ada_Impl_Suffix; + begin -- Check if the end of the file name is Specification_Append @@ -1333,6 +1358,8 @@ package body Prj.Nmsc is end if; Get_Name_String (Naming.Dot_Replacement); + Standard_GNAT := + Standard_GNAT and then Name_Buffer (1 .. Name_Len) = "-"; if Name_Buffer (1 .. Name_Len) /= "." then @@ -1414,6 +1441,36 @@ package body Prj.Nmsc is (Source => Src, Mapping => Lower_Case_Map); + -- In the standard GNAT naming scheme, check for special cases: + -- children or separates of A, G, I or S, and run time sources. + + if Standard_GNAT and then Src'Length >= 3 then + declare + S1 : constant Character := Src (Src'First); + S2 : constant Character := Src (Src'First + 1); + + begin + if S1 = 'a' or else S1 = 'g' + or else S1 = 'i' or else S1 = 's' + then + -- Children or separates of packages A, G, I or S + + if (Hostparm.OpenVMS and then S2 = '$') + or else (not Hostparm.OpenVMS and then S2 = '~') + then + Src (Src'First + 1) := '.'; + + -- If it is potentially a run time source, disable + -- filling of the mapping file to avoid warnings. + + elsif S2 = '.' then + Set_Mapping_File_Initial_State_To_Empty; + end if; + + end if; + end; + end if; + if Current_Verbosity = High then Write_Str (" "); Write_Line (Src); @@ -1432,18 +1489,48 @@ package body Prj.Nmsc is end Get_Unit; ----------------------- - -- Is_Illegal_Append -- + -- Is_Illegal_Suffix -- ----------------------- - function Is_Illegal_Append (This : String) return Boolean is + function Is_Illegal_Suffix + (Suffix : String; + Dot_Replacement_Is_A_Single_Dot : Boolean) + return Boolean + is begin - return This'Length = 0 - or else Is_Alphanumeric (This (This'First)) - or else Index (This, ".") = 0 - or else (This'Length >= 2 - and then This (This'First) = '_' - and then Is_Alphanumeric (This (This'First + 1))); - end Is_Illegal_Append; + if Suffix'Length = 0 + or else Is_Alphanumeric (Suffix (Suffix'First)) + or else Index (Suffix, ".") = 0 + or else (Suffix'Length >= 2 + and then Suffix (Suffix'First) = '_' + and then Is_Alphanumeric (Suffix (Suffix'First + 1))) + then + return True; + end if; + + -- If dot replacement is a single dot, and first character of + -- suffix is also a dot + + if Dot_Replacement_Is_A_Single_Dot + and then Suffix (Suffix'First) = '.' + then + for Index in Suffix'First + 1 .. Suffix'Last loop + + -- If there is another dot + + if Suffix (Index) = '.' then + + -- It is illegal to have a letter following the initial dot + + return Is_Letter (Suffix (Suffix'First + 1)); + end if; + end loop; + end if; + + -- Everything is OK + + return False; + end Is_Illegal_Suffix; -------------------------------- -- Language_Independent_Check -- @@ -1496,6 +1583,8 @@ package body Prj.Nmsc is The_Path_Last := The_Path_Last - 1; end if; + Canonical_Case_File_Name (The_Path); + if Current_Verbosity = High then Write_Str (" "); Write_Line (The_Path (The_Path'First .. The_Path_Last)); @@ -1545,11 +1634,13 @@ package body Prj.Nmsc is -- Avoid . and .. declare - Path_Name : constant String := + Path_Name : String := The_Path (The_Path'First .. The_Path_Last) & Name (1 .. Last); begin + Canonical_Case_File_Name (Path_Name); + if Is_Directory (Path_Name) then -- We have found a new subdirectory, @@ -1578,6 +1669,7 @@ package body Prj.Nmsc is end if; String_To_Name_Buffer (From); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Directory := Name_Buffer (1 .. Name_Len); Directory_Id := Name_Find; @@ -1622,7 +1714,7 @@ package body Prj.Nmsc is begin if Root = No_Name then - Error_Msg_Name_1 := Base_Dir; + Errout.Error_Msg_Name_1 := Base_Dir; if Location = No_Location then Error_Msg ("{ is not a valid directory.", Data.Location); else @@ -1656,7 +1748,7 @@ package body Prj.Nmsc is begin if Path_Name = No_Name then - Error_Msg_Name_1 := Directory_Id; + Errout.Error_Msg_Name_1 := Directory_Id; if Location = No_Location then Error_Msg ("{ is not a valid directory", Data.Location); else @@ -1747,7 +1839,7 @@ package body Prj.Nmsc is Locate_Directory (Dir_Id, Data.Directory); if Data.Object_Directory = No_Name then - Error_Msg_Name_1 := Dir_Id; + Errout.Error_Msg_Name_1 := Dir_Id; Error_Msg ("the object directory { cannot be found", Data.Location); @@ -1803,7 +1895,7 @@ package body Prj.Nmsc is Locate_Directory (Dir_Id, Data.Directory); if Data.Exec_Directory = No_Name then - Error_Msg_Name_1 := Dir_Id; + Errout.Error_Msg_Name_1 := Dir_Id; Error_Msg ("the exec directory { cannot be found", Data.Location); @@ -2104,9 +2196,55 @@ package body Prj.Nmsc is -- Check Specification_Suffix - Data.Naming.Specification_Suffix := Util.Value_Of - (Name_Specification_Suffix, - Naming.Decl.Arrays); + declare + Spec_Suffixs : Array_Element_Id := + Util.Value_Of + (Name_Specification_Suffix, + Naming.Decl.Arrays); + Suffix : Array_Element_Id; + Element : Array_Element; + Suffix2 : Array_Element_Id; + + begin + -- If some suffixs have been specified, we make sure that + -- for each language for which a default suffix has been + -- specified, there is a suffix specified, either the one + -- in the project file or if there were noe, the default. + + if Spec_Suffixs /= No_Array_Element then + Suffix := Data.Naming.Specification_Suffix; + + while Suffix /= No_Array_Element loop + Element := Array_Elements.Table (Suffix); + Suffix2 := Spec_Suffixs; + + while Suffix2 /= No_Array_Element loop + exit when Array_Elements.Table (Suffix2).Index = + Element.Index; + Suffix2 := Array_Elements.Table (Suffix2).Next; + end loop; + + -- There is a registered default suffix, but no + -- suffix specified in the project file. + -- Add the default to the array. + + if Suffix2 = No_Array_Element then + Array_Elements.Increment_Last; + Array_Elements.Table (Array_Elements.Last) := + (Index => Element.Index, + Value => Element.Value, + Next => Spec_Suffixs); + Spec_Suffixs := Array_Elements.Last; + end if; + + Suffix := Element.Next; + end loop; + + -- Put the resulting array as the specification suffixs + + Data.Naming.Specification_Suffix := Spec_Suffixs; + end if; + end; declare Current : Array_Element_Id := Data.Naming.Specification_Suffix; @@ -2130,9 +2268,54 @@ package body Prj.Nmsc is -- Check Implementation_Suffix - Data.Naming.Implementation_Suffix := Util.Value_Of - (Name_Implementation_Suffix, - Naming.Decl.Arrays); + declare + Impl_Suffixs : Array_Element_Id := + Util.Value_Of + (Name_Implementation_Suffix, + Naming.Decl.Arrays); + Suffix : Array_Element_Id; + Element : Array_Element; + Suffix2 : Array_Element_Id; + begin + -- If some suffixs have been specified, we make sure that + -- for each language for which a default suffix has been + -- specified, there is a suffix specified, either the one + -- in the project file or if there were noe, the default. + + if Impl_Suffixs /= No_Array_Element then + Suffix := Data.Naming.Implementation_Suffix; + + while Suffix /= No_Array_Element loop + Element := Array_Elements.Table (Suffix); + Suffix2 := Impl_Suffixs; + + while Suffix2 /= No_Array_Element loop + exit when Array_Elements.Table (Suffix2).Index = + Element.Index; + Suffix2 := Array_Elements.Table (Suffix2).Next; + end loop; + + -- There is a registered default suffix, but no + -- suffix specified in the project file. + -- Add the default to the array. + + if Suffix2 = No_Array_Element then + Array_Elements.Increment_Last; + Array_Elements.Table (Array_Elements.Last) := + (Index => Element.Index, + Value => Element.Value, + Next => Impl_Suffixs); + Impl_Suffixs := Array_Elements.Last; + end if; + + Suffix := Element.Next; + end loop; + + -- Put the resulting array as the implementation suffixs + + Data.Naming.Implementation_Suffix := Impl_Suffixs; + end if; + end; declare Current : Array_Element_Id := Data.Naming.Implementation_Suffix; @@ -2154,6 +2337,17 @@ package body Prj.Nmsc is end loop; end; + -- Get the exceptions, if any + + Data.Naming.Specification_Exceptions := + Util.Value_Of + (Name_Specification_Exceptions, + In_Arrays => Naming.Decl.Arrays); + + Data.Naming.Implementation_Exceptions := + Util.Value_Of + (Name_Implementation_Exceptions, + In_Arrays => Naming.Decl.Arrays); end if; end; @@ -2221,34 +2415,6 @@ package body Prj.Nmsc is function Path_Name_Of (File_Name : String_Id; - Directory : String_Id) - return String - is - Result : String_Access; - - begin - String_To_Name_Buffer (File_Name); - - declare - The_File_Name : constant String := Name_Buffer (1 .. Name_Len); - - begin - String_To_Name_Buffer (Directory); - Result := Locate_Regular_File - (File_Name => The_File_Name, - Path => Name_Buffer (1 .. Name_Len)); - end; - - if Result = null then - return ""; - else - Canonical_Case_File_Name (Result.all); - return Result.all; - end if; - end Path_Name_Of; - - function Path_Name_Of - (File_Name : String_Id; Directory : Name_Id) return String is @@ -2274,12 +2440,12 @@ package body Prj.Nmsc is ------------------- procedure Record_Source - (File_Name : Name_Id; - Path_Name : Name_Id; - Project : Project_Id; - Data : in out Project_Data; - Location : Source_Ptr; - Current_Source : in out String_List_Id) + (File_Name : Name_Id; + Path_Name : Name_Id; + Project : Project_Id; + Data : in out Project_Data; + Location : Source_Ptr; + Current_Source : in out String_List_Id) is Unit_Name : Name_Id; Unit_Kind : Spec_Or_Body; @@ -2367,18 +2533,18 @@ package body Prj.Nmsc is The_Location := Projects.Table (Project).Location; end if; - Error_Msg_Name_1 := Unit_Name; + Errout.Error_Msg_Name_1 := Unit_Name; Error_Msg ("duplicate source {", The_Location); - Error_Msg_Name_1 := + Errout.Error_Msg_Name_1 := Projects.Table (The_Unit_Data.File_Names (Unit_Kind).Project).Name; - Error_Msg_Name_2 := + Errout.Error_Msg_Name_2 := The_Unit_Data.File_Names (Unit_Kind).Path; Error_Msg ("\ project file {, {", The_Location); - Error_Msg_Name_1 := Projects.Table (Project).Name; - Error_Msg_Name_2 := Path_Name; + Errout.Error_Msg_Name_1 := Projects.Table (Project).Name; + Errout.Error_Msg_Name_2 := Path_Name; Error_Msg ("\ project file {, {", The_Location); end if; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 9a877af2675..e59a5c77559 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -51,8 +51,6 @@ package body Prj.Part is Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator; - Project_File_Extension : String := ".gpr"; - Project_Path : String_Access; -- The project path; initialized during package elaboration. @@ -88,13 +86,6 @@ package body Prj.Part is -- Recursive procedure: it calls itself for imported and -- modified projects. - function Path_Name_Of - (File_Name : String; - Directory : String) - return String; - -- Returns the path name of a (non project) file. - -- Returns an empty string if file cannot be found. - function Project_Path_Name_Of (Project_File_Name : String; Directory : String) @@ -166,18 +157,13 @@ package body Prj.Part is declare Path_Name : constant String := - Project_Path_Name_Of (Project_File_Name, - Directory => Current_Directory); + Project_Path_Name_Of (Project_File_Name, + Directory => Current_Directory); begin - -- Initialize the tables - - Tree_Private_Part.Project_Nodes.Set_Last (Empty_Node); - Tree_Private_Part.Projects_Htable.Reset; - Errout.Initialize; - -- And parse the main project file + -- Parse the main project file if Path_Name = "" then Fail ("project file """ & Project_File_Name & """ not found"); @@ -188,7 +174,10 @@ package body Prj.Part is Path_Name => Path_Name, Modified => False); - if Errout.Errors_Detected > 0 then + -- If there were any kind of error during the parsing, serious + -- or not, then the parsing fails. + + if Errout.Total_Errors_Detected > 0 then Project := Empty_Node; end if; @@ -242,26 +231,7 @@ package body Prj.Part is return; end if; - -- New with clause - - if Current_With_Clause = Empty_Node then - - -- First with clause of the context clause - - Current_With_Clause := Default_Project_Node - (Of_Kind => N_With_Clause); - Context_Clause := Current_With_Clause; - - else - Next_With_Clause := Default_Project_Node - (Of_Kind => N_With_Clause); - Set_Next_With_Clause_Of (Current_With_Clause, Next_With_Clause); - Current_With_Clause := Next_With_Clause; - end if; - - Set_String_Value_Of (Current_With_Clause, Strval (Token_Node)); - Set_Location_Of (Current_With_Clause, Token_Ptr); - String_To_Name_Buffer (String_Value_Of (Current_With_Clause)); + String_To_Name_Buffer (Strval (Token_Node)); declare Original_Path : constant String := @@ -285,7 +255,41 @@ package body Prj.Part is Error_Msg ("unknown project file: {", Token_Ptr); + -- If this is not imported by the main project file, + -- display the import path. + + if Project_Stack.Last > 1 then + for Index in reverse 1 .. Project_Stack.Last loop + Error_Msg_Name_1 := Project_Stack.Table (Index); + Error_Msg ("\imported by {", Token_Ptr); + end loop; + end if; + else + -- New with clause + + if Current_With_Clause = Empty_Node then + + -- First with clause of the context clause + + Current_With_Clause := Default_Project_Node + (Of_Kind => N_With_Clause); + Context_Clause := Current_With_Clause; + + else + Next_With_Clause := Default_Project_Node + (Of_Kind => N_With_Clause); + Set_Next_With_Clause_Of + (Current_With_Clause, Next_With_Clause); + Current_With_Clause := Next_With_Clause; + end if; + + Set_String_Value_Of + (Current_With_Clause, Strval (Token_Node)); + Set_Location_Of (Current_With_Clause, Token_Ptr); + String_To_Name_Buffer + (String_Value_Of (Current_With_Clause)); + -- Parse the imported project Parse_Single_Project @@ -563,6 +567,20 @@ package body Prj.Part is Error_Msg ("unknown project file: {", Token_Ptr); + -- If we are not in the main project file, display the + -- import path. + + if Project_Stack.Last > 1 then + Error_Msg_Name_1 := + Project_Stack.Table (Project_Stack.Last); + Error_Msg ("\extended by {", Token_Ptr); + + for Index in reverse 1 .. Project_Stack.Last - 1 loop + Error_Msg_Name_1 := Project_Stack.Table (Index); + Error_Msg ("\imported by {", Token_Ptr); + end loop; + end if; + else Parse_Single_Project (Project => Modified_Project, @@ -626,30 +644,6 @@ package body Prj.Part is Project_Stack.Decrement_Last; end Parse_Single_Project; - ------------------ - -- Path_Name_Of -- - ------------------ - - function Path_Name_Of - (File_Name : String; - Directory : String) - return String - is - Result : String_Access; - - begin - Result := Locate_Regular_File (File_Name => File_Name, - Path => Directory); - - if Result = null then - return ""; - - else - Canonical_Case_File_Name (Result.all); - return Result.all; - end if; - end Path_Name_Of; - ----------------------- -- Project_Name_From -- ----------------------- @@ -850,8 +844,6 @@ package body Prj.Part is end Simple_File_Name_Of; begin - Canonical_Case_File_Name (Project_File_Extension); - if Prj_Path.all = "" then Project_Path := new String'("."); diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 35dace7a1bf..1a8bd23dc88 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -36,7 +36,7 @@ with Prj.Ext; use Prj.Ext; with Prj.Nmsc; use Prj.Nmsc; with Stringt; use Stringt; -with GNAT.Case_Util; +with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.HTable; package body Prj.Proc is @@ -76,13 +76,13 @@ package body Prj.Proc is (Project : Project_Id; With_Name : Name_Id) return Project_Id; - -- Find an imported or modified project of Project whose name is With_Name. + -- Find an imported or modified project of Project whose name is With_Name function Package_From (Project : Project_Id; With_Name : Name_Id) return Package_Id; - -- Find the package of Project whose name is With_Name. + -- Find the package of Project whose name is With_Name procedure Process_Declarative_Items (Project : Project_Id; @@ -105,15 +105,13 @@ package body Prj.Proc is -- Then process the declarative items of the project. procedure Check (Project : in out Project_Id); - -- Set all projects to not checked, then call Recursive_Check for - -- the main project Project. - -- Project is set to No_Project if errors occurred. + -- Set all projects to not checked, then call Recursive_Check for the + -- main project Project. Project is set to No_Project if errors occurred. procedure Recursive_Check (Project : Project_Id); - -- If Project is marked as not checked, mark it as checked, - -- call Check_Naming_Scheme for the project, then call itself - -- for a possible modified project and all the imported projects - -- of Project. + -- If Project is marked as not checked, mark it as checked, call + -- Check_Naming_Scheme for the project, then call itself for a + -- possible modified project and all the imported projects of Project. --------- -- Add -- @@ -204,7 +202,7 @@ package body Prj.Proc is procedure Check (Project : in out Project_Id) is begin - -- Make sure that all projects are marked as not checked. + -- Make sure that all projects are marked as not checked for Index in 1 .. Projects.Last loop Projects.Table (Index).Checked := False; @@ -212,7 +210,7 @@ package body Prj.Proc is Recursive_Check (Project); - if Errout.Errors_Detected > 0 then + if Errout.Total_Errors_Detected > 0 then Project := No_Project; end if; @@ -376,11 +374,12 @@ package body Prj.Proc is The_Package : Package_Id := Pkg; The_Name : Name_Id := No_Name; The_Variable_Id : Variable_Id := No_Variable; - The_Variable : Variable; + The_Variable : Variable_Value; Term_Project : constant Project_Node_Id := Project_Node_Of (The_Current_Term); Term_Package : constant Project_Node_Id := Package_Node_Of (The_Current_Term); + Index : String_Id := No_String; begin if Term_Project /= Empty_Node and then @@ -416,58 +415,146 @@ package body Prj.Proc is The_Name := Name_Of (The_Current_Term); - if The_Package /= No_Package then + if Kind_Of (The_Current_Term) = N_Attribute_Reference then + Index := Associative_Array_Index_Of (The_Current_Term); + end if; - -- First, if there is a package, look into the package + -- If it is not an associative array attribute - if Kind_Of (The_Current_Term) = N_Variable_Reference then - The_Variable_Id := - Packages.Table (The_Package).Decl.Variables; + if Index = No_String then + + -- It is not an associative array attribute + + if The_Package /= No_Package then + + -- First, if there is a package, look into the package + + if + Kind_Of (The_Current_Term) = N_Variable_Reference + then + The_Variable_Id := + Packages.Table (The_Package).Decl.Variables; + + else + The_Variable_Id := + Packages.Table (The_Package).Decl.Attributes; + end if; + + while The_Variable_Id /= No_Variable + and then + Variable_Elements.Table (The_Variable_Id).Name /= + The_Name + loop + The_Variable_Id := + Variable_Elements.Table (The_Variable_Id).Next; + end loop; - else - The_Variable_Id := - Packages.Table (The_Package).Decl.Attributes; end if; - while The_Variable_Id /= No_Variable - and then - Variable_Elements.Table (The_Variable_Id).Name /= - The_Name - loop - The_Variable_Id := - Variable_Elements.Table (The_Variable_Id).Next; - end loop; + if The_Variable_Id = No_Variable then - end if; + -- If we have not found it, look into the project - if The_Variable_Id = No_Variable then + if + Kind_Of (The_Current_Term) = N_Variable_Reference + then + The_Variable_Id := + Projects.Table (The_Project).Decl.Variables; - -- If we have not found it, look into the project + else + The_Variable_Id := + Projects.Table (The_Project).Decl.Attributes; + end if; - if Kind_Of (The_Current_Term) = N_Variable_Reference then - The_Variable_Id := - Projects.Table (The_Project).Decl.Variables; + while The_Variable_Id /= No_Variable + and then + Variable_Elements.Table (The_Variable_Id).Name /= + The_Name + loop + The_Variable_Id := + Variable_Elements.Table (The_Variable_Id).Next; + end loop; - else - The_Variable_Id := - Projects.Table (The_Project).Decl.Attributes; end if; - while The_Variable_Id /= No_Variable - and then - Variable_Elements.Table (The_Variable_Id).Name /= - The_Name - loop - The_Variable_Id := - Variable_Elements.Table (The_Variable_Id).Next; - end loop; + pragma Assert (The_Variable_Id /= No_Variable, + "variable or attribute not found"); - end if; + The_Variable := Variable_Elements.Table + (The_Variable_Id).Value; + + else - pragma Assert (The_Variable_Id /= No_Variable, - "variable or attribute not found"); + -- It is an associative array attribute - The_Variable := Variable_Elements.Table (The_Variable_Id); + declare + The_Array : Array_Id := No_Array; + The_Element : Array_Element_Id := No_Array_Element; + Array_Index : Name_Id := No_Name; + begin + if The_Package /= No_Package then + The_Array := + Packages.Table (The_Package).Decl.Arrays; + + else + The_Array := + Projects.Table (The_Project).Decl.Arrays; + end if; + + while The_Array /= No_Array + and then Arrays.Table (The_Array).Name /= The_Name + loop + The_Array := Arrays.Table (The_Array).Next; + end loop; + + if The_Array /= No_Array then + The_Element := Arrays.Table (The_Array).Value; + + String_To_Name_Buffer (Index); + + if Case_Insensitive (The_Current_Term) then + To_Lower (Name_Buffer (1 .. Name_Len)); + end if; + + Array_Index := Name_Find; + + while The_Element /= No_Array_Element + and then Array_Elements.Table (The_Element).Index + /= Array_Index + loop + The_Element := + Array_Elements.Table (The_Element).Next; + end loop; + + end if; + + if The_Element /= No_Array_Element then + The_Variable := + Array_Elements.Table (The_Element).Value; + + else + if + Expression_Kind_Of (The_Current_Term) = List + then + The_Variable := + (Kind => List, + Location => No_Location, + Default => True, + Values => Nil_String); + + else + The_Variable := + (Kind => Single, + Location => No_Location, + Default => True, + Value => Empty_String); + end if; + + end if; + + end; + + end if; case Kind is @@ -480,13 +567,13 @@ package body Prj.Proc is when Single => - case The_Variable.Value.Kind is + case The_Variable.Kind is when Undefined => null; when Single => - Add (Result.Value, The_Variable.Value.Value); + Add (Result.Value, The_Variable.Value); when List => @@ -501,7 +588,7 @@ package body Prj.Proc is end case; when List => - case The_Variable.Value.Kind is + case The_Variable.Kind is when Undefined => null; @@ -523,7 +610,7 @@ package body Prj.Proc is Last := String_Elements.Last; String_Elements.Table (Last) := - (Value => The_Variable.Value.Value, + (Value => The_Variable.Value, Location => Location_Of (The_Current_Term), Next => Nil_String); @@ -531,7 +618,7 @@ package body Prj.Proc is declare The_List : String_List_Id := - The_Variable.Value.Values; + The_Variable.Values; begin while The_List /= Nil_String loop @@ -591,7 +678,8 @@ package body Prj.Proc is else Error_Report ("""" & Get_Name_String (Name) & - """ is an undefined external reference"); + """ is an undefined external reference", + Project); end if; Value := Empty_String; @@ -742,14 +830,13 @@ package body Prj.Proc is From_Project_Node => From_Project_Node, Modified_By => No_Project); - if Errout.Errors_Detected > 0 then + if Errout.Total_Errors_Detected > 0 then Project := No_Project; end if; if Project /= No_Project then Check (Project); end if; - end Process; ------------------------------- @@ -894,7 +981,8 @@ package body Prj.Proc is else Error_Report ("no value defined for " & - Get_Name_String (Error_Msg_Name_1)); + Get_Name_String (Error_Msg_Name_1), + Project); end if; else @@ -930,7 +1018,8 @@ package body Prj.Proc is Get_Name_String (Error_Msg_Name_1) & """ is illegal for typed string """ & Get_Name_String (Error_Msg_Name_2) & - """"); + """", + Project); end if; end if; end; @@ -1301,11 +1390,14 @@ package body Prj.Proc is Projects.Increment_Last; Project := Projects.Last; Processed_Projects.Set (Name, Project); + Processed_Data.Name := Name; Processed_Data.Path_Name := Path_Name_Of (From_Project_Node); Processed_Data.Location := Location_Of (From_Project_Node); Processed_Data.Directory := Directory_Of (From_Project_Node); Processed_Data.Modified_By := Modified_By; + Processed_Data.Naming := Standard_Naming_Data; + Add_Attributes (Processed_Data.Decl, Attribute_First); With_Clause := First_With_Clause_Of (From_Project_Node); diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb index 790c632c2cf..2a96cfdc4f6 100644 --- a/gcc/ada/prj-strt.adb +++ b/gcc/ada/prj-strt.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.12 $ +-- $Revision$ -- -- --- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -27,6 +27,7 @@ ------------------------------------------------------------------------------ with Errout; use Errout; +with Namet; use Namet; with Prj.Attr; use Prj.Attr; with Prj.Tree; use Prj.Tree; with Scans; use Scans; @@ -37,8 +38,6 @@ with Types; use Types; package body Prj.Strt is - Initial_Size : constant := 8; - type Name_Location is record Name : Name_Id := No_Name; Location : Source_Ptr := No_Location; @@ -73,11 +72,6 @@ package body Prj.Strt is First_Choice_Node_Id : constant Choice_Node_Id := Choice_Node_Low_Bound; - Empty_Choice : constant Choice_Node_Id := - Choice_Node_Low_Bound; - - First_Choice_Id : constant Choice_Node_Id := First_Choice_Node_Id + 1; - package Choices is new Table.Table (Table_Component_Type => Choice_String, Table_Index_Type => Choice_Node_Id, @@ -151,7 +145,7 @@ package body Prj.Strt is begin Reference := Default_Project_Node (Of_Kind => N_Attribute_Reference); Set_Location_Of (Reference, To => Token_Ptr); - Scan; -- past apostrophe + Scan; -- past apostrophe Expect (Tok_Identifier, "Identifier"); if Token = Tok_Identifier then @@ -165,15 +159,8 @@ package body Prj.Strt is end loop; if Current_Attribute = Empty_Attribute then - Error_Msg ("unknown attribute", Token_Ptr); - Reference := Empty_Node; - - elsif - Attributes.Table (Current_Attribute).Kind_2 = Associative_Array - then - Error_Msg - ("associative array attribute cannot be referenced", - Token_Ptr); + Error_Msg_Name_1 := Token_Name; + Error_Msg ("unknown attribute %", Token_Ptr); Reference := Empty_Node; else @@ -181,7 +168,30 @@ package body Prj.Strt is Set_Package_Node_Of (Reference, To => Current_Package); Set_Expression_Kind_Of (Reference, To => Attributes.Table (Current_Attribute).Kind_1); + Set_Case_Insensitive + (Reference, To => Attributes.Table (Current_Attribute).Kind_2 = + Case_Insensitive_Associative_Array); Scan; + + if Attributes.Table (Current_Attribute).Kind_2 /= Single then + Expect (Tok_Left_Paren, "("); + + if Token = Tok_Left_Paren then + Scan; + Expect (Tok_String_Literal, "literal string"); + + if Token = Tok_String_Literal then + Set_Associative_Array_Index_Of + (Reference, To => Strval (Token_Node)); + Scan; + Expect (Tok_Right_Paren, ")"); + + if Token = Tok_Right_Paren then + Scan; + end if; + end if; + end if; + end if; end if; end if; end Attribute_Reference; @@ -319,7 +329,9 @@ package body Prj.Strt is Found := True; if Choices.Table (Choice).Already_Used then - Error_Msg ("duplicate case label", Token_Ptr); + String_To_Name_Buffer (Choice_String); + Error_Msg_Name_1 := Name_Find; + Error_Msg ("duplicate case label {", Token_Ptr); else Choices.Table (Choice).Already_Used := True; end if; @@ -329,7 +341,9 @@ package body Prj.Strt is end loop; if not Found then - Error_Msg ("illegal case label", Token_Ptr); + String_To_Name_Buffer (Choice_String); + Error_Msg_Name_1 := Name_Find; + Error_Msg ("illegal case label {", Token_Ptr); end if; Scan; @@ -398,7 +412,9 @@ package body Prj.Strt is begin while Current /= Last_String loop if String_Equal (String_Value_Of (Current), String_Value) then - Error_Msg ("duplicate value in type", Token_Ptr); + String_To_Name_Buffer (String_Value); + Error_Msg_Name_1 := Name_Find; + Error_Msg ("duplicate value { in type", Token_Ptr); exit; end if; @@ -494,7 +510,8 @@ package body Prj.Strt is end loop; if The_Package = Empty_Node then - Error_Msg ("package not yet defined", + Error_Msg_Name_1 := The_Names (1).Name; + Error_Msg ("package % not yet defined", The_Names (1).Location); end if; @@ -514,7 +531,8 @@ package body Prj.Strt is if The_Project_Name_And_Node = Tree_Private_Part.No_Project_Name_And_Node then - Error_Msg ("unknown project", + Error_Msg_Name_1 := The_Names (1).Name; + Error_Msg ("unknown project %", The_Names (1).Location); else The_Project := The_Project_Name_And_Node.Node; @@ -535,7 +553,8 @@ package body Prj.Strt is end loop; if With_Clause = Empty_Node then - Error_Msg ("unknown project", + Error_Msg_Name_1 := The_Names (1).Name; + Error_Msg ("unknown project %", The_Names (1).Location); The_Project := Empty_Node; The_Package := Empty_Node; @@ -551,7 +570,9 @@ package body Prj.Strt is end loop; if The_Package = Empty_Node then - Error_Msg ("package not declared in project", + Error_Msg_Name_1 := The_Names (2).Name; + Error_Msg_Name_2 := The_Names (1).Name; + Error_Msg ("package % not declared in project %", The_Names (2).Location); First_Attribute := Attribute_First; @@ -637,7 +658,8 @@ package body Prj.Strt is end if; if The_Project = Empty_Node then - Error_Msg ("unknown package or project", + Error_Msg_Name_1 := The_Names (1).Name; + Error_Msg ("unknown package or project %", The_Names (1).Location); Look_For_Variable := False; else @@ -675,7 +697,8 @@ package body Prj.Strt is end if; if The_Project = Empty_Node then - Error_Msg ("unknown package or project", + Error_Msg_Name_1 := The_Names (1).Name; + Error_Msg ("unknown package or project %", The_Names (1).Location); Look_For_Variable := False; @@ -690,7 +713,8 @@ package body Prj.Strt is end loop; if The_Package = Empty_Node then - Error_Msg ("unknown package", + Error_Msg_Name_1 := The_Names (2).Name; + Error_Msg ("unknown package %", The_Names (2).Location); Look_For_Variable := False; @@ -732,7 +756,8 @@ package body Prj.Strt is end if; if Current_Variable = Empty_Node then - Error_Msg ("unknown variable", The_Names (Last_Name).Location); + Error_Msg_Name_1 := Variable_Name; + Error_Msg ("unknown variable %", The_Names (Last_Name).Location); end if; end if; @@ -745,6 +770,21 @@ package body Prj.Strt is (Variable, To => String_Type_Of (Current_Variable)); end if; end if; + + if Token = Tok_Left_Paren then + Error_Msg ("\variables cannot be associative arrays", Token_Ptr); + Scan; + Expect (Tok_String_Literal, "literal string"); + + if Token = Tok_String_Literal then + Scan; + Expect (Tok_Right_Paren, ")"); + + if Token = Tok_Right_Paren then + Scan; + end if; + end if; + end if; end Parse_Variable_Reference; --------------------------------- diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index 9f0df4851fd..5a9bbcbbf03 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -44,7 +44,9 @@ package body Prj.Tree is pragma Assert (Node /= Empty_Node and then - (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); + (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); return Project_Nodes.Table (Node).Value; end Associative_Array_Index_Of; @@ -57,7 +59,9 @@ package body Prj.Tree is pragma Assert (Node /= Empty_Node and then - (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); + (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); return Project_Nodes.Table (Node).Case_Insensitive; end Case_Insensitive; @@ -733,7 +737,9 @@ package body Prj.Tree is pragma Assert (Node /= Empty_Node and then - Project_Nodes.Table (Node).Kind = N_Attribute_Declaration); + (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); Project_Nodes.Table (Node).Value := To; end Set_Associative_Array_Index_Of; @@ -749,7 +755,9 @@ package body Prj.Tree is pragma Assert (Node /= Empty_Node and then - Project_Nodes.Table (Node).Kind = N_Attribute_Declaration); + (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); Project_Nodes.Table (Node).Case_Insensitive := To; end Set_Case_Insensitive; diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index 6a7ae30304d..14d281a35cc 100644 --- a/gcc/ada/prj-tree.ads +++ b/gcc/ada/prj-tree.ads @@ -53,7 +53,7 @@ package Prj.Tree is Empty_Node : constant Project_Node_Id := Project_Node_Low_Bound; -- Designates no node in table Project_Nodes - First_Node_Id : constant Project_Node_Id := Project_Node_Low_Bound; + First_Node_Id : constant Project_Node_Id := Project_Node_Low_Bound + 1; subtype Variable_Node_Id is Project_Node_Id; -- Used to designate a node whose expected kind is one of @@ -233,7 +233,7 @@ package Prj.Tree is function Associative_Array_Index_Of (Node : Project_Node_Id) return String_Id; - -- Only valid for N_Attribute_Declaration. + -- Only valid for N_Attribute_Declaration and N_Attribute_Reference. -- Returns No_String for non associative array attributes. function Next_Variable @@ -311,7 +311,7 @@ package Prj.Tree is -- Only valid for N_Case_Item nodes function Case_Insensitive (Node : Project_Node_Id) return Boolean; - -- Only valid for N_Attribute_Declaration nodes + -- Only valid for N_Attribute_Declaration and N_Attribute_Reference nodes -------------------- -- Set Procedures -- @@ -547,9 +547,9 @@ package Prj.Tree is -- See below the meaning for each Project_Node_Kind Case_Insensitive : Boolean := False; - -- Significant only for N_Attribute_Declaration - -- Indicates, for an associative array attribute, that the - -- index is case insensitive. + -- This flag is significant only for N_Attribute_Declaration and + -- N_Atribute_Reference. It indicates for an associative array + -- attribute, that the index is case insensitive. end record; @@ -705,7 +705,8 @@ package Prj.Tree is -- -- Field1: project -- -- Field2: package (if attribute of a package) -- -- Field3: not used - -- -- Value: not used + -- -- Value: associative array index + -- -- (if an associative array element) -- N_Case_Construction, -- -- Name: not used diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index e03d83884f7..f44fc9046a0 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -30,6 +30,7 @@ with Ada.Characters.Handling; use Ada.Characters.Handling; with Errout; use Errout; with GNAT.OS_Lib; use GNAT.OS_Lib; with Namet; use Namet; +with Osint; use Osint; with Prj.Attr; with Prj.Com; with Prj.Env; @@ -41,7 +42,9 @@ with Snames; use Snames; package body Prj is - The_Empty_String : String_Id; + The_Empty_String : String_Id; + + Ada_Language : constant Name_Id := Name_Ada; subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case; @@ -155,7 +158,7 @@ package body Prj is begin if not Projects.Table (Project).Seen then - Projects.Table (Project).Seen := False; + Projects.Table (Project).Seen := True; Action (Project, With_State); List := Projects.Table (Project).Imported_Projects; @@ -203,6 +206,10 @@ package body Prj is Std_Naming_Data.Current_Spec_Suffix := Default_Ada_Spec_Suffix; Std_Naming_Data.Current_Impl_Suffix := Default_Ada_Impl_Suffix; Std_Naming_Data.Separate_Suffix := Default_Ada_Impl_Suffix; + Register_Default_Naming_Scheme + (Language => Ada_Language, + Default_Spec_Suffix => Default_Ada_Spec_Suffix, + Default_Impl_Suffix => Default_Ada_Impl_Suffix); Prj.Env.Initialize; Prj.Attr.Initialize; Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project)); @@ -211,6 +218,99 @@ package body Prj is end if; end Initialize; + ------------------------------------ + -- Register_Default_Naming_Scheme -- + ------------------------------------ + + procedure Register_Default_Naming_Scheme + (Language : Name_Id; + Default_Spec_Suffix : Name_Id; + Default_Impl_Suffix : Name_Id) + is + Lang : Name_Id; + Suffix : Array_Element_Id; + Found : Boolean := False; + Element : Array_Element; + + Spec_Str : String_Id; + Impl_Str : String_Id; + + begin + -- The following code is completely uncommented ??? + + Get_Name_String (Language); + Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len)); + Lang := Name_Find; + + Get_Name_String (Default_Spec_Suffix); + Start_String; + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + Spec_Str := End_String; + + Get_Name_String (Default_Impl_Suffix); + Start_String; + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + Impl_Str := End_String; + + Suffix := Std_Naming_Data.Specification_Suffix; + Found := False; + + while Suffix /= No_Array_Element and then not Found loop + Element := Array_Elements.Table (Suffix); + + if Element.Index = Lang then + Found := True; + Element.Value.Value := Spec_Str; + Array_Elements.Table (Suffix) := Element; + + else + Suffix := Element.Next; + end if; + end loop; + + if not Found then + Element := + (Index => Lang, + Value => (Kind => Single, + Location => No_Location, + Default => False, + Value => Spec_Str), + Next => Std_Naming_Data.Specification_Suffix); + Array_Elements.Increment_Last; + Array_Elements.Table (Array_Elements.Last) := Element; + Std_Naming_Data.Specification_Suffix := Array_Elements.Last; + end if; + + Suffix := Std_Naming_Data.Implementation_Suffix; + Found := False; + + while Suffix /= No_Array_Element and then not Found loop + Element := Array_Elements.Table (Suffix); + + if Element.Index = Lang then + Found := True; + Element.Value.Value := Impl_Str; + Array_Elements.Table (Suffix) := Element; + + else + Suffix := Element.Next; + end if; + end loop; + + if not Found then + Element := + (Index => Lang, + Value => (Kind => Single, + Location => No_Location, + Default => False, + Value => Impl_Str), + Next => Std_Naming_Data.Implementation_Suffix); + Array_Elements.Increment_Last; + Array_Elements.Table (Array_Elements.Last) := Element; + Std_Naming_Data.Implementation_Suffix := Array_Elements.Last; + end if; + end Register_Default_Naming_Scheme; + ------------ -- Reset -- ------------ @@ -285,4 +385,9 @@ package body Prj is raise Constraint_Error; end Value; +begin + -- Make sure that the standard project file extension is compatible + -- with canonical case file naming. + + Canonical_Case_File_Name (Project_File_Extension); end Prj; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index d121c2dd5f2..0af1d897edd 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -40,6 +40,11 @@ with Types; use Types; package Prj is + Project_File_Extension : String := ".gpr"; + -- The standard project file name extension. + -- It is not a constant, because Canonical_Case_File_Name is called + -- on this variable in the body of Prj. + Default_Ada_Spec_Suffix : Name_Id; -- The Name_Id for the standard GNAT suffix for Ada spec source file -- name ".ads". Initialized by Prj.Initialize. @@ -48,9 +53,6 @@ package Prj is -- The Name_Id for the standard GNAT suffix for Ada body source file -- name ".adb". Initialized by Prj.Initialize. - type Put_Line_Access is access procedure (Line : String); - -- Use to customize error reporting in Prj.Proc and Prj.Nmsc. - type Verbosity is (Default, Medium, High); -- Verbosity when parsing GNAT Project Files -- Default is default (very quiet, if no errors). @@ -396,28 +398,28 @@ package Prj is Include_Path : String_Access := null; -- The cached value of ADA_INCLUDE_PATH for this project file. - -- Set by gnatmake (prj.Env.Set_Ada_Paths). + -- Set by gnatmake (Prj.Env.Set_Ada_Paths). -- Do not use this field directly outside of the compiler, use -- Prj.Env.Ada_Source_Path instead. Objects_Path : String_Access := null; -- The cached value of ADA_OBJECTS_PATH for this project file. - -- Set by gnatmake (prj.Env.Set_Ada_Paths). + -- Set by gnatmake (Prj.Env.Set_Ada_Paths). -- Do not use this field directly outside of the compiler, use - -- Prj.Env.Ada_Source_Path instead. + -- Prj.Env.Ada_Objects_Path instead. Config_File_Name : Name_Id := No_Name; -- The name of the configuration pragmas file, if any. - -- Set by gnatmage (Prj.Env.Create_Config_Pragmas_File). + -- Set by gnatmake (Prj.Env.Create_Config_Pragmas_File). Config_File_Temp : Boolean := False; -- An indication that the configuration pragmas file is -- a temporary file that must be deleted at the end. - -- Set by gnatmage (Prj.Env.Create_Config_Pragmas_File). + -- Set by gnatmake (Prj.Env.Create_Config_Pragmas_File). Config_Checked : Boolean := False; -- A flag to avoid checking repetitively the configuration pragmas file. - -- Set by gnatmage (Prj.Env.Create_Config_Pragmas_File). + -- Set by gnatmake (Prj.Env.Create_Config_Pragmas_File). Language_Independent_Checked : Boolean := False; -- A flag that indicates that the project file has been checked @@ -453,6 +455,11 @@ package Prj is Table_Name => "Prj.Projects"); -- The set of all project files. + type Put_Line_Access is access procedure + (Line : String; + Project : Project_Id); + -- Use to customize error reporting in Prj.Proc and Prj.Nmsc. + procedure Expect (The_Token : Token_Type; Token_Image : String); -- Check that the current token is The_Token. If it is not, then -- output an error message. @@ -465,6 +472,17 @@ package Prj is -- This procedure resets all the tables that are used when processing a -- project file tree. Initialize must be called before the call to Reset. + procedure Register_Default_Naming_Scheme + (Language : Name_Id; + Default_Spec_Suffix : Name_Id; + Default_Impl_Suffix : Name_Id); + -- Register the default suffixs for a given language. These extensions + -- will be ignored if the user has specified a new naming scheme in a + -- project file. + -- Otherwise, this information will be automatically added to Naming_Data + -- when a project is processed, in the lists Specification_Suffix and + -- Implementation_Suffix. + generic type State is limited private; with procedure Action diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c index 2d48db80693..66155538c8a 100644 --- a/gcc/ada/raise.c +++ b/gcc/ada/raise.c @@ -8,7 +8,7 @@ * * * $Revision$ * * - * Copyright (C) 1992-2001, 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- * @@ -38,6 +38,9 @@ #include "tconfig.h" #include "tsystem.h" #include <sys/stat.h> +typedef char bool; +# define true 1 +# define false 0 #else #include "config.h" #include "system.h" @@ -85,8 +88,12 @@ __gnat_unhandled_terminate () #endif } -/* Below is the eh personality routine for Ada to be called when the GCC - mechanism is used. +/* Below is the code related to the integration of the GCC mechanism for + exception handling. */ + +#include "unwind.h" + +/* Exception Handling personality routine for Ada. ??? It is currently inspired from the one for C++, needs cleanups and additional comments. It also contains a big bunch of debugging code that @@ -97,7 +104,6 @@ __gnat_unhandled_terminate () /* ??? Does it make any sense to leave this for the compiler ? */ #include "dwarf2.h" -#include "unwind.h" #include "unwind-dw2-fde.h" #include "unwind-pe.h" @@ -118,11 +124,11 @@ struct lsda_header_info typedef struct lsda_header_info lsda_header_info; -typedef enum {false = 0, true = 1} bool; - static const unsigned char * -parse_lsda_header (_Unwind_Context *context, const unsigned char *p, - lsda_header_info *info) +parse_lsda_header (context, p, info) + _Unwind_Context *context; + const unsigned char *p; + lsda_header_info *info; { _Unwind_Ptr tmp; unsigned char lpstart_encoding; @@ -135,7 +141,7 @@ parse_lsda_header (_Unwind_Context *context, const unsigned char *p, p = read_encoded_value (context, lpstart_encoding, p, &info->LPStart); else info->LPStart = info->Start; - + /* Find @TType, the base of the handler and exception spec type data. */ info->ttype_encoding = *p++; if (info->ttype_encoding != DW_EH_PE_omit) @@ -155,9 +161,11 @@ parse_lsda_header (_Unwind_Context *context, const unsigned char *p, return p; } - static const _Unwind_Ptr -get_ttype_entry (_Unwind_Context *context, lsda_header_info *info, long i) +get_ttype_entry (context, info, i) + _Unwind_Context *context; + lsda_header_info *info; + long i; { _Unwind_Ptr ptr; @@ -171,11 +179,10 @@ get_ttype_entry (_Unwind_Context *context, lsda_header_info *info, long i) library (a-except.adb). The layouts should exactly match, and the "common" header is mandated by the exception handling ABI. */ -struct _GNAT_Exception { +struct _GNAT_Exception +{ struct _Unwind_Exception common; - _Unwind_Ptr id; - char handled_by_others; char has_cleanup; char select_cleanups; @@ -216,20 +223,20 @@ static int db_specs = 0; #define END_DB(what) } \ } while (0); -/* The "action" stuff below if also there for debugging purposes only. */ +/* The "action" stuff below is also there for debugging purposes only. */ -typedef struct { +typedef struct +{ _Unwind_Action action; char * description; -} action_description_t; - -action_description_t action_descriptions [] = { - { _UA_SEARCH_PHASE, "SEARCH_PHASE" }, - { _UA_CLEANUP_PHASE, "CLEANUP_PHASE" }, - { _UA_HANDLER_FRAME, "HANDLER_FRAME" }, - { _UA_FORCE_UNWIND, "FORCE_UNWIND" }, - { -1, (char *)0 } -}; +} action_description_t; + +static action_description_t action_descriptions[] + = {{ _UA_SEARCH_PHASE, "SEARCH_PHASE" }, + { _UA_CLEANUP_PHASE, "CLEANUP_PHASE" }, + { _UA_HANDLER_FRAME, "HANDLER_FRAME" }, + { _UA_FORCE_UNWIND, "FORCE_UNWIND" }, + { -1, 0}}; static void decode_actions (actions) @@ -237,36 +244,30 @@ decode_actions (actions) { int i; - action_description_t * a = action_descriptions; + action_description_t *a = action_descriptions; printf ("\n"); - while (a->description != (char *)0) - { - if (actions & a->action) - { - printf ("%s ", a->description); - } - - a ++; - } + for (; a->description != 0; a++) + if (actions & a->action) + printf ("%s ", a->description); printf (" : "); } -/* The following is defined from a-except.adb. It's purpose is to enable +/* The following is defined from a-except.adb. Its purpose is to enable automatic backtraces upon exception raise, as provided through the GNAT.Traceback facilities. */ -extern void -__gnat_notify_handled_exception (void * handler, bool others, bool db_notify); +extern void __gnat_notify_handled_exception PARAMS ((void *, bool, bool)); /* Below is the eh personality routine per se. */ _Unwind_Reason_Code -__gnat_eh_personality (int version, - _Unwind_Action actions, - _Unwind_Exception_Class exception_class, - struct _Unwind_Exception *ue_header, - struct _Unwind_Context *context) +__gnat_eh_personality (version, actions, exception_class, ue_header, context) + int version; + _Unwind_Action actions; + _Unwind_Exception_Class exception_class; + struct _Unwind_Exception *ue_header; + struct _Unwind_Context *context; { enum found_handler_type { @@ -275,17 +276,14 @@ __gnat_eh_personality (int version, found_cleanup, found_handler } found_type; - lsda_header_info info; const unsigned char *language_specific_data; const unsigned char *action_record; const unsigned char *p; _Unwind_Ptr landing_pad, ip; int handler_switch_value; - bool hit_others_handler; - - struct _GNAT_Exception * gnat_exception; + struct _GNAT_Exception *gnat_exception; if (version != 1) return _URC_FATAL_PHASE1_ERROR; @@ -293,9 +291,9 @@ __gnat_eh_personality (int version, START_DB (DB_PHASES); decode_actions (actions); END_DB (DB_PHASES); - - if (strcmp ( ((char *)&exception_class), "GNU") != 0 - || strcmp ( ((char *)&exception_class)+4, "Ada") != 0) + + if (strcmp ((char *) &exception_class, "GNU") != 0 + || strcmp (((char *) &exception_class) + 4, "Ada") != 0) { START_DB (DB_SEARCH); printf (" Exception Class doesn't match for ip = %p\n", ip); @@ -310,17 +308,13 @@ __gnat_eh_personality (int version, START_DB (DB_PHASES); if (gnat_exception->select_cleanups) - { - printf ("(select_cleanups) :\n"); - } + printf ("(select_cleanups) :\n"); else - { - printf (" :\n"); - } + printf (" :\n"); END_DB (DB_PHASES); - language_specific_data = (const unsigned char *) - _Unwind_GetLanguageSpecificData (context); + language_specific_data + = (const unsigned char *) _Unwind_GetLanguageSpecificData (context); /* If no LSDA, then there are no handlers or cleanups. */ if (! language_specific_data) @@ -335,7 +329,7 @@ __gnat_eh_personality (int version, END_DB (DB_FOUND); return _URC_CONTINUE_UNWIND; } - + /* Parse the LSDA header. */ p = parse_lsda_header (context, language_specific_data, &info); info.ttype_base = base_of_encoded_value (info.ttype_encoding, context); @@ -347,7 +341,8 @@ __gnat_eh_personality (int version, /* Search the call-site table for the action associated with this IP. */ while (p < info.action_table) { - _Unwind_Ptr cs_start, cs_len, cs_lp, cs_action; + _Unwind_Ptr cs_start, cs_len, cs_lp; + _Unwind_Word cs_action; /* Note that all call-site encodings are "absolute" displacements. */ p = read_encoded_value (0, info.call_site_encoding, p, &cs_start); @@ -375,20 +370,19 @@ __gnat_eh_personality (int version, /* If ip is not present in the table, call terminate. This is for a destructor inside a cleanup, or a library routine the compiler was not expecting to throw. - + found_type = (actions & _UA_FORCE_UNWIND ? found_nothing : found_terminate); - + ??? Does this have a mapping in Ada semantics ? */ found_type = found_nothing; - goto do_something; found_something: found_type = found_nothing; - + if (landing_pad == 0) { /* If ip is present, and has a null landing pad, there are @@ -406,7 +400,6 @@ __gnat_eh_personality (int version, else { signed long ar_filter, ar_disp; - signed long cleanup_filter = 0; signed long handler_filter = 0; @@ -423,7 +416,7 @@ __gnat_eh_personality (int version, while (1) { - _Unwind_Ptr tmp; + _Unwind_Word tmp; p = action_record; p = read_sleb128 (p, &tmp); ar_filter = tmp; @@ -445,20 +438,20 @@ __gnat_eh_personality (int version, else if (ar_filter > 0) { _Unwind_Ptr lp_id = get_ttype_entry (context, &info, ar_filter); - + START_DB (DB_MATCH); printf ("catch_type "); - + switch (lp_id) { case GNAT_ALL_OTHERS_ID: printf ("GNAT_ALL_OTHERS_ID\n"); break; - + case GNAT_OTHERS_ID: printf ("GNAT_OTHERS_ID\n"); break; - + default: printf ("%p\n", lp_id); break; @@ -476,8 +469,9 @@ __gnat_eh_personality (int version, gnat_exception->has_cleanup = true; } - hit_others_handler = - (lp_id == GNAT_OTHERS_ID && gnat_exception->handled_by_others); + hit_others_handler + = (lp_id == GNAT_OTHERS_ID + && gnat_exception->handled_by_others); if (hit_others_handler || lp_id == gnat_exception->id) { @@ -489,10 +483,9 @@ __gnat_eh_personality (int version, } } else - { - /* Negative filter values are for C++ exception specifications. - Should not be there for Ada :/ */ - } + /* Negative filter values are for C++ exception specifications. + Should not be there for Ada :/ */ + ; if (actions & _UA_SEARCH_PHASE) { @@ -504,9 +497,7 @@ __gnat_eh_personality (int version, } if (cleanup_filter) - { - found_type = found_cleanup; - } + found_type = found_cleanup; } if (actions & _UA_CLEANUP_PHASE) @@ -517,7 +508,7 @@ __gnat_eh_personality (int version, handler_switch_value = handler_filter; break; } - + if (cleanup_filter) { found_type = found_cleanup; @@ -528,20 +519,22 @@ __gnat_eh_personality (int version, if (ar_disp == 0) break; + action_record = p + ar_disp; } } do_something: - if (found_type == found_nothing) { - START_DB (DB_FOUND); - printf (" => FOUND nothing\n"); - END_DB (DB_FOUND); + if (found_type == found_nothing) + { + START_DB (DB_FOUND); + printf (" => FOUND nothing\n"); + END_DB (DB_FOUND); - return _URC_CONTINUE_UNWIND; - } + return _URC_CONTINUE_UNWIND; + } - if (actions & _UA_SEARCH_PHASE) + if (actions & _UA_SEARCH_PHASE) { START_DB (DB_FOUND); printf (" => Computing return for SEARCH\n"); @@ -565,7 +558,7 @@ __gnat_eh_personality (int version, } install_context: - + START_DB (DB_INSTALL); printf (" => INSTALLING context for filter %d\n", handler_switch_value); @@ -579,20 +572,18 @@ __gnat_eh_personality (int version, END_DB (DB_INSTALL); } - + /* Signal that we are going to enter a handler, which will typically enable the debugger to take control and possibly output an automatic backtrace. Note that we are supposed to provide the handler's entry - point here but we don't have it. - */ - __gnat_notify_handled_exception - ((void *)landing_pad, hit_others_handler, true); - + point here but we don't have it. */ + __gnat_notify_handled_exception ((void *)landing_pad, hit_others_handler, + true); /* The GNU-Ada exception handlers know how to find the exception occurrence without having to pass it as an argument so there is no need to feed any specific register with this information. - + This is why the two following lines are commented out. */ /* _Unwind_SetGR (context, __builtin_eh_return_data_regno (0), @@ -607,4 +598,22 @@ __gnat_eh_personality (int version, } -#endif /* IN_RTS - For eh personality routine */ +#else /* IN_RTS - For eh personality routine */ + +/* The calls to the GCC runtime interface for exception raising are currently + issued from a-except.adb, which is used by both the runtime library and + the compiler. As the compiler binary is not linked against the GCC runtime + library, we need a stub for this interface in the compiler case. */ + + +_Unwind_Reason_Code +_Unwind_RaiseException (e) + struct _Unwind_Exception *e ATTRIBUTE_UNUSED; +{ + /* Since we don't link the compiler with a host libgcc, we should not be + using the GCC eh mechanism for the compiler and so expect this function + never to be called. */ + abort (); +} + +#endif diff --git a/gcc/ada/raise.h b/gcc/ada/raise.h index 8db83f4a2b8..8bf7ac08771 100644 --- a/gcc/ada/raise.h +++ b/gcc/ada/raise.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * $Revision: 1.1 $ + * $Revision$ * * * Copyright (C) 1992-2001, Free Software Foundation, Inc. * * * @@ -48,7 +48,7 @@ struct Exception_Occurrence int Max_Length; Exception_Id Id; int Msg_Length; - char Msg [0]; + char Msg[0]; }; typedef struct Exception_Occurrence *Exception_Occurrence_Access; @@ -60,12 +60,11 @@ extern void __gnat_free PARAMS ((void *)); extern void *__gnat_realloc PARAMS ((void *, __SIZE_TYPE__)); extern void __gnat_finalize PARAMS ((void)); extern void set_gnat_exit_status PARAMS ((int)); -extern void __gnat_set_globals PARAMS ((int, int, int, int, int, int, - void (*) PARAMS ((void)), - int, int)); +extern void __gnat_set_globals PARAMS ((int, int, + char, char, char, char, + char *, int, int, int)); extern void __gnat_initialize PARAMS ((void)); extern void __gnat_init_float PARAMS ((void)); extern void __gnat_install_handler PARAMS ((void)); extern int gnat_exit_status; - diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index a5bbaf4c777..4a19eacf88b 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- --- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1999-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- -- @@ -140,6 +140,14 @@ package body Repinfo is -- Returns True if Val represents a variable value, and False if it -- represents a value that is fixed at compile time. + procedure Write_Info_Line (S : String); + -- Routine to write a line to Repinfo output file. This routine is + -- passed as a special output procedure to Output.Set_Special_Output. + -- Note that Write_Info_Line is called with an EOL character at the + -- end of each line, as per the Output spec, but the internal call + -- to the appropriate routine in Osint requires that the end of line + -- sequence be stripped off. + procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False); -- Given a representation value, write it out. No_Uint values or values -- dependent on discriminants are written as two question marks. If the @@ -286,8 +294,14 @@ package body Repinfo is if Present (Ent) then E := First_Entity (Ent); while Present (E) loop - if Comes_From_Source (E) or else Debug_Flag_AA then + -- We list entities that come from source (excluding private + -- types, where we will list the info for the full view). If + -- debug flag A is set, all entities are listed + + if (Comes_From_Source (E) and then not Is_Private_Type (E)) + or else Debug_Flag_AA + then if Is_Record_Type (E) then List_Record_Info (E); @@ -295,7 +309,6 @@ package body Repinfo is List_Array_Info (E); elsif List_Representation_Info >= 2 then - if Is_Type (E) then List_Type_Info (E); @@ -311,15 +324,19 @@ package body Repinfo is end if; end if; - -- Recurse over nested package, but not if they are + -- Recurse into nested package, but not if they are -- package renamings (in particular renamings of the -- enclosing package, as for some Java bindings and -- for generic instances). - if (Ekind (E) = E_Package - and then No (Renamed_Object (E))) - or else - Ekind (E) = E_Protected_Type + if Ekind (E) = E_Package then + if No (Renamed_Object (E)) then + List_Entities (E); + end if; + + -- Recurse into bodies + + elsif Ekind (E) = E_Protected_Type or else Ekind (E) = E_Task_Type or else @@ -332,6 +349,11 @@ package body Repinfo is Ekind (E) = E_Protected_Body then List_Entities (E); + + -- Recurse into blocks + + elsif Ekind (E) = E_Block then + List_Entities (E); end if; end if; @@ -477,7 +499,7 @@ package body Repinfo is begin if U = No_Uint then - Write_Line ("??"); + Write_Str ("??"); else P (U); end if; @@ -507,21 +529,17 @@ package body Repinfo is begin Write_Eol; - if Known_Esize (Ent) then - Write_Str ("for "); - List_Name (Ent); - Write_Str ("'Size use "); - Write_Val (Esize (Ent)); - Write_Line (";"); - end if; + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); - if Known_Alignment (Ent) then - Write_Str ("for "); - List_Name (Ent); - Write_Str ("'Alignment use "); - Write_Val (Alignment (Ent)); - Write_Line (";"); - end if; + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Alignment use "); + Write_Val (Alignment (Ent)); + Write_Line (";"); end List_Object_Info; ---------------------- @@ -574,7 +592,13 @@ package body Repinfo is UI_Image (Sunit); end if; - if Unknown_Normalized_First_Bit (Comp) then + -- If the record is not packed, then we know that all + -- fields whose position is not specified have a starting + -- normalized bit position of zero + + if Unknown_Normalized_First_Bit (Comp) + and then not Is_Packed (Ent) + then Set_Normalized_First_Bit (Comp, Uint_0); end if; @@ -620,8 +644,12 @@ package body Repinfo is and then List_Representation_Info = 3 then Spaces (Max_Suni_Length - 2); + Write_Str ("bit offset"); Write_Val (Bofs, Paren => True); - Write_Str (" / 8"); + Write_Str (" size in bits = "); + Write_Val (Esiz, Paren => True); + Write_Eol; + goto Continue; elsif Known_Normalized_Position (Comp) and then List_Representation_Info = 3 @@ -630,14 +658,33 @@ package body Repinfo is Write_Val (Npos); else - Write_Str ("??"); + -- For the packed case, we don't know the bit positions + -- if we don't know the starting position! + + if Is_Packed (Ent) then + Write_Line ("?? range ? .. ??;"); + goto Continue; + + -- Otherwise we can continue + + else + Write_Str ("??"); + end if; end if; Write_Str (" range "); UI_Write (Fbit); Write_Str (" .. "); - if not Is_Dynamic_SO_Ref (Esize (Comp)) then + -- Allowing Uint_0 here is a kludge, really this should be + -- a fine Esize value but currently it means unknown, except + -- that we know after gigi has back annotated that a size of + -- zero is real, since otherwise gigi back annotates using + -- No_Uint as the value to indicate unknown). + + if (Esize (Comp) = Uint_0 or else Known_Static_Esize (Comp)) + and then Known_Static_Normalized_First_Bit (Comp) + then Lbit := Fbit + Esiz - 1; if Lbit < 10 then @@ -646,10 +693,17 @@ package body Repinfo is UI_Write (Lbit); - elsif List_Representation_Info < 3 then + -- The test for Esize (Comp) not being Uint_0 here is a kludge. + -- Officially a value of zero for Esize means unknown, but here + -- we use the fact that we know that gigi annotates Esize with + -- No_Uint, not Uint_0. Really everyone should use No_Uint??? + + elsif List_Representation_Info < 3 + or else (Esize (Comp) /= Uint_0 and then Unknown_Esize (Comp)) + then Write_Str ("??"); - else -- List_Representation >= 3 + else -- List_Representation >= 3 and Known_Esize (Comp) Write_Val (Esiz, Paren => True); @@ -679,6 +733,7 @@ package body Repinfo is end; end if; + <<Continue>> Comp := Next_Entity (Comp); end loop; @@ -695,23 +750,46 @@ package body Repinfo is begin for U in Main_Unit .. Last_Unit loop if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then - Unit_Casing := Identifier_Casing (Source_Index (U)); - Write_Eol; - Write_Str ("Representation information for unit "); - Write_Unit_Name (Unit_Name (U)); - Col := Column; - Write_Eol; - - for J in 1 .. Col - 1 loop - Write_Char ('-'); - end loop; - - Write_Eol; - List_Entities (Cunit_Entity (U)); + + -- Normal case, list to standard output + + if not List_Representation_Info_To_File then + Unit_Casing := Identifier_Casing (Source_Index (U)); + Write_Eol; + Write_Str ("Representation information for unit "); + Write_Unit_Name (Unit_Name (U)); + Col := Column; + Write_Eol; + + for J in 1 .. Col - 1 loop + Write_Char ('-'); + end loop; + + Write_Eol; + List_Entities (Cunit_Entity (U)); + + -- List representation information to file + + else + Creat_Repinfo_File_Access.all (File_Name (Source_Index (U))); + Set_Special_Output (Write_Info_Line'Access); + List_Entities (Cunit_Entity (U)); + Set_Special_Output (null); + Close_Repinfo_File_Access.all; + end if; end if; end loop; end List_Rep_Info; + --------------------- + -- Write_Info_Line -- + --------------------- + + procedure Write_Info_Line (S : String) is + begin + Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1)); + end Write_Info_Line; + -------------------- -- List_Type_Info -- -------------------- @@ -720,46 +798,45 @@ package body Repinfo is begin Write_Eol; - -- If Esize and RM_Size are the same and known, list as Size. This - -- is a common case, which we may as well list in simple form. + -- Do not list size info for unconstrained arrays, not meaningful + + if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then + null; + + else + -- If Esize and RM_Size are the same and known, list as Size. This + -- is a common case, which we may as well list in simple form. - if Esize (Ent) = RM_Size (Ent) then - if Known_Esize (Ent) then + if Esize (Ent) = RM_Size (Ent) then Write_Str ("for "); List_Name (Ent); Write_Str ("'Size use "); Write_Val (Esize (Ent)); Write_Line (";"); - end if; - -- For now, temporary case, to be removed when gigi properly back - -- annotates RM_Size, if RM_Size is not set, then list Esize as - -- Size. This avoids odd Object_Size output till we fix things??? + -- For now, temporary case, to be removed when gigi properly back + -- annotates RM_Size, if RM_Size is not set, then list Esize as + -- Size. This avoids odd Object_Size output till we fix things??? - elsif Unknown_RM_Size (Ent) then - if Known_Esize (Ent) then + elsif Unknown_RM_Size (Ent) then Write_Str ("for "); List_Name (Ent); Write_Str ("'Size use "); Write_Val (Esize (Ent)); Write_Line (";"); - end if; - -- Otherwise list size values separately if they are set + -- Otherwise list size values separately if they are set - else - if Known_Esize (Ent) then + else Write_Str ("for "); List_Name (Ent); Write_Str ("'Object_Size use "); Write_Val (Esize (Ent)); Write_Line (";"); - end if; - -- Note on following check: The RM_Size of a discrete type can - -- legitimately be set to zero, so a special check is needed. + -- Note on following check: The RM_Size of a discrete type can + -- legitimately be set to zero, so a special check is needed. - if Known_RM_Size (Ent) or else Is_Discrete_Type (Ent) then Write_Str ("for "); List_Name (Ent); Write_Str ("'Value_Size use "); @@ -768,13 +845,11 @@ package body Repinfo is end if; end if; - if Known_Alignment (Ent) then - Write_Str ("for "); - List_Name (Ent); - Write_Str ("'Alignment use "); - Write_Val (Alignment (Ent)); - Write_Line (";"); - end if; + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Alignment use "); + Write_Val (Alignment (Ent)); + Write_Line (";"); end List_Type_Info; ---------------------- @@ -1004,15 +1079,31 @@ package body Repinfo is procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is begin if Rep_Not_Constant (Val) then - if List_Representation_Info < 3 then + if List_Representation_Info < 3 or else Val = No_Uint then Write_Str ("??"); + else if Back_End_Layout then Write_Char (' '); - List_GCC_Expression (Val); + + if Paren then + Write_Char ('('); + List_GCC_Expression (Val); + Write_Char (')'); + else + List_GCC_Expression (Val); + end if; + Write_Char (' '); + else - Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val))); + if Paren then + Write_Char ('('); + Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val))); + Write_Char (')'); + else + Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val))); + end if; end if; end if; diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index a72bf71d5c7..39882ea6cf7 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -34,10 +34,10 @@ with Fname; use Fname; with Fname.UF; use Fname.UF; with Lib; use Lib; with Namet; use Namet; -with Nmake; use Nmake; with Opt; use Opt; with Stand; use Stand; with Targparm; use Targparm; +with Tbuild; use Tbuild; with Uname; use Uname; package body Restrict is @@ -125,7 +125,7 @@ package body Restrict is Error_Msg_Unit_1 := U; Error_Msg_N - ("dependence on $ not allowed,", N); + ("|dependence on $ not allowed,", N); Name_Buffer (1 .. S'Last) := S; Name_Len := S'Length; @@ -134,7 +134,7 @@ package body Restrict is Error_Msg_Sloc := Restrictions_Loc (R_Id); Error_Msg_N - ("\violates pragma Restriction (%) #", N); + ("\|violates pragma Restriction (%) #", N); return; end; end if; @@ -167,7 +167,7 @@ package body Restrict is Set_Casing (All_Lower_Case); Error_Msg_Name_1 := Name_Enter; Error_Msg_Sloc := Restrictions_Loc (R); - Error_Msg_N ("violation of restriction %#", N); + Error_Msg_N ("|violation of restriction %#", N); end; end if; end Check_Restriction; @@ -198,7 +198,8 @@ package body Restrict is Error_Msg_N ("violation of restriction %?#!", N); Insert_Action (N, - Make_Raise_Storage_Error (Loc)); + Make_Raise_Storage_Error (Loc, + Reason => SE_Restriction_Violation)); end; end if; end Check_Restriction; @@ -224,7 +225,7 @@ package body Restrict is Set_Casing (All_Lower_Case); Error_Msg_Name_1 := Name_Enter; Error_Msg_Sloc := Restriction_Parameters_Loc (R); - Error_Msg_N ("maximum value exceeded for restriction %#", N); + Error_Msg_N ("|maximum value exceeded for restriction %#", N); end; end if; end Check_Restriction; @@ -269,10 +270,10 @@ package body Restrict is if No_Run_Time then if High_Integrity_Mode_On_Target then Error_Msg_N - ("this construct not allowed in high integrity mode", Enode); + ("|this construct not allowed in high integrity mode", Enode); else Error_Msg_N - ("this construct not allowed in No_Run_Time mode", Enode); + ("|this construct not allowed in No_Run_Time mode", Enode); end if; end if; end Disallow_In_No_Run_Time_Mode; @@ -378,6 +379,7 @@ package body Restrict is begin No_Run_Time := True; Restrictions (No_Exception_Handlers) := True; + Restrictions (No_Implicit_Dynamic_Code) := True; Opt.Global_Discard_Names := True; end Set_No_Run_Time_Mode; @@ -434,7 +436,7 @@ package body Restrict is function Suppress_Restriction_Message (N : Node_Id) return Boolean is begin - -- If main unit is library unit, then we will output message + -- We only output messages for the extended main source unit if In_Extended_Main_Source_Unit (N) then return False; @@ -447,8 +449,7 @@ package body Restrict is -- Otherwise suppress message if internal file else - return - Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N))); + return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N))); end if; end Suppress_Restriction_Message; @@ -458,8 +459,7 @@ package body Restrict is function Tasking_Allowed return Boolean is begin - return - Restriction_Parameters (Max_Tasks) /= 0; + return Restriction_Parameters (Max_Tasks) /= 0; end Tasking_Allowed; end Restrict; diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 426149efaaf..47d2879dbc6 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.27 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -37,8 +37,15 @@ package Restrict is type Restriction_Id is new Rident.Restriction_Id; -- The type Restriction_Id defines the set of restriction identifiers, -- which take no parameter (i.e. they are either present or not present). - -- The actual definition is in the separate package Rident, so that it - -- can easily be accessed by the binder without dragging in lots of stuff. + -- The actual definition is in the separate package Rident, so that + -- it can easily be accessed by the binder without dragging in lots of + -- stuff. + + subtype All_Restrictions is + Restriction_Id range + Restriction_Id (Rident.All_Restrictions'First) .. + Restriction_Id (Rident.All_Restrictions'Last); + -- All restriction identifiers subtype Partition_Restrictions is Restriction_Id range @@ -69,7 +76,7 @@ package Restrict is -- be consistent at link time, and we might as well find the error -- at compile time. Clients must NOT use this array for checking to -- see if a restriction is violated, instead it is required that the - -- Check_Restrictions subprograms be used for this purpose. The only + -- Check_Restriction subprograms be used for this purpose. The only -- legitimate direct use of this array is when the code is modified -- as a result of the restriction in some way. @@ -140,6 +147,40 @@ package Restrict is -- Type used for saving and restoring compilation unit restrictions. -- See Compilation_Unit_Restrictions_[Save|Restore] subprograms. + -- The following map has True for all GNAT pragmas. It is used to + -- implement pragma Restrictions (No_Implementation_Restrictions) + -- (which is why this restriction itself is excluded from the list). + + Implementation_Restriction : Restrictions_Flags := + (Boolean_Entry_Barriers => True, + No_Calendar => True, + No_Dynamic_Interrupts => True, + No_Enumeration_Maps => True, + No_Entry_Calls_In_Elaboration_Code => True, + No_Entry_Queue => True, + No_Exception_Handlers => True, + No_Implicit_Conditionals => True, + No_Implicit_Dynamic_Code => True, + No_Implicit_Loops => True, + No_Local_Protected_Objects => True, + No_Protected_Type_Allocators => True, + No_Relative_Delay => True, + No_Requeue => True, + No_Secondary_Stack => True, + No_Select_Statements => True, + No_Standard_Storage_Pools => True, + No_Streams => True, + No_Task_Attributes => True, + No_Task_Termination => True, + No_Tasking => True, + No_Wide_Characters => True, + Static_Priorities => True, + Static_Storage_Size => True, + No_Implementation_Attributes => True, + No_Implementation_Pragmas => True, + No_Elaboration_Code => True, + others => False); + ----------------- -- Subprograms -- ----------------- diff --git a/gcc/ada/rident.ads b/gcc/ada/rident.ads index 2a9f875a59e..bdff01ae679 100644 --- a/gcc/ada/rident.ads +++ b/gcc/ada/rident.ads @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -36,7 +36,7 @@ package Rident is -- identifiers not taking a parameter that are implemented in GNAT. -- To add a new restriction identifier, add an entry with the name -- to be used in the pragma, and add appropriate calls to the - -- Check_Restriction routine. + -- Restrict.Check_Restriction routine. type Restriction_Id is ( @@ -46,7 +46,7 @@ package Rident is No_Abort_Statements, -- (RM D.7(5), H.4(3)) No_Access_Subprograms, -- (RM H.4(17)) No_Allocators, -- (RM H.4(7)) - No_Asynchronous_Control, -- (RM D.9(10)) + No_Asynchronous_Control, -- (RM D.7(10)) No_Calendar, -- GNAT No_Delay, -- (RM H.4(21)) No_Dispatch, -- (RM H.4(19)) @@ -81,6 +81,7 @@ package Rident is No_Task_Attributes, -- GNAT No_Task_Hierarchy, -- (RM D.7(3), H.4(3)) No_Task_Termination, -- GNAT + No_Tasking, -- GNAT No_Terminate_Alternatives, -- (RM D.7(6)) No_Unchecked_Access, -- (RM H.4(18)) No_Unchecked_Conversion, -- (RM H.4(16)) @@ -99,6 +100,10 @@ package Rident is Not_A_Restriction_Id); + subtype All_Restrictions is + Restriction_Id range Boolean_Entry_Barriers .. No_Elaboration_Code; + -- All restrictions except Not_A_Restriction_Id + -- The following range of Restriction identifiers is checked for -- consistency across a partition. The generated ali file is marked -- for each entry to show one of three possibilities: @@ -111,8 +116,9 @@ package Rident is Restriction_Id range Boolean_Entry_Barriers .. Static_Storage_Size; -- The following set of Restriction identifiers is not checked for - -- consistency across a partition, and the generated ali files does - -- not carry any indications with respect to such restrictions. + -- consistency across a partition. The generated ali file still + -- contains indications of the above three possibilities for the + -- purposes of listing applicable restrictions. subtype Compilation_Unit_Restrictions is Restriction_Id range Immediate_Reclamation .. No_Elaboration_Code; @@ -121,7 +127,7 @@ package Rident is -- parameter identifiers taking a parameter that are implemented in -- GNAT. To add a new restriction parameter identifier, add an entry -- with the name to be used in the pragma, and add appropriate - -- calls to Check_Restriction. + -- calls to Restrict.Check_Restriction. -- Note: the GNAT implementation currently only accomodates restriction -- parameter identifiers whose expression value is a non-negative diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 2723e4f79c6..092b7920898 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -577,13 +577,23 @@ package body Rtsfind is U_Id : constant RTU_Id := RE_Unit_Table (E); U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); - Ent : Entity_Id; Lib_Unit : Node_Id; Pkg_Ent : Entity_Id; Ename : Name_Id; Ravenscar : constant Boolean := Restricted_Profile; + -- The following flag is used to disable front-end inlining when RTE + -- is invoked. This prevents the analysis of other runtime bodies when + -- a particular spec is loaded through Rtsfind. This is both efficient, + -- and it prevents spurious visibility conflicts between use-visible + -- user entities, and entities in run-time packages. + + -- In No_Run_Time mode, subprograms marked Inlined_Always must be + -- inlined, so in the case we retain the Front_End_Inlining mode. + + Save_Front_End_Inlining : Boolean; + procedure Check_RPC; -- Reject programs that make use of distribution features not supported -- on the current target. On such targets (VMS, Vxworks, others?) we @@ -714,6 +724,7 @@ package body Rtsfind is -- Start of processing for RTE begin + -- Check violation of no run time and ravenscar mode if No_Run_Time @@ -745,6 +756,9 @@ package body Rtsfind is return Find_Local_Entity (E); end if; + Save_Front_End_Inlining := Front_End_Inlining; + Front_End_Inlining := No_Run_Time; + -- Load unit if unit not previously loaded if No (RE_Table (E)) then @@ -790,6 +804,7 @@ package body Rtsfind is if No_Run_Time and then not OK_To_Use_In_No_Run_Time_Mode (U_Id) then + Front_End_Inlining := Save_Front_End_Inlining; return Empty; else @@ -832,29 +847,8 @@ package body Rtsfind is end; end if; - -- We can now obtain the entity. Check that the no run time condition - -- is not violated. Note that we do not signal the error if we detect - -- it in a runtime unit. This can only arise if the user explicitly - -- with'ed the runtime unit (or another runtime unit that uses it - -- transitively), or if some acceptable (e.g. inlined) entity is - -- fetched from a unit, some of whose other routines or entities - -- violate the conditions. In the latter case, it does not matter, - -- since we won't be using those entities. - - Ent := RE_Table (E); - - if Is_Subprogram (Ent) - and then not Is_Inlined (Ent) - and then Sloc (Current_Error_Node) /= Standard_Location - and then not - Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Current_Error_Node))) - and then not Ravenscar - then - Disallow_In_No_Run_Time_Mode (Current_Error_Node); - end if; - - return Ent; + Front_End_Inlining := Save_Front_End_Inlining; + return RE_Table (E); end RTE; -------------------- diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index fe6c31b0dc2..90a7d5e1fea 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -158,7 +158,6 @@ package Rtsfind is System_Checked_Pools, System_Exception_Table, System_Exceptions, - System_Delay_Operations, System_Exn_Flt, System_Exn_Int, System_Exn_LFlt, diff --git a/gcc/ada/s-arit64.adb b/gcc/ada/s-arit64.adb index dff290ce85a..96b0ecfa0cd 100644 --- a/gcc/ada/s-arit64.adb +++ b/gcc/ada/s-arit64.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -63,9 +63,8 @@ package body System.Arith_64 is -- Length doubling subtraction function "*" (A, B : Uns32) return Uns64; - function "*" (A : Uns64; B : Uns32) return Uns64; pragma Inline ("*"); - -- Length doubling multiplications + -- Length doubling multiplication function "/" (A : Uns64; B : Uns32) return Uns64; pragma Inline ("/"); @@ -120,11 +119,6 @@ package body System.Arith_64 is return Uns64 (A) * Uns64 (B); end "*"; - function "*" (A : Uns64; B : Uns32) return Uns64 is - begin - return A * Uns64 (B); - end "*"; - --------- -- "+" -- --------- diff --git a/gcc/ada/s-asthan.adb b/gcc/ada/s-asthan.adb index 8247ec7a153..07a57f2330a 100644 --- a/gcc/ada/s-asthan.adb +++ b/gcc/ada/s-asthan.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.5 $ -- +-- $Revision$ -- -- --- Copyright (C) 1996-1998 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-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- -- @@ -41,6 +41,8 @@ with System.Aux_DEC; package body System.AST_Handling is + pragma Warnings (Off); -- kill warnings on unreferenced formals + ------------------------ -- Create_AST_Handler -- ------------------------ diff --git a/gcc/ada/s-atacco.adb b/gcc/ada/s-atacco.adb index 7d2842cfcba..5c77176aff7 100644 --- a/gcc/ada/s-atacco.adb +++ b/gcc/ada/s-atacco.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.4 $ -- +-- $Revision$ -- -- --- Copyright (C) 1992,1993,1994 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- -- diff --git a/gcc/ada/s-atacco.ads b/gcc/ada/s-atacco.ads index 3f44bc38f28..278982b1133 100644 --- a/gcc/ada/s-atacco.ads +++ b/gcc/ada/s-atacco.ads @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- diff --git a/gcc/ada/s-auxdec.adb b/gcc/ada/s-auxdec.adb index e16cf6acbb0..c6b61f47d99 100644 --- a/gcc/ada/s-auxdec.adb +++ b/gcc/ada/s-auxdec.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.11 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -326,6 +326,8 @@ package body System.Aux_DEC is Retry_Count : in Natural; Success_Flag : out Boolean) is + pragma Warnings (Off, Retry_Count); + begin SSL.Lock_Task.all; Old_Value := Bit; @@ -355,6 +357,8 @@ package body System.Aux_DEC is Retry_Count : in Natural; Success_Flag : out Boolean) is + pragma Warnings (Off, Retry_Count); + begin SSL.Lock_Task.all; Old_Value := Bit; @@ -408,6 +412,8 @@ package body System.Aux_DEC is Old_Value : out Integer; Success_Flag : out Boolean) is + pragma Warnings (Off, Retry_Count); + begin SSL.Lock_Task.all; Old_Value := To.Value; @@ -433,6 +439,8 @@ package body System.Aux_DEC is Old_Value : out Long_Integer; Success_Flag : out Boolean) is + pragma Warnings (Off, Retry_Count); + begin SSL.Lock_Task.all; Old_Value := To.Value; @@ -471,6 +479,8 @@ package body System.Aux_DEC is Old_Value : out Integer; Success_Flag : out Boolean) is + pragma Warnings (Off, Retry_Count); + begin SSL.Lock_Task.all; Old_Value := To.Value; @@ -496,6 +506,8 @@ package body System.Aux_DEC is Old_Value : out Long_Integer; Success_Flag : out Boolean) is + pragma Warnings (Off, Retry_Count); + begin SSL.Lock_Task.all; Old_Value := To.Value; @@ -525,6 +537,8 @@ package body System.Aux_DEC is Old_Value : out Integer; Success_Flag : out Boolean) is + pragma Warnings (Off, Retry_Count); + begin SSL.Lock_Task.all; Old_Value := To.Value; @@ -550,6 +564,8 @@ package body System.Aux_DEC is Old_Value : out Long_Integer; Success_Flag : out Boolean) is + pragma Warnings (Off, Retry_Count); + begin SSL.Lock_Task.all; Old_Value := To.Value; diff --git a/gcc/ada/s-crc32.adb b/gcc/ada/s-crc32.adb index 120914b3c00..24b6f4e9fbb 100644 --- a/gcc/ada/s-crc32.adb +++ b/gcc/ada/s-crc32.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 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- -- diff --git a/gcc/ada/s-crc32.ads b/gcc/ada/s-crc32.ads index 07ad1b552f3..520a755c270 100644 --- a/gcc/ada/s-crc32.ads +++ b/gcc/ada/s-crc32.ads @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 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- -- diff --git a/gcc/ada/s-direio.adb b/gcc/ada/s-direio.adb index 1aeb84149a4..1e89ce5f926 100644 --- a/gcc/ada/s-direio.adb +++ b/gcc/ada/s-direio.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.17 $ +-- $Revision$ -- -- --- Copyright (C) 1992-1999 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- -- @@ -60,6 +60,8 @@ package body System.Direct_IO is ------------------- function AFCB_Allocate (Control_Block : Direct_AFCB) return FCB.AFCB_Ptr is + pragma Warnings (Off, Control_Block); + begin return new Direct_AFCB; end AFCB_Allocate; @@ -71,6 +73,8 @@ package body System.Direct_IO is -- No special processing required for Direct_IO close procedure AFCB_Close (File : access Direct_AFCB) is + pragma Warnings (Off, File); + begin null; end AFCB_Close; diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb index b100aca6cf1..34e11ebc9f0 100644 --- a/gcc/ada/s-fatgen.adb +++ b/gcc/ada/s-fatgen.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -40,7 +40,7 @@ -- specialized appropriately, or better still, its generic instantiations -- should be replaced by efficient machine-specific code. -with Ada.Unchecked_Conversion; use Ada; +with Ada.Unchecked_Conversion; with System; package body System.Fat_Gen is @@ -784,11 +784,11 @@ package body System.Fat_Gen is -- This assumes that the range IEEE_Emin - 1 .. IEEE_Emax + 1 -- contains 2**N values, for some N in Natural. - function To_Float is new Unchecked_Conversion (Float_Rep, T); + function To_Float is new Ada.Unchecked_Conversion (Float_Rep, T); type Float_Access is access all T; function To_Address is - new Unchecked_Conversion (Float_Access, System.Address); + new Ada.Unchecked_Conversion (Float_Access, System.Address); XA : constant System.Address := To_Address (Float_Access (X)); diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index 21548568a33..2f02c4ce907 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.59 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -79,6 +79,7 @@ package body System.File_IO is -- This is the finalize operation that is used to do the cleanup. File_IO_Clean_Up_Object : File_IO_Clean_Up_Type; + pragma Warnings (Off, File_IO_Clean_Up_Object); -- This is the single object of the type that triggers the finalization -- call. Since it is at the library level, this happens just before the -- environment task is finalized. @@ -331,6 +332,8 @@ package body System.File_IO is -- task just before terminating execution. procedure Finalize (V : in out File_IO_Clean_Up_Type) is + pragma Warnings (Off, V); + Discard : int; Fptr1 : AFCB_Ptr; Fptr2 : AFCB_Ptr; @@ -795,11 +798,11 @@ package body System.File_IO is raise Use_Error; end if; - for J in Fullname'Range loop - if Fullname (J) = ASCII.NUL then - Full_Name_Len := J; - exit; - end if; + Full_Name_Len := 1; + while Full_Name_Len < Fullname'Last + and then Fullname (Full_Name_Len) /= ASCII.NUL + loop + Full_Name_Len := Full_Name_Len + 1; end loop; -- If Shared=None or Shared=Yes, then check for the existence diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb index 724477b2b2f..83d71da1d3b 100644 --- a/gcc/ada/s-finimp.adb +++ b/gcc/ada/s-finimp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -290,6 +290,8 @@ package body System.Finalization_Implementation is A : System.Address; B : Boolean) is + pragma Warnings (Off, L); + V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag); @@ -515,6 +517,8 @@ package body System.Finalization_Implementation is ---------------- procedure Initialize (Object : in out Limited_Record_Controller) is + pragma Warnings (Off, Object); + begin null; end Initialize; diff --git a/gcc/ada/s-gloloc.adb b/gcc/ada/s-gloloc.adb index 73d69df1185..e0c473ded10 100644 --- a/gcc/ada/s-gloloc.adb +++ b/gcc/ada/s-gloloc.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.6 $ -- +-- $Revision$ -- -- --- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 1999-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- -- @@ -43,11 +43,10 @@ package body System.Global_Locks is Dir_Separator : Character; pragma Import (C, Dir_Separator, "__gnat_dir_separator"); - type Lock_File_Entry is - record - Dir : String_Access; - File : String_Access; - end record; + type Lock_File_Entry is record + Dir : String_Access; + File : String_Access; + end record; Last_Lock : Lock_Type := Null_Lock; Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry; @@ -68,8 +67,7 @@ package body System.Global_Locks is ------------------ procedure Acquire_Lock - (Lock : in out Lock_Type) - is + (Lock : in out Lock_Type) is begin Lock_File (Lock_Table (Lock).Dir.all, diff --git a/gcc/ada/s-gloloc.ads b/gcc/ada/s-gloloc.ads index 3129044bbf9..c81a2a2ef11 100644 --- a/gcc/ada/s-gloloc.ads +++ b/gcc/ada/s-gloloc.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.3 $ +-- $Revision$ -- -- --- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 1999-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- -- diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb index 8bd065ed214..12cb69f903f 100644 --- a/gcc/ada/s-interr.adb +++ b/gcc/ada/s-interr.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $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,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). -- -- -- ------------------------------------------------------------------------------ @@ -57,13 +56,6 @@ -- There is no more than one interrupt per Server_Task and no more than -- one Server_Task per interrupt. --- Within this package, the lock L is used to protect the various status --- tables. If there is a Server_Task associated with an interrupt, we use --- the per-task lock of the Server_Task instead so that we protect the --- status between Interrupt_Manager and Server_Task. Protection among --- service requests are done using User Request to Interrupt_Manager --- rendezvous. - with Ada.Task_Identification; -- used for Task_ID type @@ -100,9 +92,6 @@ with System.Interrupt_Management.Operations; -- All_Tasks_Mask pragma Elaborate_All (System.Interrupt_Management.Operations); -with System.Error_Reporting; --- used for Shutdown - with System.Task_Primitives.Operations; -- used for Write_Lock -- Unlock @@ -137,12 +126,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 Parameters; use Tasking; - use System.Error_Reporting; use Ada.Exceptions; package PRI renames System.Task_Primitives; @@ -158,11 +150,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 @@ -186,8 +180,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); @@ -205,9 +197,9 @@ package body System.Interrupts is type Server_Task_Access is access Server_Task; - -------------------------------- - -- Local Types and Variables -- - -------------------------------- + ------------------------------- + -- Local Types and Variables -- + ------------------------------- type Entry_Assoc is record T : Task_ID; @@ -272,43 +264,13 @@ 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, hence we use PO_Level which is the highest - -- lock level for error checking. - - 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; - -- ??? spec needs comments + -- See if the Handler has been "pragma"ed using Interrupt_Handler. + -- Always consider a null handler as registered. -------------------- -- Attach_Handler -- @@ -603,9 +565,6 @@ 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 @@ -649,51 +608,6 @@ package body System.Interrupts is return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); end Is_Reserved; - -------------------- - -- 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; - --------------- -- Reference -- --------------- @@ -787,24 +701,6 @@ package body System.Interrupts is Interrupt_Manager.Unignore_Interrupt (Interrupt); end Unignore_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; - ----------------------- -- Interrupt_Manager -- ----------------------- @@ -819,6 +715,7 @@ package body System.Interrupts is Ret_Interrupt : Interrupt_ID; Old_Mask : aliased IMNG.Interrupt_Mask; Self_ID : Task_ID := POP.Self; + Old_Handler : Parameterless_Handler; --------------------- -- Local Routines -- @@ -834,9 +731,6 @@ package body System.Interrupts is -- Otherwise, we have to interrupt Server_Task for status change -- through abort interrupt. - -- Following two procedure are named Unprotected... in order to - -- indicate that Lock/Unlock_Interrupt operations are needed around. - procedure Unprotected_Exchange_Handler (Old_Handler : out Parameterless_Handler; New_Handler : in Parameterless_Handler; @@ -925,7 +819,6 @@ package body System.Interrupts is -- 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; @@ -935,11 +828,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; @@ -971,15 +862,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; @@ -1003,7 +891,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"); @@ -1070,7 +957,7 @@ package body System.Interrupts is System.Tasking.Utilities.Make_Independent; - -- Environmen task gets its own interrupt mask, saves it, + -- Environment task gets its own interrupt mask, saves it, -- and then masks all interrupts except the Keep_Unmasked set. -- During rendezvous, the Interrupt_Manager receives the old @@ -1125,247 +1012,218 @@ package body System.Interrupts is loop -- A block is needed to absorb Program_Error exception - declare - Old_Handler : Parameterless_Handler; - begin select - - accept Attach_Handler - (New_Handler : in Parameterless_Handler; - Interrupt : in Interrupt_ID; - 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 - (Old_Handler : out Parameterless_Handler; - New_Handler : in Parameterless_Handler; - 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 - (T : Task_ID; - 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; - - -- The interrupt should no longer be ingnored if - -- it was ever ignored. - - Ignored (Interrupt) := False; - User_Entry (Interrupt) := Entry_Assoc' (T => T, E => E); - - -- Indicate the attachment of Interrupt Entry in ATCB. - -- This is need so that when an Interrupt Entry task terminates - -- the binding can be cleaned. The call to unbinding must be - -- make by the task before it terminates. - - T.Interrupt_Entry := True; - - -- Invoke a corresponding Server_Task if not yet created. - -- Place Task_ID info in Server_ID array. - - if Server_ID (Interrupt) = Null_Task then - - -- When a new Server_Task is created, it should have its - -- signal mask set to the All_Tasks_Mask. - - IMOP.Set_Interrupt_Mask - (IMOP.All_Tasks_Mask'Access, Old_Mask'Access); - Access_Hold := new Server_Task (Interrupt); - IMOP.Set_Interrupt_Mask (Old_Mask'Access); - Server_ID (Interrupt) := - To_System (Access_Hold.all'Identity); - end if; - - Bind_Handler (Interrupt); - 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 ingnored if - -- it was ever ignored. - - Ignored (I) := False; - User_Entry (I) := Entry_Assoc' - (T => Null_Task, E => Null_Task_Entry); - Unbind_Handler (I); - end if; - - Unlock_Interrupt (Self_ID, I); + accept Attach_Handler + (New_Handler : in Parameterless_Handler; + Interrupt : in Interrupt_ID; + Static : in Boolean; + Restoration : in Boolean := False) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static, Restoration); + end Attach_Handler; + + or + accept Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : in Parameterless_Handler; + Interrupt : in Interrupt_ID; + Static : in Boolean) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + end Exchange_Handler; + + or + accept Detach_Handler + (Interrupt : in Interrupt_ID; + Static : in Boolean) + do + Unprotected_Detach_Handler (Interrupt, Static); + end Detach_Handler; + + or + accept Bind_Interrupt_To_Entry + (T : Task_ID; + E : Task_Entry_Index; + Interrupt : Interrupt_ID) + do + -- if there is a binding already (either a procedure or an + -- entry), raise Program_Error (propagate it to the caller). + + if User_Handler (Interrupt).H /= null + or else User_Entry (Interrupt).T /= Null_Task + then + Raise_Exception (Program_Error'Identity, + "A binding for this interrupt is already present"); end if; - end loop; - -- Indicate in ATCB that no Interrupt Entries are attached. + -- The interrupt should no longer be ingnored if + -- it was ever ignored. - T.Interrupt_Entry := False; - end Detach_Interrupt_Entries; + Ignored (Interrupt) := False; + User_Entry (Interrupt) := Entry_Assoc' (T => T, E => E); - or accept Block_Interrupt (Interrupt : Interrupt_ID) do - Lock_Interrupt (Self_ID, Interrupt); + -- Indicate the attachment of Interrupt Entry in ATCB. + -- This is need so that when an Interrupt Entry task + -- terminates the binding can be cleaned. The call to + -- unbinding must be made by the task before it terminates. - if Blocked (Interrupt) then - Unlock_Interrupt (Self_ID, Interrupt); - return; - end if; + T.Interrupt_Entry := True; - Blocked (Interrupt) := True; - Last_Unblocker (Interrupt) := Null_Task; + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_ID info in Server_ID array. - -- Mask this task for the given Interrupt so that all tasks - -- are masked for the Interrupt. + if Server_ID (Interrupt) = Null_Task then + -- When a new Server_Task is created, it should have its + -- signal mask set to the All_Tasks_Mask. - IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt)); + IMOP.Set_Interrupt_Mask + (IMOP.All_Tasks_Mask'Access, Old_Mask'Access); + Access_Hold := new Server_Task (Interrupt); + IMOP.Set_Interrupt_Mask (Old_Mask'Access); + Server_ID (Interrupt) := + To_System (Access_Hold.all'Identity); + end if; - if User_Handler (Interrupt).H /= null - or else User_Entry (Interrupt).T /= Null_Task - then - -- This is the case where the Server_Task is waiting on - -- "sigwait." Wake it up by sending an Abort_Task_Interrupt - -- so that the Server_Task waits on Cond. + Bind_Handler (Interrupt); + end Bind_Interrupt_To_Entry; + + or + accept Detach_Interrupt_Entries (T : Task_ID) do + for J in Interrupt_ID'Range loop + if not Is_Reserved (J) then + if User_Entry (J).T = T then + -- The interrupt should no longer be ingnored if + -- it was ever ignored. + + Ignored (J) := False; + User_Entry (J) := Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (J); + end if; + end if; + end loop; - POP.Abort_Task (Server_ID (Interrupt)); + -- Indicate in ATCB that no Interrupt Entries are attached. - -- Make sure corresponding Server_Task is out of its own - -- sigwait state. + T.Interrupt_Entry := False; + end Detach_Interrupt_Entries; - Ret_Interrupt := - Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access)); - pragma Assert - (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt)); - end if; + or + accept Block_Interrupt (Interrupt : Interrupt_ID) do + if Blocked (Interrupt) then + return; + end if; - Unlock_Interrupt (Self_ID, Interrupt); - end Block_Interrupt; + Blocked (Interrupt) := True; + Last_Unblocker (Interrupt) := Null_Task; - or accept Unblock_Interrupt (Interrupt : Interrupt_ID) do - Lock_Interrupt (Self_ID, Interrupt); + -- Mask this task for the given Interrupt so that all tasks + -- are masked for the Interrupt. - if not Blocked (Interrupt) then - Unlock_Interrupt (Self_ID, Interrupt); - return; - end if; + IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt)); - Blocked (Interrupt) := False; - Last_Unblocker (Interrupt) := - To_System (Unblock_Interrupt'Caller); + if User_Handler (Interrupt).H /= null + or else User_Entry (Interrupt).T /= Null_Task + then + -- This is the case where the Server_Task is waiting on + -- "sigwait." Wake it up by sending an + -- Abort_Task_Interrupt so that the Server_Task waits on + -- Cond. - if User_Handler (Interrupt).H = null - and then User_Entry (Interrupt).T = Null_Task - then - -- No handler is attached. Unmask the Interrupt so that - -- the default action can be carried out. - IMOP.Thread_Unblock_Interrupt - (IMNG.Interrupt_ID (Interrupt)); + POP.Abort_Task (Server_ID (Interrupt)); - else - -- The Server_Task must be waiting on the Cond variable - -- since it was being blocked and an Interrupt Hander or - -- an Entry was there. Wake it up and let it change - -- it place of waiting according to its new state. - POP.Wakeup (Server_ID (Interrupt), - Interrupt_Server_Blocked_Interrupt_Sleep); - end if; + -- Make sure corresponding Server_Task is out of its own + -- sigwait state. - Unlock_Interrupt (Self_ID, Interrupt); - end Unblock_Interrupt; + Ret_Interrupt := Interrupt_ID + (IMOP.Interrupt_Wait (Intwait_Mask'Access)); + pragma Assert + (Ret_Interrupt = + Interrupt_ID (IMNG.Abort_Task_Interrupt)); + end if; + end Block_Interrupt; - or accept Ignore_Interrupt (Interrupt : Interrupt_ID) do - Lock_Interrupt (Self_ID, Interrupt); + or + accept Unblock_Interrupt (Interrupt : Interrupt_ID) do + if not Blocked (Interrupt) then + return; + end if; - if Ignored (Interrupt) then - Unlock_Interrupt (Self_ID, Interrupt); - return; - end if; + Blocked (Interrupt) := False; + Last_Unblocker (Interrupt) := + To_System (Unblock_Interrupt'Caller); + + if User_Handler (Interrupt).H = null + and then User_Entry (Interrupt).T = Null_Task + then + -- No handler is attached. Unmask the Interrupt so that + -- the default action can be carried out. + IMOP.Thread_Unblock_Interrupt + (IMNG.Interrupt_ID (Interrupt)); + + else + -- The Server_Task must be waiting on the Cond variable + -- since it was being blocked and an Interrupt Hander or + -- an Entry was there. Wake it up and let it change + -- it place of waiting according to its new state. + POP.Wakeup (Server_ID (Interrupt), + Interrupt_Server_Blocked_Interrupt_Sleep); + end if; + end Unblock_Interrupt; - Ignored (Interrupt) := True; + or + accept Ignore_Interrupt (Interrupt : Interrupt_ID) do + if Ignored (Interrupt) then + return; + end if; - -- If there is a handler associated with the Interrupt, - -- detach it first. In this way we make sure that the - -- Server_Task is not on sigwait. This is legal since - -- Unignore_Interrupt is to install the default action. + Ignored (Interrupt) := True; - if User_Handler (Interrupt).H /= null then - Unprotected_Detach_Handler - (Interrupt => Interrupt, Static => True); + -- If there is a handler associated with the Interrupt, + -- detach it first. In this way we make sure that the + -- Server_Task is not on sigwait. This is legal since + -- Unignore_Interrupt is to install the default action. - elsif User_Entry (Interrupt).T /= Null_Task then - User_Entry (Interrupt) := Entry_Assoc' - (T => Null_Task, E => Null_Task_Entry); - Unbind_Handler (Interrupt); - end if; + if User_Handler (Interrupt).H /= null then + Unprotected_Detach_Handler + (Interrupt => Interrupt, Static => True); - IMOP.Install_Ignore_Action (IMNG.Interrupt_ID (Interrupt)); - Unlock_Interrupt (Self_ID, Interrupt); - end Ignore_Interrupt; + elsif User_Entry (Interrupt).T /= Null_Task then + User_Entry (Interrupt) := Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (Interrupt); + end if; - or accept Unignore_Interrupt (Interrupt : Interrupt_ID) do - Lock_Interrupt (Self_ID, Interrupt); - Ignored (Interrupt) := False; + IMOP.Install_Ignore_Action (IMNG.Interrupt_ID (Interrupt)); + end Ignore_Interrupt; - -- If there is a handler associated with the Interrupt, - -- detach it first. In this way we make sure that the - -- Server_Task is not on sigwait. This is legal since - -- Unignore_Interrupt is to install the default action. + or + accept Unignore_Interrupt (Interrupt : Interrupt_ID) do + Ignored (Interrupt) := False; - if User_Handler (Interrupt).H /= null then - Unprotected_Detach_Handler - (Interrupt => Interrupt, Static => True); + -- If there is a handler associated with the Interrupt, + -- detach it first. In this way we make sure that the + -- Server_Task is not on sigwait. This is legal since + -- Unignore_Interrupt is to install the default action. - elsif User_Entry (Interrupt).T /= Null_Task then - User_Entry (Interrupt) := Entry_Assoc' - (T => Null_Task, E => Null_Task_Entry); - Unbind_Handler (Interrupt); - end if; + if User_Handler (Interrupt).H /= null then + Unprotected_Detach_Handler + (Interrupt => Interrupt, Static => True); - IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); - Unlock_Interrupt (Self_ID, Interrupt); - end Unignore_Interrupt; + elsif User_Entry (Interrupt).T /= Null_Task then + User_Entry (Interrupt) := Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (Interrupt); + end if; + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + end Unignore_Interrupt; end select; exception - -- If there is a program error we just want to propagate it to -- the caller and do not want to stop this task. @@ -1373,15 +1231,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; ----------------- @@ -1439,6 +1292,11 @@ package body System.Interrupts is loop System.Tasking.Initialization.Defer_Abort (Self_ID); + + if Single_Lock then + POP.Lock_RTS; + end if; + POP.Write_Lock (Self_ID); if User_Handler (Interrupt).H = null @@ -1473,6 +1331,10 @@ package body System.Interrupts is POP.Unlock (Self_ID); + if Single_Lock then + POP.Unlock_RTS; + end if; + Ret_Interrupt := Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access)); @@ -1481,11 +1343,20 @@ package body System.Interrupts is -- Inform the Interrupt_Manager of wakeup from above sigwait. POP.Abort_Task (Interrupt_Manager_ID); + + if Single_Lock then + POP.Lock_RTS; + end if; + POP.Write_Lock (Self_ID); else pragma Assert (Ret_Interrupt = Interrupt); + if Single_Lock then + POP.Lock_RTS; + end if; + POP.Write_Lock (Self_ID); -- Even though we have received an Interrupt the status may @@ -1502,7 +1373,16 @@ package body System.Interrupts is POP.Unlock (Self_ID); + if Single_Lock then + POP.Unlock_RTS; + end if; + Tmp_Handler.all; + + if Single_Lock then + POP.Lock_RTS; + end if; + POP.Write_Lock (Self_ID); elsif User_Entry (Interrupt).T /= Null_Task then @@ -1511,12 +1391,21 @@ package body System.Interrupts is -- RTS calls should not be made with self being locked. + if Single_Lock then + POP.Unlock_RTS; + end if; + POP.Unlock (Self_ID); 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; + else -- This is a situation that this task wake up -- receiving an Interrupt and before it get the lock @@ -1527,17 +1416,19 @@ package body System.Interrupts is IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (Interrupt)); 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; -- Elaboration code for package System.Interrupts @@ -1548,12 +1439,6 @@ begin Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); - -- Initialize the lock L. - - Initialization.Defer_Abort (Self); - POP.Initialize_Lock (L'Access, POP.PO_Level); - Initialization.Undefer_Abort (Self); - -- During the elaboration of this package body we want RTS to -- inherit the interrupt mask from the Environment Task. diff --git a/gcc/ada/s-mastop.adb b/gcc/ada/s-mastop.adb index 16e7de2ff70..08b6844d919 100644 --- a/gcc/ada/s-mastop.adb +++ b/gcc/ada/s-mastop.adb @@ -7,9 +7,9 @@ -- B o d y -- -- (Dummy version) -- -- -- --- $Revision: 1.4 $ +-- $Revision$ -- -- --- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 1999-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- -- @@ -39,6 +39,10 @@ package body System.Machine_State_Operations is + -- Turn off warnings since many unused parameters + + pragma Warnings (Off); + use System.Exceptions; ---------------------------- @@ -122,7 +126,8 @@ package body System.Machine_State_Operations is procedure Set_Signal_Machine_State (M : Machine_State; - Context : System.Address) is + Context : System.Address) + is begin null; end Set_Signal_Machine_State; diff --git a/gcc/ada/s-mastop.ads b/gcc/ada/s-mastop.ads index ef0282bf524..2e2acbccb0c 100644 --- a/gcc/ada/s-mastop.ads +++ b/gcc/ada/s-mastop.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.4 $ +-- $Revision$ -- -- --- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 1999-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- -- diff --git a/gcc/ada/s-memory.adb b/gcc/ada/s-memory.adb index 4f11aeca738..fc5a72f49b6 100644 --- a/gcc/ada/s-memory.adb +++ b/gcc/ada/s-memory.adb @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- --- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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 -- @@ -51,6 +51,7 @@ with Ada.Exceptions; with System.Soft_Links; +with System.Parameters; package body System.Memory is @@ -89,9 +90,13 @@ package body System.Memory is Actual_Size := 1; end if; - Abort_Defer.all; - Result := c_malloc (Actual_Size); - Abort_Undefer.all; + if Parameters.No_Abort then + Result := c_malloc (Actual_Size); + else + Abort_Defer.all; + Result := c_malloc (Actual_Size); + Abort_Undefer.all; + end if; if Result = System.Null_Address then Raise_Exception (Storage_Error'Identity, "heap exhausted"); @@ -106,9 +111,13 @@ package body System.Memory is procedure Free (Ptr : System.Address) is begin - Abort_Defer.all; - c_free (Ptr); - Abort_Undefer.all; + if Parameters.No_Abort then + c_free (Ptr); + else + Abort_Defer.all; + c_free (Ptr); + Abort_Undefer.all; + end if; end Free; ------------- @@ -128,9 +137,13 @@ package body System.Memory is Raise_Exception (Storage_Error'Identity, "object too large"); end if; - Abort_Defer.all; - Result := c_realloc (Ptr, Actual_Size); - Abort_Undefer.all; + if Parameters.No_Abort then + Result := c_realloc (Ptr, Actual_Size); + else + Abort_Defer.all; + Result := c_realloc (Ptr, Actual_Size); + Abort_Undefer.all; + end if; if Result = System.Null_Address then Raise_Exception (Storage_Error'Identity, "heap exhausted"); diff --git a/gcc/ada/s-parame.ads b/gcc/ada/s-parame.ads index 92028c17398..661537e4876 100644 --- a/gcc/ada/s-parame.ads +++ b/gcc/ada/s-parame.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.41 $ +-- $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- -- @@ -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 := 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; diff --git a/gcc/ada/s-parint.adb b/gcc/ada/s-parint.adb index 4d8e80d2706..d8402d7852c 100644 --- a/gcc/ada/s-parint.adb +++ b/gcc/ada/s-parint.adb @@ -7,9 +7,9 @@ -- B o d y -- -- (Dummy body for non-distributed case) -- -- -- --- $Revision: 1.21 $ +-- $Revision$ -- -- --- Copyright (C) 1995-2000 Free Software Foundation, Inc. -- +-- Copyright (C) 1995-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- -- @@ -36,6 +36,8 @@ package body System.Partition_Interface is + pragma Warnings (Off); -- supress warnings for unreferenced formals + M : constant := 7; type String_Access is access String; diff --git a/gcc/ada/s-pooglo.adb b/gcc/ada/s-pooglo.adb index 11f265eb1e3..703daec7209 100644 --- a/gcc/ada/s-pooglo.adb +++ b/gcc/ada/s-pooglo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.9 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- @@ -51,7 +51,11 @@ package body System.Pool_Global is Storage_Size : SSE.Storage_Count; Alignment : SSE.Storage_Count) is + pragma Warnings (Off, Pool); + pragma Warnings (Off, Alignment); + Allocated : System.Address; + begin Allocated := Memory.Alloc (Memory.size_t (Storage_Size)); @@ -74,7 +78,12 @@ package body System.Pool_Global is (Pool : in out Unbounded_No_Reclaim_Pool; Address : System.Address; Storage_Size : SSE.Storage_Count; - Alignment : SSE.Storage_Count) is + Alignment : SSE.Storage_Count) + is + pragma Warnings (Off, Pool); + pragma Warnings (Off, Storage_Size); + pragma Warnings (Off, Alignment); + begin Memory.Free (Address); end Deallocate; @@ -87,6 +96,8 @@ package body System.Pool_Global is (Pool : Unbounded_No_Reclaim_Pool) return SSE.Storage_Count is + pragma Warnings (Off, Pool); + begin -- Intuitively, should return System.Memory_Size. But on Sun/Alsys, -- System.Memory_Size > System.Max_Int, which means all you can do with diff --git a/gcc/ada/s-pooloc.adb b/gcc/ada/s-pooloc.adb index 6adbf2d33ca..e0a3abb5252 100644 --- a/gcc/ada/s-pooloc.adb +++ b/gcc/ada/s-pooloc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.11 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- @@ -68,8 +68,11 @@ package body System.Pool_Local is Storage_Size : SSE.Storage_Count; Alignment : SSE.Storage_Count) is + pragma Warnings (Off, Alignment); + Allocated : constant System.Address := - Memory.Alloc (Memory.size_t (Storage_Size + Pointers_Size)); + Memory.Alloc + (Memory.size_t (Storage_Size + Pointers_Size)); begin -- The call to Alloc returns an address whose alignment is compatible @@ -101,7 +104,11 @@ package body System.Pool_Local is Storage_Size : SSE.Storage_Count; Alignment : SSE.Storage_Count) is + pragma Warnings (Off, Storage_Size); + pragma Warnings (Off, Alignment); + Allocated : constant System.Address := Address - Pointers_Size; + begin if Prev (Allocated).all = Null_Address then Pool.First := Next (Allocated).all; diff --git a/gcc/ada/s-rpc.adb b/gcc/ada/s-rpc.adb index 43f1fc0a8db..b7b4f2f30a2 100644 --- a/gcc/ada/s-rpc.adb +++ b/gcc/ada/s-rpc.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.27 $ +-- $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- -- @@ -46,6 +46,7 @@ with Ada.Exceptions; use Ada.Exceptions; package body System.RPC is GNAT : constant Boolean := True; + pragma Unreferenced (GNAT); -- This dummy entity allows the compiler to recognize that this is the -- version of this package that is supplied by GNAT, not by the user. -- This is used to cause a compile time error if an attempt is made to @@ -85,7 +86,6 @@ package body System.RPC is Raise_Exception (Program_Error'Identity, Msg); end Write; - ------------ -- Do_RPC -- ------------ diff --git a/gcc/ada/s-secsta.adb b/gcc/ada/s-secsta.adb index ac3d9bb9081..558554e1ea9 100644 --- a/gcc/ada/s-secsta.adb +++ b/gcc/ada/s-secsta.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.49 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -109,7 +109,6 @@ package body System.Secondary_Stack is function From_Addr is new Unchecked_Conversion (Address, Stack_Ptr); function To_Addr is new Unchecked_Conversion (Stack_Ptr, System.Address); - function To_Stack is new Unchecked_Conversion (Fixed_Stack_Ptr, Stack_Ptr); function To_Fixed is new Unchecked_Conversion (Stack_Ptr, Fixed_Stack_Ptr); procedure Free is new Unchecked_Deallocation (Chunk_Id, Chunk_Ptr); diff --git a/gcc/ada/s-sequio.adb b/gcc/ada/s-sequio.adb index 87c6d69ede7..72dfbcf34d7 100644 --- a/gcc/ada/s-sequio.adb +++ b/gcc/ada/s-sequio.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.7 $ -- +-- $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- -- @@ -50,6 +50,8 @@ package body System.Sequential_IO is (Control_Block : Sequential_AFCB) return FCB.AFCB_Ptr is + pragma Warnings (Off, Control_Block); + begin return new Sequential_AFCB; end AFCB_Allocate; @@ -61,6 +63,8 @@ package body System.Sequential_IO is -- No special processing required for Sequential_IO close procedure AFCB_Close (File : access Sequential_AFCB) is + pragma Warnings (Off, File); + begin null; end AFCB_Close; diff --git a/gcc/ada/s-shasto.adb b/gcc/ada/s-shasto.adb index 5d0d45378c0..bda70d1a951 100644 --- a/gcc/ada/s-shasto.adb +++ b/gcc/ada/s-shasto.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.11 $ +-- $Revision$ -- -- -- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- @@ -78,10 +78,9 @@ package body System.Shared_Storage is Shared_Var_Files_Open : Natural := 0; -- Number of shared variable access files currently open - type File_Stream_Type is new AS.Root_Stream_Type with - record - File : SIO.File_Type; - end record; + type File_Stream_Type is new AS.Root_Stream_Type with record + File : SIO.File_Type; + end record; type File_Stream_Access is access all File_Stream_Type'Class; procedure Read @@ -315,6 +314,7 @@ package body System.Shared_Storage is ---------------------- procedure Shared_Var_Close (Var : in SIO.Stream_Access) is + pragma Warnings (Off, Var); begin TSL.Unlock; end Shared_Var_Close; @@ -324,6 +324,8 @@ package body System.Shared_Storage is --------------------- procedure Shared_Var_Lock (Var : in String) is + pragma Warnings (Off, Var); + begin TSL.Lock; Initialize; @@ -409,6 +411,8 @@ package body System.Shared_Storage is ----------------------- procedure Shared_Var_Unlock (Var : in String) is + pragma Warnings (Off, Var); + begin TSL.Lock; Initialize; diff --git a/gcc/ada/s-soflin.adb b/gcc/ada/s-soflin.adb index 518c14ca7f0..61cda2dc07c 100644 --- a/gcc/ada/s-soflin.adb +++ b/gcc/ada/s-soflin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.15 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -112,8 +112,8 @@ package body System.Soft_Links is SS_Ratio_Dynamic : constant Boolean := Parameters.Sec_Stack_Ratio = Parameters.Dynamic; - begin + begin if SS_Ratio_Dynamic then SST.SS_Init (New_TSD.Sec_Stack_Addr, SST.Default_Secondary_Stack_Size); @@ -266,6 +266,8 @@ package body System.Soft_Links is --------------------------- procedure Set_Exc_Stack_Addr_NT (Self_ID : Address; Addr : Address) is + pragma Warnings (Off, Self_ID); + begin NT_TSD.Exc_Stack_Addr := Addr; end Set_Exc_Stack_Addr_NT; @@ -356,6 +358,15 @@ package body System.Soft_Links is Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X); end Update_Exception_NT; + ------------------ + -- Task_Name_NT -- + ------------------- + + function Task_Name_NT return String is + begin + return "main_task"; + end Task_Name_NT; + ------------------------- -- Package Elaboration -- ------------------------- diff --git a/gcc/ada/s-soflin.ads b/gcc/ada/s-soflin.ads index 52306076ad1..eaef71b0181 100644 --- a/gcc/ada/s-soflin.ads +++ b/gcc/ada/s-soflin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.15 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- @@ -84,6 +84,9 @@ package System.Soft_Links is type Get_Stack_Access_Call is access function return Stack_Checking.Stack_Access; + type Task_Name_Call is access + function return String; + -- Suppress checks on all these types, since we know corrresponding -- values can never be null (the soft links are always initialized). @@ -98,6 +101,7 @@ package System.Soft_Links is pragma Suppress (Access_Check, Set_EOA_Call); pragma Suppress (Access_Check, Timed_Delay_Call); pragma Suppress (Access_Check, Get_Stack_Access_Call); + pragma Suppress (Access_Check, Task_Name_Call); -- The following one is not related to tasking/no-tasking but to the -- traceback decorators for exceptions. @@ -258,6 +262,14 @@ package System.Soft_Links is Timed_Delay : Timed_Delay_Call; + -------------------------- + -- Task Name Soft-Links -- + -------------------------- + + function Task_Name_NT return String; + + Task_Name : Task_Name_Call := Task_Name_NT'Access; + ------------------------------------- -- Exception Tracebacks Soft-Links -- ------------------------------------- diff --git a/gcc/ada/s-stache.adb b/gcc/ada/s-stache.adb index 2cfb603ecc3..65e58cde331 100644 --- a/gcc/ada/s-stache.adb +++ b/gcc/ada/s-stache.adb @@ -81,6 +81,8 @@ package body System.Stack_Checking is ---------------------------- procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is + pragma Warnings (Off, Any_Stack); + begin Cache := Null_Stack; end Invalidate_Stack_Cache; diff --git a/gcc/ada/s-taasde.adb b/gcc/ada/s-taasde.adb index 1f75f741feb..70d7c26f408 100644 --- a/gcc/ada/s-taasde.adb +++ b/gcc/ada/s-taasde.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.5 $ +-- $Revision$ -- -- --- Copyright (C) 1998-2001 Ada Core Technologies, Inc. -- +-- 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,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). -- -- -- ------------------------------------------------------------------------------ @@ -67,6 +66,13 @@ with System.OS_Primitives; with Ada.Task_Identification; -- used for Task_ID type +with System.Parameters; +-- used for Single_Lock +-- Runtime_Traces + +with System.Traces.Tasking; +-- used for Send_Trace_Info + with Unchecked_Conversion; package body System.Tasking.Async_Delays is @@ -77,6 +83,10 @@ package body System.Tasking.Async_Delays is package STI renames System.Tasking.Initialization; package OSP renames System.OS_Primitives; + use Parameters; + use System.Traces; + use System.Traces.Tasking; + function To_System is new Unchecked_Conversion (Ada.Task_Identification.Task_Id, Task_ID); @@ -127,6 +137,11 @@ package body System.Tasking.Async_Delays is -- remove self from timer queue STI.Defer_Abort_Nestable (D.Self_Id); + + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Timer_Server_ID); Dpred := D.Pred; Dsucc := D.Succ; @@ -145,6 +160,11 @@ package body System.Tasking.Async_Delays is STPO.Write_Lock (D.Self_Id); STU.Exit_One_ATC_Level (D.Self_Id); STPO.Unlock (D.Self_Id); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + STI.Undefer_Abort_Nestable (D.Self_Id); end Cancel_Async_Delay; @@ -164,6 +184,9 @@ package body System.Tasking.Async_Delays is return False; else + -- The corresponding call to Undefer_Abort is performed by the + -- expanded code (see exp_ch9). + STI.Defer_Abort (STPO.Self); Time_Enqueue (STPO.Monotonic_Clock @@ -219,7 +242,10 @@ package body System.Tasking.Async_Delays is D.Self_Id := Self_Id; D.Resume_Time := T; - STI.Defer_Abort (Self_Id); + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Timer_Server_ID); -- Previously, there was code here to dynamically create @@ -256,7 +282,10 @@ package body System.Tasking.Async_Delays is end if; STPO.Unlock (Timer_Server_ID); - STI.Undefer_Abort (Self_Id); + + if Single_Lock then + STPO.Unlock_RTS; + end if; end Time_Enqueue; --------------- @@ -273,7 +302,21 @@ package body System.Tasking.Async_Delays is ------------------ task body Timer_Server is - Next_Wakeup_Time : Duration := Duration'Last; + function Get_Next_Wakeup_Time return Duration; + -- Used to initialize Next_Wakeup_Time, but also to ensure that + -- Make_Independent is called during the elaboration of this task + + -------------------------- + -- Get_Next_Wakeup_Time -- + -------------------------- + + function Get_Next_Wakeup_Time return Duration is + begin + STU.Make_Independent; + return Duration'Last; + end Get_Next_Wakeup_Time; + + Next_Wakeup_Time : Duration := Get_Next_Wakeup_Time; Timedout : Boolean; Yielded : Boolean; Now : Duration; @@ -282,18 +325,19 @@ package body System.Tasking.Async_Delays is Tsucc : Delay_Block_Access; Dequeued_Task : Task_ID; - -- Initialize_Timer_Queue returns null, but has critical side-effects - -- of initializing the timer queue. - begin Timer_Server_ID := STPO.Self; - STU.Make_Independent; -- Initialize the timer queue to empty, and make the wakeup time of the -- header node be larger than any real wakeup time we will ever use. loop STI.Defer_Abort (Timer_Server_ID); + + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Timer_Server_ID); -- The timer server needs to catch pending aborts after finalization @@ -350,6 +394,10 @@ package body System.Tasking.Async_Delays is -- the timer queue, but that is OK because we always restart the -- next iteration at the head of the queue. + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Kill, Dequeued.Self_Id); + end if; + STPO.Unlock (Timer_Server_ID); STPO.Write_Lock (Dequeued.Self_Id); Dequeued_Task := Dequeued.Self_Id; @@ -368,6 +416,11 @@ package body System.Tasking.Async_Delays is -- an actual delay in this server. STPO.Unlock (Timer_Server_ID); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + STI.Undefer_Abort (Timer_Server_ID); end loop; end Timer_Server; diff --git a/gcc/ada/s-taasde.ads b/gcc/ada/s-taasde.ads index f83c7222f38..c42e2229594 100644 --- a/gcc/ada/s-taasde.ads +++ b/gcc/ada/s-taasde.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- --- Copyright (C) 1998-1999 Ada Core Technologies, 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- -- @@ -34,8 +34,8 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the procedures to implements timeouts (delays) on --- asynchronous select statements. +-- This package contains the procedures to implements timeouts (delays) +-- for asynchronous select statements. -- Note: the compiler generates direct calls to this interface, via Rtsfind. -- Any changes to this interface may require corresponding compiler changes. diff --git a/gcc/ada/s-tadeca.adb b/gcc/ada/s-tadeca.adb index acf479c4359..a32a802ebbe 100644 --- a/gcc/ada/s-tadeca.adb +++ b/gcc/ada/s-tadeca.adb @@ -2,14 +2,13 @@ -- -- -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S . -- --- E N Q U E U E _ C A L E N D A R -- +-- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_CALENDAR -- -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- --- Copyright (C) 1998-1999 Ada Core Technologies, 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- -- @@ -40,8 +39,9 @@ with System.Task_Primitives.Operations; with System.Tasking.Initialization; function System.Tasking.Async_Delays.Enqueue_Calendar - (T : in Ada.Calendar.Time; - D : Delay_Block_Access) return Boolean + (T : Ada.Calendar.Time; + D : Delay_Block_Access) + return Boolean is use type Ada.Calendar.Time; begin diff --git a/gcc/ada/s-tadeca.ads b/gcc/ada/s-tadeca.ads index cf0a9180d17..1058acb196e 100644 --- a/gcc/ada/s-tadeca.ads +++ b/gcc/ada/s-tadeca.ads @@ -2,14 +2,13 @@ -- -- -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S . -- --- E N Q U E U E _ C A L E N D A R -- +-- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_CALENDAR -- -- -- -- S p e c -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- --- Copyright (C) 1998-1999 Ada Core Technologies, 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- -- @@ -42,5 +41,6 @@ with Ada.Calendar; function System.Tasking.Async_Delays.Enqueue_Calendar - (T : in Ada.Calendar.Time; - D : Delay_Block_Access) return Boolean; + (T : Ada.Calendar.Time; + D : Delay_Block_Access) + return Boolean; diff --git a/gcc/ada/s-tadert.adb b/gcc/ada/s-tadert.adb index a44a810adff..c84063da20b 100644 --- a/gcc/ada/s-tadert.adb +++ b/gcc/ada/s-tadert.adb @@ -2,14 +2,13 @@ -- -- -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S . -- --- E N Q U E U E _ R T -- +-- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_RT -- -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- --- Copyright (C) 1998-1999 Ada Core Technologies, 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- -- diff --git a/gcc/ada/s-tadert.ads b/gcc/ada/s-tadert.ads index 12e3e592f80..05b48e50eb6 100644 --- a/gcc/ada/s-tadert.ads +++ b/gcc/ada/s-tadert.ads @@ -2,14 +2,13 @@ -- -- -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S . -- --- E N Q U E U E _ R T -- +-- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_RT -- -- -- -- S p e c -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- --- Copyright (C) 1998-1999 Ada Core Technologies, 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- -- @@ -42,5 +41,6 @@ with Ada.Real_Time; function System.Tasking.Async_Delays.Enqueue_RT - (T : in Ada.Real_Time.Time; - D : Delay_Block_Access) return Boolean; + (T : Ada.Real_Time.Time; + D : Delay_Block_Access) + return Boolean; diff --git a/gcc/ada/s-taenca.adb b/gcc/ada/s-taenca.adb index bf9afbaedad..c44fca2763f 100644 --- a/gcc/ada/s-taenca.adb +++ b/gcc/ada/s-taenca.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.36 $ +-- $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,17 +29,10 @@ -- 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 package provides internal RTS calls implementing operations --- that apply to general entry calls, that is, calls to either --- protected or task entries. - --- These declarations are not part of the GNARL interface - with System.Task_Primitives.Operations; -- used for STPO.Write_Lock -- Unlock @@ -67,17 +60,26 @@ with System.Tasking.Queuing; with System.Tasking.Utilities; -- used for Exit_One_ATC_Level +with System.Parameters; +-- used for Single_Lock +-- Runtime_Traces + +with System.Traces; +-- used for Send_Trace_Info + package body System.Tasking.Entry_Calls is package STPO renames System.Task_Primitives.Operations; - use System.Task_Primitives; - use System.Tasking.Protected_Objects.Entries; - use System.Tasking.Protected_Objects.Operations; + use Parameters; + use Task_Primitives; + use Protected_Objects.Entries; + use Protected_Objects.Operations; + use System.Traces; -- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock -- internally. Those operations will raise Program_Error, which - -- we do are not prepared to handle inside the RTS. Instead, use + -- we are not prepared to handle inside the RTS. Instead, use -- System.Task_Primitives lock operations directly on Protection.L. ----------------------- @@ -101,23 +103,28 @@ package body System.Tasking.Entry_Calls is -- hold an ATCB lock, something which is not permitted. Since -- the server cannot be obtained reliably, it must be obtained unreliably -- and then checked again once it has been locked. + -- + -- If Single_Lock and server is a PO, release RTS_Lock. procedure Unlock_Server (Entry_Call : Entry_Call_Link); -- STPO.Unlock the server targeted by Entry_Call. The server must -- be locked before calling this. + -- + -- If Single_Lock and server is a PO, take RTS_Lock on exit. procedure Unlock_And_Update_Server (Self_ID : Task_ID; Entry_Call : Entry_Call_Link); -- Similar to Unlock_Server, but services entry calls if the -- server is a protected object. + -- + -- If Single_Lock and server is a PO, take RTS_Lock on exit. procedure Check_Pending_Actions_For_Entry_Call (Self_ID : Task_ID; Entry_Call : Entry_Call_Link); - pragma Inline (Check_Pending_Actions_For_Entry_Call); -- This procedure performs priority change of a queued call and - -- dequeuing of an entry call when an the call is cancelled. + -- dequeuing of an entry call when the call is cancelled. -- If the call is dequeued the state should be set to Cancelled. procedure Poll_Base_Priority_Change_At_Entry_Call @@ -147,6 +154,8 @@ package body System.Tasking.Entry_Calls is (Self_ID : Task_ID; Entry_Call : Entry_Call_Link) is + pragma Warnings (Off, Self_ID); + use type Ada.Exceptions.Exception_Id; procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); @@ -177,8 +186,7 @@ package body System.Tasking.Entry_Calls is procedure Check_Pending_Actions_For_Entry_Call (Self_ID : Task_ID; - Entry_Call : Entry_Call_Link) - is + Entry_Call : Entry_Call_Link) is begin pragma Assert (Self_ID = Entry_Call.Self); @@ -240,9 +248,19 @@ package body System.Tasking.Entry_Calls is -- We had very bad luck, interleaving with TWO different -- requeue operations. Go around the loop and try again. - STPO.Yield; + if Single_Lock then + STPO.Unlock_RTS; + STPO.Yield; + STPO.Lock_RTS; + else + STPO.Yield; + end if; else + if Single_Lock then + STPO.Unlock_RTS; + end if; + Lock_Entries (Test_PO, Ceiling_Violation); -- ???? @@ -250,7 +268,7 @@ package body System.Tasking.Entry_Calls is -- when cancelling a call, to allow for the possibility -- that the priority of the caller has been raised -- beyond that of the protected entry call by - -- Ada.Dynamic_Priorities.STPO.Set_Priority. + -- Ada.Dynamic_Priorities.Set_Priority. -- If the current task has a higher priority than the ceiling -- of the protected object, temporarily lower it. It will @@ -262,6 +280,10 @@ package body System.Tasking.Entry_Calls is Old_Base_Priority : System.Any_Priority; begin + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Current_Task); Old_Base_Priority := Current_Task.Common.Base_Priority; Current_Task.New_Base_Priority := Test_PO.Ceiling; @@ -269,6 +291,10 @@ package body System.Tasking.Entry_Calls is (Current_Task); STPO.Unlock (Current_Task); + if Single_Lock then + STPO.Unlock_RTS; + end if; + -- Following lock should not fail Lock_Entries (Test_PO); @@ -280,6 +306,10 @@ package body System.Tasking.Entry_Calls is exit when To_Address (Test_PO) = Entry_Call.Called_PO; Unlock_Entries (Test_PO); + + if Single_Lock then + STPO.Lock_RTS; + end if; end if; else @@ -303,24 +333,26 @@ package body System.Tasking.Entry_Calls is procedure Poll_Base_Priority_Change_At_Entry_Call (Self_ID : Task_ID; - Entry_Call : Entry_Call_Link) - is + Entry_Call : Entry_Call_Link) is begin - if Initialization.Dynamic_Priority_Support - and then Self_ID.Pending_Priority_Change - then + if Dynamic_Priority_Support and then Self_ID.Pending_Priority_Change then -- Check for ceiling violations ??? Self_ID.Pending_Priority_Change := False; if Self_ID.Common.Base_Priority = Self_ID.New_Base_Priority then - STPO.Unlock (Self_ID); - STPO.Yield; - STPO.Write_Lock (Self_ID); + if Single_Lock then + STPO.Unlock_RTS; + STPO.Yield; + STPO.Lock_RTS; + else + STPO.Unlock (Self_ID); + STPO.Yield; + STPO.Write_Lock (Self_ID); + end if; else if Self_ID.Common.Base_Priority < Self_ID.New_Base_Priority then - -- Raising priority Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; @@ -331,9 +363,16 @@ package body System.Tasking.Entry_Calls is Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; STPO.Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - STPO.Unlock (Self_ID); - STPO.Yield; - STPO.Write_Lock (Self_ID); + + if Single_Lock then + STPO.Unlock_RTS; + STPO.Yield; + STPO.Lock_RTS; + else + STPO.Unlock (Self_ID); + STPO.Yield; + STPO.Write_Lock (Self_ID); + end if; end if; end if; @@ -354,36 +393,25 @@ package body System.Tasking.Entry_Calls is -- Reset_Priority -- -------------------- - -- Reset the priority of a task completing an accept statement to - -- the value it had before the call. - procedure Reset_Priority - (Acceptor_Prev_Priority : Rendezvous_Priority; - Acceptor : Task_ID) is + (Acceptor : Task_ID; + Acceptor_Prev_Priority : Rendezvous_Priority) is begin + pragma Assert (Acceptor = STPO.Self); + + -- Since we limit this kind of "active" priority change to be done + -- by the task for itself, we don't need to lock Acceptor. + if Acceptor_Prev_Priority /= Priority_Not_Boosted then STPO.Set_Priority (Acceptor, Acceptor_Prev_Priority, Loss_Of_Inheritance => True); end if; end Reset_Priority; - -- ??? - -- Check why we don't need any kind of lock to do this. - -- Do we limit this kind of "active" priority change to be done - -- by the task for itself only? - ------------------------------ -- Try_To_Cancel_Entry_Call -- ------------------------------ - -- This is used to implement the Cancel_Task_Entry_Call and - -- Cancel_Protected_Entry_Call. - -- Try to cancel async. entry call. - -- Effect includes Abort_To_Level and Wait_For_Completion. - -- Cancelled = True iff the cancelation was successful, i.e., - -- the call was not Done before this call. - -- On return, the call is off-queue and the ATC level is reduced by one. - procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean) is Entry_Call : Entry_Call_Link; Self_ID : constant Task_ID := STPO.Self; @@ -394,13 +422,16 @@ package body System.Tasking.Entry_Calls is Entry_Call := Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; -- Experimentation has shown that abort is sometimes (but not - -- always) already deferred when Cancel_X_Entry_Call is called. + -- always) already deferred when Cancel_xxx_Entry_Call is called. -- That may indicate an error. Find out what is going on. ??? pragma Assert (Entry_Call.Mode = Asynchronous_Call); - pragma Assert (Self_ID = Self); - Initialization.Defer_Abort_Nestable (Self_ID); + + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Self_ID); Entry_Call.Cancellation_Attempted := True; @@ -408,14 +439,19 @@ package body System.Tasking.Entry_Calls is Self_ID.Pending_ATC_Level := Entry_Call.Level - 1; end if; - Entry_Calls.Wait_For_Completion (Self_ID, Entry_Call); + Entry_Calls.Wait_For_Completion (Entry_Call); STPO.Unlock (Self_ID); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + Succeeded := Entry_Call.State = Cancelled; if Succeeded then Initialization.Undefer_Abort_Nestable (Self_ID); else - -- ???? + -- ??? Initialization.Undefer_Abort_Nestable (Self_ID); @@ -456,13 +492,26 @@ package body System.Tasking.Entry_Calls is if Called_PO.Pending_Action then Called_PO.Pending_Action := False; Caller := STPO.Self; + + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Caller); Caller.New_Base_Priority := Called_PO.Old_Base_Priority; Initialization.Change_Base_Priority (Caller); STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; end if; Unlock_Entries (Called_PO); + + if Single_Lock then + STPO.Lock_RTS; + end if; end if; end Unlock_And_Update_Server; @@ -483,106 +532,101 @@ package body System.Tasking.Entry_Calls is if Called_PO.Pending_Action then Called_PO.Pending_Action := False; Caller := STPO.Self; + + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Caller); Caller.New_Base_Priority := Called_PO.Old_Base_Priority; Initialization.Change_Base_Priority (Caller); STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; end if; Unlock_Entries (Called_PO); + + if Single_Lock then + STPO.Lock_RTS; + end if; end if; end Unlock_Server; ------------------------- - -- Wait_For_Completion-- + -- Wait_For_Completion -- ------------------------- - -- Call this only when holding Self_ID locked - - -- If this is a conditional call, it should be cancelled when it - -- becomes abortable. This is checked in the loop below. + procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is + Self_Id : constant Task_ID := Entry_Call.Self; + begin + -- If this is a conditional call, it should be cancelled when it + -- becomes abortable. This is checked in the loop below. - -- We do the same thing for Asynchronous_Call. Executing the following - -- loop will clear the Pending_Action field if there is no - -- Pending_Action. We want the call made from Cancel_Task_Entry_Call - -- to check the abortion level so that we make sure that the Cancelled - -- field reflect the status of an Asynchronous_Call properly. - -- This problem came up when the triggered statement and the abortable - -- part depend on entries of the same task. When a cancellation is - -- delivered, Undefer_Abort in the call made from abortable part - -- sets the Pending_Action bit to false. However, the call is actually - -- made to cancel the Asynchronous Call so that we need to check its - -- status here again. Otherwise we may end up waiting for a cancelled - -- call forever. + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Completion); + end if; - -- ????? ......... - -- Recheck the logic of the above old comment. It may be stale. - - procedure Wait_For_Completion - (Self_ID : Task_ID; - Entry_Call : Entry_Call_Link) - is - begin - pragma Assert (Self_ID = Entry_Call.Self); - Self_ID.Common.State := Entry_Caller_Sleep; + Self_Id.Common.State := Entry_Caller_Sleep; loop - Check_Pending_Actions_For_Entry_Call (Self_ID, Entry_Call); + Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); exit when Entry_Call.State >= Done; - STPO.Sleep (Self_ID, Entry_Caller_Sleep); + STPO.Sleep (Self_Id, Entry_Caller_Sleep); end loop; - Self_ID.Common.State := Runnable; - Utilities.Exit_One_ATC_Level (Self_ID); + Self_Id.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_Id); + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Call_Complete); + end if; end Wait_For_Completion; -------------------------------------- -- Wait_For_Completion_With_Timeout -- -------------------------------------- - -- This routine will lock Self_ID. - - -- This procedure waits for the entry call to - -- be served, with a timeout. It tries to cancel the - -- call if the timeout expires before the call is served. - - -- If we wake up from the timed sleep operation here, - -- it may be for several possible reasons: - - -- 1) The entry call is done being served. - -- 2) There is an abort or priority change to be served. - -- 3) The timeout has expired (Timedout = True) - -- 4) There has been a spurious wakeup. - - -- Once the timeout has expired we may need to continue to wait if - -- the call is already being serviced. In that case, we want to go - -- back to sleep, but without any timeout. The variable Timedout is - -- used to control this. If the Timedout flag is set, we do not need - -- to STPO.Sleep with a timeout. We just sleep until we get a wakeup for - -- some status change. - - -- The original call may have become abortable after waking up. - -- We want to check Check_Pending_Actions_For_Entry_Call again - -- in any case. - procedure Wait_For_Completion_With_Timeout - (Self_ID : Task_ID; - Entry_Call : Entry_Call_Link; + (Entry_Call : Entry_Call_Link; Wakeup_Time : Duration; - Mode : Delay_Modes) + Mode : Delay_Modes; + Yielded : out Boolean) is + Self_Id : constant Task_ID := Entry_Call.Self; Timedout : Boolean := False; - Yielded : Boolean := False; use type Ada.Exceptions.Exception_Id; begin - Initialization.Defer_Abort_Nestable (Self_ID); - STPO.Write_Lock (Self_ID); + -- This procedure waits for the entry call to be served, with a timeout. + -- It tries to cancel the call if the timeout expires before the call is + -- served. + + -- If we wake up from the timed sleep operation here, it may be for + -- several possible reasons: + + -- 1) The entry call is done being served. + -- 2) There is an abort or priority change to be served. + -- 3) The timeout has expired (Timedout = True) + -- 4) There has been a spurious wakeup. + + -- Once the timeout has expired we may need to continue to wait if the + -- call is already being serviced. In that case, we want to go back to + -- sleep, but without any timeout. The variable Timedout is used to + -- control this. If the Timedout flag is set, we do not need to + -- STPO.Sleep with a timeout. We just sleep until we get a wakeup for + -- some status change. + + -- The original call may have become abortable after waking up. We want + -- to check Check_Pending_Actions_For_Entry_Call again in any case. - pragma Assert (Entry_Call.Self = Self_ID); pragma Assert (Entry_Call.Mode = Timed_Call); - Self_ID.Common.State := Entry_Caller_Sleep; + + Yielded := False; + Self_Id.Common.State := Entry_Caller_Sleep; -- Looping is necessary in case the task wakes up early from the -- timed sleep, due to a "spurious wakeup". Spurious wakeups are @@ -591,22 +635,29 @@ package body System.Tasking.Entry_Calls is -- when the condition is signaled. See the same loop in the -- ordinary Wait_For_Completion, above. + if Parameters.Runtime_Traces then + Send_Trace_Info (WT_Completion, Wakeup_Time); + end if; + loop - Check_Pending_Actions_For_Entry_Call (Self_ID, Entry_Call); + Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); exit when Entry_Call.State >= Done; - STPO.Timed_Sleep (Self_ID, Wakeup_Time, Mode, + STPO.Timed_Sleep (Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded); if Timedout then + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Timeout); + end if; -- Try to cancel the call (see Try_To_Cancel_Entry_Call for -- corresponding code in the ATC case). Entry_Call.Cancellation_Attempted := True; - if Self_ID.Pending_ATC_Level >= Entry_Call.Level then - Self_ID.Pending_ATC_Level := Entry_Call.Level - 1; + if Self_Id.Pending_ATC_Level >= Entry_Call.Level then + Self_Id.Pending_ATC_Level := Entry_Call.Level - 1; end if; -- The following loop is the same as the loop and exit code @@ -615,39 +666,13 @@ package body System.Tasking.Entry_Calls is -- has actually completed or been cancelled successfully. loop - Check_Pending_Actions_For_Entry_Call (Self_ID, Entry_Call); + Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); exit when Entry_Call.State >= Done; - STPO.Sleep (Self_ID, Entry_Caller_Sleep); + STPO.Sleep (Self_Id, Entry_Caller_Sleep); end loop; - Self_ID.Common.State := Runnable; - Utilities.Exit_One_ATC_Level (Self_ID); - - STPO.Unlock (Self_ID); - - if Entry_Call.State = Cancelled then - Initialization.Undefer_Abort_Nestable (Self_ID); - else - -- ???? - - Initialization.Undefer_Abort_Nestable (Self_ID); - - -- Ideally, abort should no longer be deferred at this - -- point, so we should be able to call Check_Exception. - -- The loop below should be considered temporary, - -- to work around the possiblility that abort may be - -- deferred more than one level deep. - - if Entry_Call.Exception_To_Raise /= - Ada.Exceptions.Null_Id then - - while Self_ID.Deferral_Level > 0 loop - Initialization.Undefer_Abort_Nestable (Self_ID); - end loop; - - Entry_Calls.Check_Exception (Self_ID, Entry_Call); - end if; - end if; + Self_Id.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_Id); return; end if; @@ -656,32 +681,29 @@ package body System.Tasking.Entry_Calls is -- This last part is the same as ordinary Wait_For_Completion, -- and is only executed if the call completed without timing out. - Self_ID.Common.State := Runnable; - Utilities.Exit_One_ATC_Level (Self_ID); - STPO.Unlock (Self_ID); - - Initialization.Undefer_Abort_Nestable (Self_ID); - - if not Yielded then - STPO.Yield; + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Call_Complete); end if; + + Self_Id.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_Id); end Wait_For_Completion_With_Timeout; -------------------------- -- Wait_Until_Abortable -- -------------------------- - -- Wait to start the abortable part of an async. select statement - -- until the trigger entry call becomes abortable. - procedure Wait_Until_Abortable - (Self_ID : Task_ID; - Call : Entry_Call_Link) - is + (Self_ID : Task_ID; + Call : Entry_Call_Link) is begin pragma Assert (Self_ID.ATC_Nesting_Level > 0); pragma Assert (Call.Mode = Asynchronous_Call); + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Completion); + end if; + STPO.Write_Lock (Self_ID); Self_ID.Common.State := Entry_Caller_Sleep; @@ -693,21 +715,10 @@ package body System.Tasking.Entry_Calls is Self_ID.Common.State := Runnable; STPO.Unlock (Self_ID); - end Wait_Until_Abortable; - - -- It might seem that we should be holding the server's lock when - -- we test Call.State above. - -- In an earlier version, the code above temporarily unlocked the - -- caller and locked the server just for checking Call.State. - -- The unlocking of the caller risked missing a wakeup - -- (an error) and locking the server had no apparent value. - -- We should not need the server's lock, since once Call.State - -- is set to Was_Abortable or beyond, it never goes back below - -- Was_Abortable until this task starts another entry call. - - -- ???? - -- It seems that other calls to Lock_Server may also risk missing - -- wakeups. We need to check that they do not have this problem. + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Call_Complete); + end if; + end Wait_Until_Abortable; end System.Tasking.Entry_Calls; diff --git a/gcc/ada/s-taenca.ads b/gcc/ada/s-taenca.ads index e28ff7a3e76..d272479038c 100644 --- a/gcc/ada/s-taenca.ads +++ b/gcc/ada/s-taenca.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.12 $ -- +-- $Revision$ -- -- --- Copyright (C) 1991-1998, 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,39 +29,44 @@ -- 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 package provides internal RTS calls implementing operations +-- that apply to general entry calls, that is, calls to either +-- protected or task entries. + +-- These declarations are not part of the GNARL Interface + package System.Tasking.Entry_Calls is - procedure Wait_For_Completion - (Self_ID : Task_ID; - Entry_Call : Entry_Call_Link); + procedure Wait_For_Completion (Entry_Call : Entry_Call_Link); -- This procedure suspends the calling task until the specified entry -- call has either been completed or cancelled. It performs other -- operations required of suspended tasks, such as performing -- dynamic priority changes. On exit, the call will not be queued. -- This waits for calls on task or protected entries. -- Abortion must be deferred when calling this procedure. - -- Call this only when holding Self_ID locked. + -- Call this only when holding Self (= Entry_Call.Self) or global RTS lock. procedure Wait_For_Completion_With_Timeout - (Self_ID : Task_ID; - Entry_Call : Entry_Call_Link; + (Entry_Call : Entry_Call_Link; Wakeup_Time : Duration; - Mode : Delay_Modes); - -- Same as Wait_For_Completion but it wait for a timeout with the value + Mode : Delay_Modes; + Yielded : out Boolean); + -- Same as Wait_For_Completion but wait for a timeout with the value -- specified in Wakeup_Time as well. - -- Self_ID will be locked by this procedure. + -- On return, Yielded indicates whether the wait has performed a yield. + -- Check_Exception must be called after calling this procedure. procedure Wait_Until_Abortable (Self_ID : Task_ID; - Call : Entry_Call_Link); + Call : Entry_Call_Link); -- This procedure suspends the calling task until the specified entry -- call is queued abortably or completes. - -- Abortion must be deferred when calling this procedure. + -- Abortion must be deferred when calling this procedure, and the global + -- RTS lock taken when Single_Lock. procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean); pragma Inline (Try_To_Cancel_Entry_Call); @@ -72,23 +77,24 @@ package System.Tasking.Entry_Calls is -- On return, the call is off-queue and the ATC level is reduced by one. procedure Reset_Priority - (Acceptor_Prev_Priority : Rendezvous_Priority; - Acceptor : Task_ID); + (Acceptor : Task_ID; + Acceptor_Prev_Priority : Rendezvous_Priority); pragma Inline (Reset_Priority); -- Reset the priority of a task completing an accept statement to -- the value it had before the call. + -- Acceptor should always be equal to Self. procedure Check_Exception - (Self_ID : Task_ID; + (Self_ID : Task_ID; Entry_Call : Entry_Call_Link); pragma Inline (Check_Exception); -- Raise any pending exception from the Entry_Call. - -- This should be called at the end of every compiler interface - -- procedure that implements an entry call. - -- In principle, the caller should not be abort-deferred (unless - -- the application program violates the Ada language rules by doing - -- entry calls from within protected operations -- an erroneous practice - -- apparently followed with success by some adventurous GNAT users). + -- This should be called at the end of every compiler interface procedure + -- that implements an entry call. + -- In principle, the caller should not be abort-deferred (unless the + -- application program violates the Ada language rules by doing entry calls + -- from within protected operations -- an erroneous practice apparently + -- followed with success by some adventurous GNAT users). -- Absolutely, the caller should not be holding any locks, or there -- will be deadlock. diff --git a/gcc/ada/s-taprob.adb b/gcc/ada/s-taprob.adb index 816d851e480..231d63059c0 100644 --- a/gcc/ada/s-taprob.adb +++ b/gcc/ada/s-taprob.adb @@ -42,9 +42,16 @@ with System.Task_Primitives.Operations; -- used for Write_Lock -- Unlock +with System.Parameters; +-- used for Runtime_Traces + +with System.Traces; +-- used for Send_Trace_Info + package body System.Tasking.Protected_Objects is use System.Task_Primitives.Operations; + use System.Traces; ------------------------- -- Finalize_Protection -- @@ -92,6 +99,10 @@ package body System.Tasking.Protected_Objects is Write_Lock (Object.L'Access, Ceiling_Violation); + if Parameters.Runtime_Traces then + Send_Trace_Info (PO_Lock); + end if; + if Ceiling_Violation then raise Program_Error; end if; @@ -106,6 +117,10 @@ package body System.Tasking.Protected_Objects is begin Read_Lock (Object.L'Access, Ceiling_Violation); + if Parameters.Runtime_Traces then + Send_Trace_Info (PO_Lock); + end if; + if Ceiling_Violation then raise Program_Error; end if; @@ -118,6 +133,10 @@ package body System.Tasking.Protected_Objects is procedure Unlock (Object : Protection_Access) is begin Unlock (Object.L'Access); + + if Parameters.Runtime_Traces then + Send_Trace_Info (PO_Unlock); + end if; end Unlock; end System.Tasking.Protected_Objects; diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads index df22279115e..c9171c6f57b 100644 --- a/gcc/ada/s-taprop.ads +++ b/gcc/ada/s-taprop.ads @@ -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). -- -- -- ------------------------------------------------------------------------------ @@ -138,9 +137,7 @@ package System.Task_Primitives.Operations is type Lock_Level is (PO_Level, Global_Task_Level, - All_Attrs_Level, - All_Tasks_Level, - Interrupts_Level, + RTS_Lock_Level, ATCB_Level); -- Type used to describe kind of lock for second form of Initialize_Lock -- call specified below. @@ -176,7 +173,7 @@ package System.Task_Primitives.Operations is -- corresponding Initialize_Lock operation. procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean); - procedure Write_Lock (L : access RTS_Lock); + procedure Write_Lock (L : access RTS_Lock; Global_Lock : Boolean := False); procedure Write_Lock (T : ST.Task_ID); pragma Inline (Write_Lock); -- Lock a lock object for write access. After this operation returns, @@ -190,6 +187,9 @@ package System.Task_Primitives.Operations is -- operation failed, which will happen if there is a priority ceiling -- violation. -- + -- For the operation on RTS_Lock, Global_Lock should be set to True + -- if L is a global lock (Single_RTS_Lock, Global_Task_Lock). + -- -- For the operation on ST.Task_ID, the lock is the special lock object -- associated with that task's ATCB. This lock has effective ceiling -- priority high enough that it is safe to call by a task with any @@ -221,7 +221,7 @@ package System.Task_Primitives.Operations is -- locking that make a reader-writer distinction have higher overhead. procedure Unlock (L : access Lock); - procedure Unlock (L : access RTS_Lock); + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False); procedure Unlock (T : ST.Task_ID); pragma Inline (Unlock); -- Unlock a locked lock object. @@ -232,9 +232,12 @@ package System.Task_Primitives.Operations is -- read or write permission. (That is, matching pairs of Lock and Unlock -- operations on each lock object must be properly nested.) + -- For the operation on RTS_Lock, Global_Lock should be set to True + -- if L is a global lock (Single_RTS_Lock, Global_Task_Lock). + -- -- Note that Write_Lock for RTS_Lock does not have an out-parameter. -- RTS_Locks are used in situations where we have not made provision - -- for recovery from ceiling violations. We do not expect them to + -- for recovery from ceiling violations. We do not expect them to -- occur inside the runtime system, because all RTS locks have ceiling -- Priority'Last. @@ -243,7 +246,7 @@ package System.Task_Primitives.Operations is -- executing in the Interrupt_Priority range. -- It is not clear what to do about ceiling violations due - -- to RTS calls done at interrupt priority. In general, it + -- to RTS calls done at interrupt priority. In general, it -- is not acceptable to give all RTS locks interrupt priority, -- since that whould give terrible performance on systems where -- this has the effect of masking hardware interrupts, though we @@ -255,7 +258,7 @@ package System.Task_Primitives.Operations is -- penalties. -- For POSIX systems, we considered just skipping setting a - -- priority ceiling on RTS locks. This would mean there is no + -- priority ceiling on RTS locks. This would mean there is no -- ceiling violation, but we would end up with priority inversions -- inside the runtime system, resulting in failure to satisfy the -- Ada priority rules, and possible missed validation tests. @@ -267,9 +270,9 @@ package System.Task_Primitives.Operations is -- This issue should be reconsidered whenever we get around to -- checking for calls to potentially blocking operations from - -- within protected operations. If we check for such calls and + -- within protected operations. If we check for such calls and -- catch them on entry to the OS, it may be that we can eliminate - -- the possibility of ceiling violations inside the RTS. For this + -- the possibility of ceiling violations inside the RTS. For this -- to work, we would have to forbid explicitly setting the priority -- of a task to anything in the Interrupt_Priority range, at least. -- We would also have to check that there are no RTS-lock operations @@ -278,7 +281,7 @@ package System.Task_Primitives.Operations is -- The latter approach seems to be the best, i.e. to check on entry -- to RTS calls that may need to use locks that the priority is not - -- in the interrupt range. If there are RTS operations that NEED to + -- in the interrupt range. If there are RTS operations that NEED to -- be called from interrupt handlers, those few RTS locks should then -- be converted to PO-type locks, with ceiling Interrupt_Priority'Last. @@ -325,9 +328,9 @@ package System.Task_Primitives.Operations is -- Returns the resolution of the underlying clock used to implement -- RT_Clock. - ------------------ - -- Extensions -- - ------------------ + ---------------- + -- Extensions -- + ---------------- -- Whoever calls either of the Sleep routines is responsible -- for checking for pending aborts before the call. @@ -389,6 +392,26 @@ package System.Task_Primitives.Operations is function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id; -- returns the thread id of the specified task. + ----------------------- + -- RTS Entrance/Exit -- + ----------------------- + + -- Following two routines are used for possible operations needed + -- to be setup/cleared upon entrance/exit of RTS while maintaining + -- a single thread of control in the RTS. Since we intend these + -- routines to be used for implementing the Single_Lock RTS, + -- Lock_RTS should follow the first Defer_Abortion operation + -- entering RTS. In the same fashion Unlock_RTS should preceed + -- the last Undefer_Abortion exiting RTS. + -- + -- These routines also replace the functions Lock/Unlock_All_Tasks_List + + procedure Lock_RTS; + -- Take the global RTS lock. + + procedure Unlock_RTS; + -- Release the global RTS lock. + -------------------- -- Stack Checking -- -------------------- @@ -465,12 +488,4 @@ package System.Task_Primitives.Operations is -- Such functionality is needed by gdb on some targets (e.g VxWorks) -- Return True is the operation is successful - procedure Lock_All_Tasks_List; - procedure Unlock_All_Tasks_List; - -- Lock/Unlock the All_Tasks_L lock which protects - -- System.Initialization.All_Tasks_List and Known_Tasks - -- ??? These routines were previousely in System.Tasking.Initialization - -- but were moved here to avoid dependency problems. That would be - -- nice to look at it some day and put it back in Initialization. - end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb index 83d184e3fa4..19cac821ca7 100644 --- a/gcc/ada/s-tarest.adb +++ b/gcc/ada/s-tarest.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1999-2001 Ada Core Technologies -- +-- Copyright (C) 1999-2001, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -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,6 +49,7 @@ pragma Polling (Off); with System.Parameters; -- used for Size_Type +-- Single_Lock with System.Task_Info; -- used for Task_Info_Type @@ -83,9 +83,9 @@ package body System.Tasking.Restricted.Stages is package SSE renames System.Storage_Elements; package SST renames System.Secondary_Stack; - use System.Task_Primitives; - use System.Task_Primitives.Operations; - use System.Task_Info; + use Parameters; + use Task_Primitives.Operations; + use Task_Info; Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock; -- This is a global lock; it is used to execute in mutual exclusion @@ -147,7 +147,7 @@ package body System.Tasking.Restricted.Stages is procedure Task_Lock is begin - STPO.Write_Lock (Global_Task_Lock'Access); + STPO.Write_Lock (Global_Task_Lock'Access, Global_Lock => True); end Task_Lock; ----------------- @@ -156,7 +156,7 @@ package body System.Tasking.Restricted.Stages is procedure Task_Unlock is begin - STPO.Unlock (Global_Task_Lock'Access); + STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True); end Task_Unlock; ---------------------- @@ -294,6 +294,10 @@ package body System.Tasking.Restricted.Stages is pragma Assert (Self_ID = Environment_Task); pragma Assert (Self_ID.Common.Wait_Count = 0); + if Single_Lock then + Lock_RTS; + end if; + -- Lock self, to prevent activated tasks -- from racing ahead before we finish activating the chain. @@ -351,6 +355,10 @@ package body System.Tasking.Restricted.Stages is Self_ID.Common.State := Runnable; Unlock (Self_ID); + if Single_Lock then + Unlock_RTS; + end if; + -- Remove the tasks from the chain. Chain_Access.T_ID := null; @@ -370,6 +378,10 @@ package body System.Tasking.Restricted.Stages is Activator : constant Task_ID := Self_ID.Common.Activator; begin + if Single_Lock then + Lock_RTS; + end if; + Write_Lock (Activator); Write_Lock (Self_ID); @@ -393,6 +405,10 @@ package body System.Tasking.Restricted.Stages is Unlock (Self_ID); Unlock (Activator); + if Single_Lock then + Unlock_RTS; + end if; + -- After the activation, active priority should be the same -- as base priority. We must unlock the Activator first, -- though, since it should not wait if we have lower priority. @@ -439,6 +455,11 @@ package body System.Tasking.Restricted.Stages is end if; T := New_ATCB (0); + + if Single_Lock then + Lock_RTS; + end if; + Write_Lock (Self_ID); -- With no task hierarchy, the parent of all non-Environment tasks that @@ -454,6 +475,11 @@ package body System.Tasking.Restricted.Stages is if not Success then Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + raise Program_Error; end if; @@ -461,6 +487,10 @@ package body System.Tasking.Restricted.Stages is T.Common.Task_Image := Task_Image; Unlock (Self_ID); + if Single_Lock then + Unlock_RTS; + end if; + -- Create TSD as early as possible in the creation of a task, since it -- may be used by the operation of Ada code within the task. @@ -483,10 +513,18 @@ package body System.Tasking.Restricted.Stages is begin pragma Assert (Self_ID = STPO.Environment_Task); + if Single_Lock then + Lock_RTS; + end if; + Write_Lock (Self_ID); Sleep (Self_ID, Master_Completion_Sleep); Unlock (Self_ID); + if Single_Lock then + Unlock_RTS; + end if; + -- Should never return from Master Completion Sleep raise Program_Error; diff --git a/gcc/ada/s-tasdeb.adb b/gcc/ada/s-tasdeb.adb index aceeecfdb84..8b6f2720e79 100644 --- a/gcc/ada/s-tasdeb.adb +++ b/gcc/ada/s-tasdeb.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $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- -- @@ -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). -- -- -- ------------------------------------------------------------------------------ @@ -40,7 +39,7 @@ -- Note : This file *must* be compiled with debugging information -- Do not add any dependency to GNARL packages since this package is used --- in both normal and resticted (ravenscar) environments. +-- in both normal and restricted (ravenscar) environments. with System.Task_Info, System.Task_Primitives.Operations, @@ -53,18 +52,12 @@ package body System.Tasking.Debug is package STPO renames System.Task_Primitives.Operations; type Integer_Address is mod 2 ** Standard'Address_Size; - type Integer_Address_Ptr is access all Integer_Address; - - function "+" is new - Unchecked_Conversion (System.Address, Integer_Address_Ptr); function "+" is new Unchecked_Conversion (Task_ID, Integer_Address); Hex_Address_Width : constant := (Standard'Address_Size / 4); - Zero_Pos : constant := Character'Pos ('0'); - Hex_Digits : constant array (0 .. Integer_Address'(15)) of Character := "0123456789abcdef"; @@ -499,7 +492,7 @@ package body System.Tasking.Debug is R : Boolean; begin - STPO.Lock_All_Tasks_List; + STPO.Lock_RTS; C := All_Tasks_List; while C /= null loop @@ -507,7 +500,7 @@ package body System.Tasking.Debug is C := C.Common.All_Tasks_Link; end loop; - STPO.Unlock_All_Tasks_List; + STPO.Unlock_RTS; end Resume_All_Tasks; ---------- @@ -580,7 +573,7 @@ package body System.Tasking.Debug is R : Boolean; begin - STPO.Lock_All_Tasks_List; + STPO.Lock_RTS; C := All_Tasks_List; while C /= null loop @@ -588,7 +581,7 @@ package body System.Tasking.Debug is C := C.Common.All_Tasks_Link; end loop; - STPO.Unlock_All_Tasks_List; + STPO.Unlock_RTS; end Suspend_All_Tasks; ------------------------ @@ -682,6 +675,8 @@ package body System.Tasking.Debug is Other_ID : ST.Task_ID; Flag : Character) is + pragma Warnings (Off, Other_ID); + Self_ID : constant ST.Task_ID := STPO.Self; begin diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb index 08d778f9231..791be6027e7 100644 --- a/gcc/ada/s-tasini.adb +++ b/gcc/ada/s-tasini.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.63 $ +-- $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). -- -- -- ------------------------------------------------------------------------------ @@ -43,11 +42,6 @@ pragma Polling (Off); -- of the routines in this package, and more to the point, if we try -- to poll it can cause infinite loops. --- This package provides overall initialization of the tasking portion --- of the RTS. This package must be elaborated before any tasking --- features are used. It also contains initialization for --- Ada Task Control Block (ATCB) records. - with Ada.Exceptions; -- used for Exception_Occurrence_Access. @@ -71,22 +65,23 @@ with System.Soft_Links; with System.Tasking.Debug; -- used for Trace -with System.Tasking.Task_Attributes; --- used for All_Attrs_L - with System.Stack_Checking; +with System.Parameters; +-- used for Single_Lock + package body System.Tasking.Initialization is package STPO renames System.Task_Primitives.Operations; package SSL renames System.Soft_Links; package AE renames Ada.Exceptions; - use System.Task_Primitives.Operations; + use Parameters; + use Task_Primitives.Operations; Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock; -- This is a global lock; it is used to execute in mutual exclusion - -- from all other tasks. It is only used by Task_Lock, + -- from all other tasks. It is only used by Task_Lock, -- Task_Unlock, and Final_Task_Unlock. function Current_Target_Exception return AE.Exception_Occurrence; @@ -143,6 +138,9 @@ package body System.Tasking.Initialization is (X : AE.Exception_Occurrence := Current_Target_Exception); -- Handle exception setting and check for pending actions + function Task_Name return String; + -- Returns current task's name + ------------------------ -- Local Subprograms -- ------------------------ @@ -181,8 +179,7 @@ package body System.Tasking.Initialization is ------------------------ function Check_Abort_Status return Integer is - Self_ID : Task_ID := Self; - + Self_ID : constant Task_ID := Self; begin if Self_ID /= null and then Self_ID.Deferral_Level = 0 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level @@ -199,36 +196,37 @@ package body System.Tasking.Initialization is procedure Defer_Abort (Self_ID : Task_ID) is begin + if No_Abort and then not Dynamic_Priority_Support then + return; + end if; pragma Assert (Self_ID.Deferral_Level = 0); --- pragma Assert --- (Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level); - - -- The above check has been useful in detecting mismatched - -- defer/undefer pairs. You may uncomment it when testing on - -- systems that support preemptive abort. - - -- If the OS supports preemptive abort (e.g. pthread_kill), - -- it should have happened already. A problem is with systems - -- that do not support preemptive abort, and so rely on polling. - -- On such systems we may get false failures of the assertion, - -- since polling for pending abort does no occur until the abort - -- undefer operation. - - -- Even on systems that only poll for abort, the assertion may - -- be useful for catching missed abort completion polling points. - -- The operations that undefer abort poll for pending aborts. - -- This covers most of the places where the core Ada semantics - -- require abort to be caught, without any special attention. - -- However, this generally happens on exit from runtime system - -- call, which means a pending abort will not be noticed on the - -- way into the runtime system. We considered adding a check - -- for pending aborts at this point, but chose not to, because - -- of the overhead. Instead, we searched for RTS calls that - -- where abort completion is required and a task could go - -- farther than Ada allows before undeferring abort; we then - -- modified the code to ensure the abort would be detected. + -- pragma Assert + -- (Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level); + + -- The above check has been useful in detecting mismatched defer/undefer + -- pairs. You may uncomment it when testing on systems that support + -- preemptive abort. + + -- If the OS supports preemptive abort (e.g. pthread_kill), it should + -- have happened already. A problem is with systems that do not support + -- preemptive abort, and so rely on polling. On such systems we may get + -- false failures of the assertion, since polling for pending abort does + -- no occur until the abort undefer operation. + + -- Even on systems that only poll for abort, the assertion may be useful + -- for catching missed abort completion polling points. The operations + -- that undefer abort poll for pending aborts. This covers most of the + -- places where the core Ada semantics require abort to be caught, + -- without any special attention. However, this generally happens on + -- exit from runtime system call, which means a pending abort will not + -- be noticed on the way into the runtime system. We considered adding a + -- check for pending aborts at this point, but chose not to, because of + -- the overhead. Instead, we searched for RTS calls where abort + -- completion is required and a task could go farther than Ada allows + -- before undeferring abort; we then modified the code to ensure the + -- abort would be detected. Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; end Defer_Abort; @@ -239,13 +237,16 @@ package body System.Tasking.Initialization is procedure Defer_Abort_Nestable (Self_ID : Task_ID) is begin + if No_Abort and then not Dynamic_Priority_Support then + return; + end if; --- pragma Assert --- ((Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level or else --- Self_ID.Deferral_Level > 0)); + -- pragma Assert + -- ((Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level or else + -- Self_ID.Deferral_Level > 0)); - -- See comment in Defer_Abort on the situations in which it may - -- be useful to uncomment the above assertion. + -- See comment in Defer_Abort on the situations in which it may be + -- useful to uncomment the above assertion. Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; end Defer_Abort_Nestable; @@ -254,14 +255,15 @@ package body System.Tasking.Initialization is -- Defer_Abortion -- -------------------- - -- ?????? - -- Phase out Defer_Abortion without Self_ID - -- to reduce overhead due to multiple calls to Self - procedure Defer_Abortion is - Self_ID : constant Task_ID := STPO.Self; + Self_ID : Task_ID; begin + if No_Abort and then not Dynamic_Priority_Support then + return; + end if; + + Self_ID := STPO.Self; Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; end Defer_Abortion; @@ -285,11 +287,19 @@ package body System.Tasking.Initialization is Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; + if Single_Lock then + Lock_RTS; + end if; + Write_Lock (Self_ID); Self_ID.Pending_Action := False; Poll_Base_Priority_Change (Self_ID); Unlock (Self_ID); + if Single_Lock then + Unlock_RTS; + end if; + -- Restore the original Deferral value. Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; @@ -341,7 +351,7 @@ package body System.Tasking.Initialization is procedure Final_Task_Unlock (Self_ID : Task_ID) is begin pragma Assert (Self_ID.Global_Task_Lock_Nesting = 1); - Unlock (Global_Task_Lock'Access); + Unlock (Global_Task_Lock'Access, Global_Lock => True); end Final_Task_Unlock; -------------- @@ -350,6 +360,7 @@ package body System.Tasking.Initialization is procedure Init_RTS is Self_Id : Task_ID; + begin -- Terminate run time (regular vs restricted) specific initialization -- of the environment task. @@ -380,17 +391,14 @@ package body System.Tasking.Initialization is Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level); - -- Initialize lock used to implement mutual exclusion in the package - -- System.Task_Attributes. - - Initialize_Lock (System.Tasking.Task_Attributes.All_Attrs_L'Access, - All_Attrs_Level); - -- Notify that the tasking run time has been elaborated so that -- the tasking version of the soft links can be used. - SSL.Abort_Defer := Defer_Abortion'Access; - SSL.Abort_Undefer := Undefer_Abortion'Access; + if not No_Abort or else Dynamic_Priority_Support then + SSL.Abort_Defer := Defer_Abortion'Access; + SSL.Abort_Undefer := Undefer_Abortion'Access; + end if; + SSL.Update_Exception := Update_Exception'Access; SSL.Lock_Task := Task_Lock'Access; SSL.Unlock_Task := Task_Unlock'Access; @@ -406,6 +414,7 @@ package body System.Tasking.Initialization is SSL.Timed_Delay := Timed_Delay_T'Access; SSL.Check_Abort_Status := Check_Abort_Status'Access; SSL.Get_Stack_Info := Get_Stack_Info'Access; + SSL.Task_Name := Task_Name'Access; -- No need to create a new Secondary Stack, since we will use the -- default one created in s-secsta.adb @@ -574,17 +583,21 @@ package body System.Tasking.Initialization is procedure Poll_Base_Priority_Change (Self_ID : Task_ID) is begin - if Dynamic_Priority_Support - and then Self_ID.Pending_Priority_Change - then + if Dynamic_Priority_Support and then Self_ID.Pending_Priority_Change then -- Check for ceiling violations ??? Self_ID.Pending_Priority_Change := False; if Self_ID.Common.Base_Priority = Self_ID.New_Base_Priority then - Unlock (Self_ID); - Yield; - Write_Lock (Self_ID); + if Single_Lock then + Unlock_RTS; + Yield; + Lock_RTS; + else + Unlock (Self_ID); + Yield; + Write_Lock (Self_ID); + end if; elsif Self_ID.Common.Base_Priority < Self_ID.New_Base_Priority then Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; @@ -595,9 +608,16 @@ package body System.Tasking.Initialization is Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - Unlock (Self_ID); - Yield; - Write_Lock (Self_ID); + + if Single_Lock then + Unlock_RTS; + Yield; + Lock_RTS; + else + Unlock (Self_ID); + Yield; + Write_Lock (Self_ID); + end if; end if; end if; end Poll_Base_Priority_Change; @@ -614,10 +634,9 @@ package body System.Tasking.Initialization is pragma Debug (Debug.Trace ("Remove_From_All_Tasks_List", 'C')); - Lock_All_Tasks_List; - Previous := Null_Task; C := All_Tasks_List; + while C /= Null_Task loop if C = T then if Previous = Null_Task then @@ -627,7 +646,6 @@ package body System.Tasking.Initialization is Previous.Common.All_Tasks_Link := C.Common.All_Tasks_Link; end if; - Unlock_All_Tasks_List; return; end if; @@ -642,56 +660,56 @@ package body System.Tasking.Initialization is -- Task_Lock -- --------------- - procedure Task_Lock is - T : Task_ID := STPO.Self; - - begin - T.Global_Task_Lock_Nesting := T.Global_Task_Lock_Nesting + 1; - - if T.Global_Task_Lock_Nesting = 1 then - Defer_Abort_Nestable (T); - Write_Lock (Global_Task_Lock'Access); - end if; - end Task_Lock; - procedure Task_Lock (Self_ID : Task_ID) is begin Self_ID.Global_Task_Lock_Nesting := Self_ID.Global_Task_Lock_Nesting + 1; if Self_ID.Global_Task_Lock_Nesting = 1 then Defer_Abort_Nestable (Self_ID); - Write_Lock (Global_Task_Lock'Access); + Write_Lock (Global_Task_Lock'Access, Global_Lock => True); end if; end Task_Lock; - ----------------- - -- Task_Unlock -- - ----------------- - - procedure Task_Unlock is - T : Task_ID := STPO.Self; - + procedure Task_Lock is begin - pragma Assert (T.Global_Task_Lock_Nesting > 0); + Task_Lock (STPO.Self); + end Task_Lock; - T.Global_Task_Lock_Nesting := T.Global_Task_Lock_Nesting - 1; + --------------- + -- Task_Name -- + --------------- + + function Task_Name return String is + use System.Task_Info; - if T.Global_Task_Lock_Nesting = 0 then - Unlock (Global_Task_Lock'Access); - Undefer_Abort_Nestable (T); + begin + if STPO.Self.Common.Task_Image /= null then + return STPO.Self.Common.Task_Image.all; + else + return ""; end if; - end Task_Unlock; + end Task_Name; + + ----------------- + -- Task_Unlock -- + ----------------- procedure Task_Unlock (Self_ID : Task_ID) is begin + pragma Assert (Self_ID.Global_Task_Lock_Nesting > 0); Self_ID.Global_Task_Lock_Nesting := Self_ID.Global_Task_Lock_Nesting - 1; if Self_ID.Global_Task_Lock_Nesting = 0 then - Unlock (Global_Task_Lock'Access); + Unlock (Global_Task_Lock'Access, Global_Lock => True); Undefer_Abort_Nestable (Self_ID); end if; end Task_Unlock; + procedure Task_Unlock is + begin + Task_Unlock (STPO.Self); + end Task_Unlock; + ------------------- -- Undefer_Abort -- ------------------- @@ -700,14 +718,17 @@ package body System.Tasking.Initialization is -- Undefer_Abort is called on any abortion completion point (aka. -- synchronization point). It performs the following actions if they - -- are pending: (1) change the base priority, (2) abort the task, - -- (3) raise a pending exception. + -- are pending: (1) change the base priority, (2) abort the task. -- The priority change has to occur before abortion. Otherwise, it would -- take effect no earlier than the next abortion completion point. procedure Undefer_Abort (Self_ID : Task_ID) is begin + if No_Abort and then not Dynamic_Priority_Support then + return; + end if; + pragma Assert (Self_ID.Deferral_Level = 1); Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; @@ -725,23 +746,25 @@ package body System.Tasking.Initialization is -- Undefer_Abort_Nestable -- ---------------------------- - -- An earlier version would re-defer abort if an abort is - -- in progress. Then, we modified the effect of the raise - -- statement so that it defers abort until control reaches a - -- handler. That was done to prevent "skipping over" a - -- handler if another asynchronous abort occurs during the - -- propagation of the abort to the handler. - - -- There has been talk of reversing that decision, based on - -- a newer implementation of exception propagation. Care must - -- be taken to evaluate how such a change would interact with - -- the above code and all the places where abort-deferral is - -- used to bridge over critical transitions, such as entry to - -- the scope of a region with a finalizer and entry into the + -- An earlier version would re-defer abort if an abort is in progress. + -- Then, we modified the effect of the raise statement so that it defers + -- abort until control reaches a handler. That was done to prevent + -- "skipping over" a handler if another asynchronous abort occurs during + -- the propagation of the abort to the handler. + + -- There has been talk of reversing that decision, based on a newer + -- implementation of exception propagation. Care must be taken to evaluate + -- how such a change would interact with the above code and all the places + -- where abort-deferral is used to bridge over critical transitions, such + -- as entry to the scope of a region with a finalizer and entry into the -- body of an accept-procedure. procedure Undefer_Abort_Nestable (Self_ID : Task_ID) is begin + if No_Abort and then not Dynamic_Priority_Support then + return; + end if; + pragma Assert (Self_ID.Deferral_Level > 0); Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; @@ -764,9 +787,13 @@ package body System.Tasking.Initialization is -- to reduce overhead due to multiple calls to Self. procedure Undefer_Abortion is - Self_ID : constant Task_ID := STPO.Self; - + Self_ID : Task_ID; begin + if No_Abort and then not Dynamic_Priority_Support then + return; + end if; + + Self_ID := STPO.Self; pragma Assert (Self_ID.Deferral_Level > 0); Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; @@ -799,10 +826,20 @@ package body System.Tasking.Initialization is if Self_Id.Pending_Action then Self_Id.Pending_Action := False; Self_Id.Deferral_Level := Self_Id.Deferral_Level + 1; + + if Single_Lock then + Lock_RTS; + end if; + Write_Lock (Self_Id); Self_Id.Pending_Action := False; Poll_Base_Priority_Change (Self_Id); Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + Self_Id.Deferral_Level := Self_Id.Deferral_Level - 1; if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then @@ -846,7 +883,6 @@ package body System.Tasking.Initialization is New_State : Entry_Call_State) is Caller : constant Task_ID := Entry_Call.Self; - begin pragma Debug (Debug.Trace (Self_ID, "Wakeup_Entry_Caller", Caller, 'E')); @@ -878,49 +914,42 @@ package body System.Tasking.Initialization is function Get_Current_Excep return SSL.EOA is Me : constant Task_ID := STPO.Self; - begin return Me.Common.Compiler_Data.Current_Excep'Access; end Get_Current_Excep; function Get_Exc_Stack_Addr return Address is Me : constant Task_ID := STPO.Self; - begin return Me.Common.Compiler_Data.Exc_Stack_Addr; end Get_Exc_Stack_Addr; function Get_Jmpbuf_Address return Address is Me : constant Task_ID := STPO.Self; - begin return Me.Common.Compiler_Data.Jmpbuf_Address; end Get_Jmpbuf_Address; function Get_Machine_State_Addr return Address is Me : constant Task_ID := STPO.Self; - begin return Me.Common.Compiler_Data.Machine_State_Addr; end Get_Machine_State_Addr; function Get_Sec_Stack_Addr return Address is Me : constant Task_ID := STPO.Self; - begin return Me.Common.Compiler_Data.Sec_Stack_Addr; end Get_Sec_Stack_Addr; function Get_Stack_Info return Stack_Checking.Stack_Access is Me : constant Task_ID := STPO.Self; - begin return Me.Common.Compiler_Data.Pri_Stack_Info'Access; end Get_Stack_Info; procedure Set_Exc_Stack_Addr (Self_ID : Address; Addr : Address) is Me : Task_ID := To_Task_Id (Self_ID); - begin if Me = Null_Task then Me := STPO.Self; @@ -931,47 +960,44 @@ package body System.Tasking.Initialization is procedure Set_Jmpbuf_Address (Addr : Address) is Me : Task_ID := STPO.Self; - begin Me.Common.Compiler_Data.Jmpbuf_Address := Addr; end Set_Jmpbuf_Address; procedure Set_Machine_State_Addr (Addr : Address) is Me : Task_ID := STPO.Self; - begin Me.Common.Compiler_Data.Machine_State_Addr := Addr; end Set_Machine_State_Addr; procedure Set_Sec_Stack_Addr (Addr : Address) is Me : Task_ID := STPO.Self; - begin Me.Common.Compiler_Data.Sec_Stack_Addr := Addr; end Set_Sec_Stack_Addr; procedure Timed_Delay_T (Time : Duration; Mode : Integer) is - Self_ID : constant Task_ID := Self; - begin - STPO.Timed_Delay (Self_ID, Time, Mode); + STPO.Timed_Delay (STPO.Self, Time, Mode); end Timed_Delay_T; - ------------------------ - -- Soft-Link Dummies -- - ------------------------ + ----------------------- + -- Soft-Link Dummies -- + ----------------------- -- These are dummies for subprograms that are only needed by certain - -- optional run-time system packages. If they are needed, the soft + -- optional run-time system packages. If they are needed, the soft -- links will be redirected to the real subprogram by elaboration of -- the subprogram body where the real subprogram is declared. procedure Finalize_Attributes (T : Task_ID) is + pragma Warnings (Off, T); begin null; end Finalize_Attributes; procedure Initialize_Attributes (T : Task_ID) is + pragma Warnings (Off, T); begin null; end Initialize_Attributes; diff --git a/gcc/ada/s-tasini.ads b/gcc/ada/s-tasini.ads index 56381c60bcf..1128739e8a2 100644 --- a/gcc/ada/s-tasini.ads +++ b/gcc/ada/s-tasini.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.24 $ +-- $Revision$ -- -- --- Copyright (C) 1992-1999, 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- -- @@ -29,32 +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 package provides overall initialization of the tasking portion of the -- RTS. This package must be elaborated before any tasking features are used. --- It also contains initialization for Ada Task Control Block (ATCB) records. package System.Tasking.Initialization is procedure Remove_From_All_Tasks_List (T : Task_ID); -- Remove T from All_Tasks_List. - - ------------------------------------------------ - -- Static (Compile-Time) Configuration Flags -- - ------------------------------------------------ - - -- ????? - -- Maybe this does not belong here? Where else? - -- For now, it is here because so is Change_Base_Priority, - -- and the two are used together. - - Dynamic_Priority_Support : constant Boolean := True; - -- Should we poll for pending base priority changes at every - -- abort completion point? + -- Call this function with RTS_Lock taken. --------------------------------- -- Tasking-Specific Soft Links -- @@ -89,9 +75,7 @@ package System.Tasking.Initialization is -- 1) base priority changes - -- 2) exceptions that need to be raised - - -- 3) abort/ATC + -- 2) abort/ATC -- Abort deferral MAY be nested (Self_ID.Deferral_Level is a count), -- but to avoid waste and undetected errors, it generally SHOULD NOT @@ -119,10 +103,10 @@ package System.Tasking.Initialization is -- deferred, and do not modify the deferral level. -- There is also a set of non-linable defer/undefer routines, - -- for direct call from the compiler. These are not in-lineable + -- for direct call from the compiler. These are not in-lineable -- because they may need to be called via pointers ("soft links"). -- For the sake of efficiency, the version with Self_ID as parameter - -- should used wherever possible. These are all nestable. + -- should used wherever possible. These are all nestable. -- Non-nestable inline versions -- @@ -141,7 +125,7 @@ package System.Tasking.Initialization is pragma Inline (Undefer_Abort_Nestable); -- NON-INLINE versions without Self_ID for code generated by the - -- expander and for hard links + -- expander and for soft links procedure Defer_Abortion; procedure Undefer_Abortion; @@ -172,7 +156,10 @@ package System.Tasking.Initialization is ---------------------- procedure Task_Lock (Self_ID : Task_ID); + pragma Inline (Task_Lock); + procedure Task_Unlock (Self_ID : Task_ID); + pragma Inline (Task_Unlock); -- These are versions of Lock_Task and Unlock_Task created for use -- within the GNARL. diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index dcab023fdc5..a9c2a4e552c 100644 --- a/gcc/ada/s-taskin.adb +++ b/gcc/ada/s-taskin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.38 $ +-- $Revision$ -- -- -- Copyright (C) 1991-2001 Florida State University -- -- -- @@ -67,8 +67,6 @@ package body System.Tasking is -- Initialize_ATCB -- --------------------- - -- Call this only with abort deferred and holding All_Tasks_L. - procedure Initialize_ATCB (Self_ID : Task_ID; Task_Entry_Point : Task_Procedure_Access; diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index de9fe568b98..3df8512b8af 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.89 $ +-- $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). -- -- -- ------------------------------------------------------------------------------ @@ -53,7 +52,6 @@ with System.Soft_Links; with System.Task_Primitives; -- used for Private_Data --- Lock (in System.Tasking.Protected_Objects) with Unchecked_Conversion; @@ -83,15 +81,13 @@ package System.Tasking is -- Unlock (Y); -- -- Locks with lower (smaller) level number cannot be locked - -- while holding a lock with a higher level number. (The level + -- while holding a lock with a higher level number. (The level -- number is the number at the left.) -- -- 1. System.Tasking.PO_Simple.Protection.L (any PO lock) -- 2. System.Tasking.Initialization.Global_Task_Lock (in body) - -- 3. System.Tasking.Task_Attributes.All_Attrs_L - -- 4. System.Task_Primitives.Operations.All_Tasks_L - -- 5. System.Interrupts.L (in body) - -- 6. System.Tasking.Ada_Task_Control_Block.LL.L (any TCB lock) + -- 3. System.Task_Primitives.Operations.Single_RTS_Lock + -- 4. System.Tasking.Ada_Task_Control_Block.LL.L (any TCB lock) -- -- Clearly, there can be no circular chain of hold-and-wait -- relationships involving locks in different ordering levels. @@ -100,7 +96,7 @@ package System.Tasking is -- clearly wrong since there can be calls to "new" inside protected -- operations. The new ordering prevents these failures. -- - -- Sometime we need to hold two ATCB locks at the same time. To allow + -- Sometimes we need to hold two ATCB locks at the same time. To allow -- us to order the locking, each ATCB is given a unique serial -- number. If one needs to hold locks on several ATCBs at once, -- the locks with lower serial numbers must be locked first. @@ -113,9 +109,6 @@ package System.Tasking is -- . The environment task has a lower serial number than any other task. -- . If the activator of a task is different from the task's parent, -- the parent always has a lower serial number than the activator. - -- - -- For interrupt-handler state, we have a special locking rule. - -- See System.Interrupts (spec) for explanation. --------------------------------- -- Task_ID related definitions -- @@ -469,7 +462,7 @@ package System.Tasking is All_Tasks_Link : Task_ID; -- Used to link this task to the list of all tasks in the system. - -- Protection: All_Tasks.L. + -- Protection: RTS_Lock. Activation_Link : Task_ID; -- Used to link this task to a list of tasks to be activated. @@ -934,11 +927,13 @@ package System.Tasking is -- is, in user terms Direct_Attributes : Direct_Attribute_Array; - -- for task attributes that have same size as Address + -- For task attributes that have same size as Address + Is_Defined : Direct_Index_Vector := 0; - -- bit I is 1 iff Direct_Attributes (I) is defined + -- Bit I is 1 iff Direct_Attributes (I) is defined + Indirect_Attributes : Access_Address; - -- a pointer to chain of records for other attributes that + -- A pointer to chain of records for other attributes that -- are not address-sized, including all tagged types. Entry_Queues : Task_Entry_Queue_Array (1 .. Entry_Num); @@ -964,7 +959,7 @@ package System.Tasking is T : in out Task_ID; Success : out Boolean); -- Initialize fields of a TCB and link into global TCB structures - -- Call this only with abort deferred and holding All_Tasks_L. + -- Call this only with abort deferred and holding RTS_Lock. private diff --git a/gcc/ada/s-tasque.adb b/gcc/ada/s-tasque.adb index 19533476073..dfc5aa961af 100644 --- a/gcc/ada/s-tasque.adb +++ b/gcc/ada/s-tasque.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.37 $ +-- $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). -- -- -- ------------------------------------------------------------------------------ @@ -45,17 +44,15 @@ with System.Task_Primitives.Operations; with System.Tasking.Initialization; -- used for Wakeup_Entry_Caller +with System.Parameters; +-- used for Single_Lock + package body System.Tasking.Queuing is - use System.Task_Primitives.Operations; - use System.Tasking.Protected_Objects; - use System.Tasking.Protected_Objects.Entries; - - procedure Wakeup_Entry_Caller - (Self_ID : Task_ID; - Entry_Call : Entry_Call_Link; - New_State : Entry_Call_State) - renames Initialization.Wakeup_Entry_Caller; + use Parameters; + use Task_Primitives.Operations; + use Protected_Objects; + use Protected_Objects.Entries; -- Entry Queues implemented as doubly linked list. @@ -81,11 +78,15 @@ package body System.Tasking.Queuing is procedure Broadcast_Program_Error (Self_ID : Task_ID; Object : Protection_Entries_Access; - Pending_Call : Entry_Call_Link) + Pending_Call : Entry_Call_Link; + RTS_Locked : Boolean := False) is - Entry_Call : Entry_Call_Link; - + Entry_Call : Entry_Call_Link; begin + if Single_Lock and then not RTS_Locked then + Lock_RTS; + end if; + if Pending_Call /= null then Send_Program_Error (Self_ID, Pending_Call); end if; @@ -100,6 +101,10 @@ package body System.Tasking.Queuing is Dequeue_Head (Object.Entry_Queues (E), Entry_Call); end loop; end loop; + + if Single_Lock and then not RTS_Locked then + Unlock_RTS; + end if; end Broadcast_Program_Error; ----------------- @@ -472,7 +477,9 @@ package body System.Tasking.Queuing is is Entry_Call : Entry_Call_Link; Temp_Call : Entry_Call_Link; - Entry_Index : Protected_Entry_Index; + Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning + + -- ??? should add comment as to why Entry_Index is always initialized begin Entry_Call := null; @@ -485,10 +492,12 @@ package body System.Tasking.Queuing is for J in Object.Entry_Queues'Range loop Temp_Call := Head (Object.Entry_Queues (J)); - if Temp_Call /= null and then - Object.Entry_Bodies ( - Object.Find_Body_Index (Object.Compiler_Info, J)). - Barrier (Object.Compiler_Info, J) + if Temp_Call /= null + and then + Object.Entry_Bodies + (Object.Find_Body_Index + (Object.Compiler_Info, J)). + Barrier (Object.Compiler_Info, J) then if (Entry_Call = null or else Entry_Call.Prio < Temp_Call.Prio) @@ -505,10 +514,12 @@ package body System.Tasking.Queuing is for J in Object.Entry_Queues'Range loop Temp_Call := Head (Object.Entry_Queues (J)); - if Temp_Call /= null and then - Object.Entry_Bodies ( - Object.Find_Body_Index (Object.Compiler_Info, J)). - Barrier (Object.Compiler_Info, J) + if Temp_Call /= null + and then + Object.Entry_Bodies + (Object.Find_Body_Index + (Object.Compiler_Info, J)). + Barrier (Object.Compiler_Info, J) then Entry_Call := Temp_Call; Entry_Index := J; @@ -549,16 +560,16 @@ package body System.Tasking.Queuing is is Entry_Call : Entry_Call_Link; Temp_Call : Entry_Call_Link; - Entry_Index : Task_Entry_Index; + Entry_Index : Task_Entry_Index := Task_Entry_Index'First; Temp_Entry : Task_Entry_Index; begin Open_Alternative := False; - Entry_Call := null; + Entry_Call := null; + Selection := No_Rendezvous; if Priority_Queuing then - - -- Priority Queuing + -- Priority queueing case for J in Open_Accepts'Range loop Temp_Entry := Open_Accepts (J).S; @@ -567,12 +578,11 @@ package body System.Tasking.Queuing is Open_Alternative := True; Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); - if Temp_Call /= null and then - (Entry_Call = null or else - Entry_Call.Prio < Temp_Call.Prio) - + if Temp_Call /= null + and then (Entry_Call = null + or else Entry_Call.Prio < Temp_Call.Prio) then - Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); Entry_Index := Temp_Entry; Selection := J; end if; @@ -580,7 +590,7 @@ package body System.Tasking.Queuing is end loop; else - -- FIFO Queuing + -- FIFO Queuing case for J in Open_Accepts'Range loop Temp_Entry := Open_Accepts (J).S; @@ -599,10 +609,7 @@ package body System.Tasking.Queuing is end loop; end if; - if Entry_Call = null then - Selection := No_Rendezvous; - - else + if Entry_Call /= null then Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call); -- Guard is open @@ -620,12 +627,11 @@ package body System.Tasking.Queuing is Entry_Call : Entry_Call_Link) is Caller : Task_ID; - begin Caller := Entry_Call.Self; Entry_Call.Exception_To_Raise := Program_Error'Identity; Write_Lock (Caller); - Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); Unlock (Caller); end Send_Program_Error; diff --git a/gcc/ada/s-tasque.ads b/gcc/ada/s-tasque.ads index 9ee56095c0e..c6de5c02262 100644 --- a/gcc/ada/s-tasque.ads +++ b/gcc/ada/s-tasque.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.21 $ +-- $Revision$ -- -- --- Copyright (C) 1991-1998 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). -- -- -- ------------------------------------------------------------------------------ @@ -43,11 +42,13 @@ package System.Tasking.Queuing is procedure Broadcast_Program_Error (Self_ID : Task_ID; Object : POE.Protection_Entries_Access; - Pending_Call : Entry_Call_Link); - -- Raise Program_Error in all tasks calling the protected entries - -- of Object. The exception will not be raised immediately for - -- the calling task; it will be deferred until it calls - -- Raise_Pending_Exception. + Pending_Call : Entry_Call_Link; + RTS_Locked : Boolean := False); + -- Raise Program_Error in all tasks calling the protected entries of Object + -- The exception will not be raised immediately for the calling task; it + -- will be deferred until it calls Check_Exception. + -- RTS_Locked indicates whether the global RTS lock is taken (only + -- relevant if Single_Lock is True). procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link); -- Enqueue Call at the end of entry_queue E diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index 516cee0fd2e..9bc84b663b5 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.101 $ +-- $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). -- -- -- ------------------------------------------------------------------------------ @@ -79,14 +78,23 @@ with System.Tasking.Protected_Objects.Operations; with System.Tasking.Debug; -- used for Trace +with System.Parameters; +-- used for Single_Lock +-- Runtime_Traces + +with System.Traces.Tasking; +-- used for Send_Trace_Info + package body System.Tasking.Rendezvous is package STPO renames System.Task_Primitives.Operations; - package POO renames System.Tasking.Protected_Objects.Operations; - package POE renames System.Tasking.Protected_Objects.Entries; + package POO renames Protected_Objects.Operations; + package POE renames Protected_Objects.Entries; - use System.Task_Primitives; - use System.Task_Primitives.Operations; + use Parameters; + use Task_Primitives.Operations; + use System.Traces; + use System.Traces.Tasking; type Select_Treatment is ( Accept_Alternative_Selected, -- alternative with non-null body @@ -138,12 +146,10 @@ package body System.Tasking.Rendezvous is -- means either the user is trying to do a potentially blocking -- operation from within a protected object, or there is a -- runtime system/compiler error that has failed to undefer - -- an earlier abort deferral. Thus, for debugging it may be + -- an earlier abort deferral. Thus, for debugging it may be -- wise to modify the above renamings to the non-nestable forms. - procedure Boost_Priority - (Call : Entry_Call_Link; - Acceptor : Task_ID); + procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_ID); pragma Inline (Boost_Priority); -- Call this only with abort deferred and holding lock of Acceptor. @@ -174,36 +180,13 @@ package body System.Tasking.Rendezvous is pragma Inline (Wait_For_Call); -- Call this only with abort deferred and holding lock of Self_Id. -- An accepting task goes into Sleep by calling this routine - -- waiting for a call from the caller or waiting for an abortion. + -- waiting for a call from the caller or waiting for an abort. -- Make sure Self_Id is locked before calling this routine. ----------------- -- Accept_Call -- ----------------- - -- Compiler interface only. Do not call from within the RTS. - - -- source: - -- accept E do ...A... end E; - -- expansion: - -- A27b : address; - -- L26b : label - -- begin - -- accept_call (1, A27b); - -- ...A... - -- complete_rendezvous; - -- <<L26b>> - -- exception - -- when all others => - -- exceptional_complete_rendezvous (get_gnat_exception); - -- end; - - -- The handler for Abort_Signal (*all* others) is to handle the case when - -- the acceptor is aborted between Accept_Call and the corresponding - -- Complete_Rendezvous call. We need to wake up the caller in this case. - - -- See also Selective_Wait - procedure Accept_Call (E : Task_Entry_Index; Uninterpreted_Data : out System.Address) @@ -216,6 +199,10 @@ package body System.Tasking.Rendezvous is begin Initialization.Defer_Abort (Self_Id); + if Single_Lock then + Lock_RTS; + end if; + STPO.Write_Lock (Self_Id); if not Self_Id.Callable then @@ -224,6 +211,11 @@ package body System.Tasking.Rendezvous is pragma Assert (Self_Id.Pending_Action); STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + Initialization.Undefer_Abort (Self_Id); -- Should never get here ??? @@ -232,17 +224,6 @@ package body System.Tasking.Rendezvous is raise Standard'Abort_Signal; end if; - -- If someone completed this task, this task should not try to - -- access its pending entry calls or queues in this case, as they - -- are being emptied. Wait for abortion to kill us. - -- ????? - -- Recheck the correctness of the above, now that we have made - -- changes. The logic above seems to be based on the assumption - -- that one task can safely clean up another's in-service accepts. - -- ????? - -- Why do we need to block here in this case? - -- Why not just return and let Undefer_Abort do its work? - Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); if Entry_Call /= null then @@ -259,60 +240,60 @@ package body System.Tasking.Rendezvous is -- Wait for normal call + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length)); + end if; + pragma Debug (Debug.Trace (Self_Id, "Accept_Call: wait", 'R')); Wait_For_Call (Self_Id); pragma Assert (Self_Id.Open_Accepts = null); - if Self_Id.Pending_ATC_Level >= Self_Id.ATC_Nesting_Level then + if Self_Id.Common.Call /= null then Caller := Self_Id.Common.Call.Self; Uninterpreted_Data := Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data; - end if; - - -- If this task has been aborted, skip the Uninterpreted_Data load - -- (Caller will not be reliable) and fall through to - -- Undefer_Abort which will allow the task to be killed. - -- ????? - -- Perhaps we could do the code anyway, if it has no harm, in order - -- to get better performance for the normal case. + else + -- Case of an aborted task. + Uninterpreted_Data := System.Null_Address; + end if; end if; -- Self_Id.Common.Call should already be updated by the Caller -- On return, we will start the rendezvous. STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + Initialization.Undefer_Abort (Self_Id); + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Accept_Complete, Caller, Entry_Index (E)); + end if; end Accept_Call; -------------------- -- Accept_Trivial -- -------------------- - -- Compiler interface only. Do not call from within the RTS. - -- This should only be called when there is no accept body, - -- or the except body is empty. - - -- source: - -- accept E; - -- expansion: - -- accept_trivial (1); - - -- The compiler is also able to recognize the following and - -- translate it the same way. - - -- accept E do null; end E; - procedure Accept_Trivial (E : Task_Entry_Index) is - Self_Id : constant Task_ID := STPO.Self; - Caller : Task_ID := null; - Open_Accepts : aliased Accept_List (1 .. 1); - Entry_Call : Entry_Call_Link; + Self_Id : constant Task_ID := STPO.Self; + Caller : Task_ID := null; + Open_Accepts : aliased Accept_List (1 .. 1); + Entry_Call : Entry_Call_Link; begin Initialization.Defer_Abort_Nestable (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + STPO.Write_Lock (Self_Id); if not Self_Id.Callable then @@ -321,6 +302,11 @@ package body System.Tasking.Rendezvous is pragma Assert (Self_Id.Pending_Action); STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + Initialization.Undefer_Abort_Nestable (Self_Id); -- Should never get here ??? @@ -329,23 +315,19 @@ package body System.Tasking.Rendezvous is raise Standard'Abort_Signal; end if; - -- If someone completed this task, this task should not try to - -- access its pending entry calls or queues in this case, as they - -- are being emptied. Wait for abortion to kill us. - -- ????? - -- Recheck the correctness of the above, now that we have made - -- changes. - Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); if Entry_Call = null then - -- Need to wait for entry call Open_Accepts (1).Null_Body := True; Open_Accepts (1).S := E; Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access; + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length)); + end if; + pragma Debug (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R')); @@ -359,7 +341,6 @@ package body System.Tasking.Rendezvous is STPO.Unlock (Self_Id); else -- found caller already waiting - pragma Assert (Entry_Call.State < Done); STPO.Unlock (Self_Id); @@ -370,6 +351,19 @@ package body System.Tasking.Rendezvous is STPO.Unlock (Caller); end if; + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Accept_Complete); + + -- Fake one, since there is (???) no way + -- to know that the rendezvous is over + + Send_Trace_Info (M_RDV_Complete); + end if; + + if Single_Lock then + Unlock_RTS; + end if; + Initialization.Undefer_Abort_Nestable (Self_Id); end Accept_Trivial; @@ -377,10 +371,8 @@ package body System.Tasking.Rendezvous is -- Boost_Priority -- -------------------- - -- Call this only with abort deferred and holding lock of Acceptor. - procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_ID) is - Caller : Task_ID := Call.Self; + Caller : constant Task_ID := Call.Self; Caller_Prio : System.Any_Priority := Get_Priority (Caller); Acceptor_Prio : System.Any_Priority := Get_Priority (Acceptor); @@ -398,8 +390,6 @@ package body System.Tasking.Rendezvous is -- Call_Simple -- ----------------- - -- Compiler interface only. Do not call from within the RTS. - procedure Call_Simple (Acceptor : Task_ID; E : Task_Entry_Index; @@ -415,8 +405,7 @@ package body System.Tasking.Rendezvous is -- Call_Synchronous -- ---------------------- - -- Compiler interface. - -- Also called from inside Call_Simple and Task_Entry_Call. + -- Called from Call_Simple and Task_Entry_Call. procedure Call_Synchronous (Acceptor : Task_ID; @@ -443,6 +432,10 @@ package body System.Tasking.Rendezvous is Entry_Call.Mode := Mode; Entry_Call.Cancellation_Attempted := False; + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Call, Acceptor, Entry_Index (E)); + end if; + -- If this is a call made inside of an abort deferred region, -- the call should be never abortable. @@ -458,12 +451,25 @@ package body System.Tasking.Rendezvous is Entry_Call.Called_Task := Acceptor; Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; - -- Note: the caller will undefer abortion on return (see WARNING above) + -- Note: the caller will undefer abort on return (see WARNING above) + + if Single_Lock then + Lock_RTS; + end if; if not Task_Do_Or_Queue (Self_Id, Entry_Call, With_Abort => True) then Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1; + + if Single_Lock then + Unlock_RTS; + end if; + + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Missed, Acceptor); + end if; + Initialization.Undefer_Abort (Self_Id); pragma Debug (Debug.Trace (Self_Id, "CS: exited to ATC level: " & @@ -474,11 +480,16 @@ package body System.Tasking.Rendezvous is STPO.Write_Lock (Self_Id); pragma Debug (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R')); - Entry_Calls.Wait_For_Completion (Self_Id, Entry_Call); + Entry_Calls.Wait_For_Completion (Entry_Call); pragma Debug (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R')); Rendezvous_Successful := Entry_Call.State = Done; STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + Local_Undefer_Abort (Self_Id); Entry_Calls.Check_Exception (Self_Id, Entry_Call); end Call_Synchronous; @@ -487,19 +498,25 @@ package body System.Tasking.Rendezvous is -- Callable -- -------------- - -- Compiler interface. - -- Do not call from within the RTS, - -- except for body of Ada.Task_Identification. - function Callable (T : Task_ID) return Boolean is Result : Boolean; Self_Id : constant Task_ID := STPO.Self; begin Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + STPO.Write_Lock (T); Result := T.Callable; STPO.Unlock (T); + + if Single_Lock then + Unlock_RTS; + end if; + Initialization.Undefer_Abort (Self_Id); return Result; end Callable; @@ -508,9 +525,6 @@ package body System.Tasking.Rendezvous is -- Cancel_Task_Entry_Call -- ---------------------------- - -- Compiler interface only. Do not call from within the RTS. - -- Call only with abort deferred. - procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is begin Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled); @@ -520,8 +534,6 @@ package body System.Tasking.Rendezvous is -- Complete_Rendezvous -- ------------------------- - -- See comments for Exceptional_Complete_Rendezvous. - procedure Complete_Rendezvous is begin Exceptional_Complete_Rendezvous (Ada.Exceptions.Null_Id); @@ -531,22 +543,6 @@ package body System.Tasking.Rendezvous is -- Exceptional_Complete_Rendezvous -- ------------------------------------- - -- Compiler interface. - -- Also called from Complete_Rendezvous. - -- ????? - -- Consider phasing out Complete_Rendezvous in favor - -- of direct call to this with Ada.Exceptions.Null_ID. - -- See code expansion examples for Accept_Call and Selective_Wait. - -- ????? - -- If we don't change the interface, consider instead - -- putting an explicit re-raise after this call, in - -- the generated code. That way we could eliminate the - -- code here that reraises the exception. - - -- The deferral level is critical here, - -- since we want to raise an exception or allow abort to take - -- place, if there is an exception or abort pending. - procedure Exceptional_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id) is @@ -565,12 +561,28 @@ package body System.Tasking.Rendezvous is use type STPE.Protection_Entries_Access; begin + -- Consider phasing out Complete_Rendezvous in favor + -- of direct call to this with Ada.Exceptions.Null_ID. + -- See code expansion examples for Accept_Call and Selective_Wait. + -- Also consider putting an explicit re-raise after this call, in + -- the generated code. That way we could eliminate the + -- code here that reraises the exception. + + -- The deferral level is critical here, + -- since we want to raise an exception or allow abort to take + -- place, if there is an exception or abort pending. + pragma Debug (Debug.Trace (Self_Id, "Exceptional_Complete_Rendezvous", 'R')); if Ex = Ada.Exceptions.Null_Id then -- The call came from normal end-of-rendezvous, -- so abort is not yet deferred. + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); + end if; + Initialization.Defer_Abort_Nestable (Self_Id); end if; @@ -578,6 +590,10 @@ package body System.Tasking.Rendezvous is -- been serving when it was aborted. if Ex = Standard'Abort_Signal'Identity then + if Single_Lock then + Lock_RTS; + end if; + while Entry_Call /= null loop Entry_Call.Exception_To_Raise := Tasking_Error'Identity; @@ -593,12 +609,15 @@ package body System.Tasking.Rendezvous is -- Complete the call abnormally, with exception. STPO.Write_Lock (Caller); - Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); STPO.Unlock (Caller); Entry_Call := Entry_Call.Acceptor_Prev_Call; end loop; + if Single_Lock then + Unlock_RTS; + end if; + else Caller := Entry_Call.Self; @@ -612,13 +631,25 @@ package body System.Tasking.Rendezvous is if Entry_Call.Called_Task /= null then -- Requeue to another task entry + if Single_Lock then + Lock_RTS; + end if; + if not Task_Do_Or_Queue (Self_Id, Entry_Call, Entry_Call.Requeue_With_Abort) then + if Single_Lock then + Lock_RTS; + end if; + Initialization.Undefer_Abort (Self_Id); raise Tasking_Error; end if; + if Single_Lock then + Unlock_RTS; + end if; + else -- Requeue to a protected entry @@ -630,11 +661,20 @@ package body System.Tasking.Rendezvous is Exception_To_Raise := Program_Error'Identity; Entry_Call.Exception_To_Raise := Exception_To_Raise; + + if Single_Lock then + Lock_RTS; + end if; + STPO.Write_Lock (Caller); Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); STPO.Unlock (Caller); + if Single_Lock then + Unlock_RTS; + end if; + else POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call, @@ -644,14 +684,19 @@ package body System.Tasking.Rendezvous is end if; end if; - Entry_Calls.Reset_Priority (Entry_Call.Acceptor_Prev_Priority, - Self_Id); + Entry_Calls.Reset_Priority + (Self_Id, Entry_Call.Acceptor_Prev_Priority); else -- The call does not need to be requeued. Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call; Entry_Call.Exception_To_Raise := Ex; + + if Single_Lock then + Lock_RTS; + end if; + STPO.Write_Lock (Caller); -- Done with Caller locked to make sure that Wakeup is not lost. @@ -664,8 +709,13 @@ package body System.Tasking.Rendezvous is Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); STPO.Unlock (Caller); - Entry_Calls.Reset_Priority (Entry_Call.Acceptor_Prev_Priority, - Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Entry_Calls.Reset_Priority + (Self_Id, Entry_Call.Acceptor_Prev_Priority); end if; end if; @@ -675,10 +725,8 @@ package body System.Tasking.Rendezvous is Internal_Reraise; end if; - -- ????? - -- Do we need to - -- give precedence to Program_Error that might be raised - -- due to failure of finalization, over Tasking_Error from + -- ??? Do we need to give precedence to Program_Error that might be + -- raised due to failure of finalization, over Tasking_Error from -- failure of requeue? end Exceptional_Complete_Rendezvous; @@ -710,43 +758,6 @@ package body System.Tasking.Rendezvous is -- Requeue_Protected_To_Task_Entry -- ------------------------------------- - -- Compiler interface only. Do not call from within the RTS. - - -- entry e2 when b is - -- begin - -- b := false; - -- ...A... - -- requeue t.e2; - -- end e2; - - -- procedure rPT__E14b (O : address; P : address; E : - -- protected_entry_index) is - -- type rTVP is access rTV; - -- freeze rTVP [] - -- _object : rTVP := rTVP!(O); - -- begin - -- declare - -- rR : protection renames _object._object; - -- vP : integer renames _object.v; - -- bP : boolean renames _object.b; - -- begin - -- b := false; - -- ...A... - -- requeue_protected_to_task_entry (rR'unchecked_access, tTV!(t). - -- _task_id, 2, false); - -- return; - -- end; - -- complete_entry_body (_object._object'unchecked_access, objectF => - -- 0); - -- return; - -- exception - -- when others => - -- abort_undefer.all; - -- exceptional_complete_entry_body (_object._object' - -- unchecked_access, current_exception, objectF => 0); - -- return; - -- end rPT__E14b; - procedure Requeue_Protected_To_Task_Entry (Object : STPE.Protection_Entries_Access; Acceptor : Task_ID; @@ -768,41 +779,13 @@ package body System.Tasking.Rendezvous is -- Requeue_Task_Entry -- ------------------------ - -- Compiler interface only. Do not call from within the RTS. - -- The code generation for task entry requeues is different from that - -- for protected entry requeues. There is a "goto" that skips around - -- the call to Complete_Rendezous, so that Requeue_Task_Entry must also - -- do the work of Complete_Rendezvous. The difference is that it does - -- not report that the call's State = Done. - - -- accept e1 do - -- ...A... - -- requeue e2; - -- ...B... - -- end e1; - - -- A62b : address; - -- L61b : label - -- begin - -- accept_call (1, A62b); - -- ...A... - -- requeue_task_entry (tTV!(t)._task_id, 2, false); - -- goto L61b; - -- ...B... - -- complete_rendezvous; - -- <<L61b>> - -- exception - -- when others => - -- exceptional_complete_rendezvous (current_exception); - -- end; - procedure Requeue_Task_Entry (Acceptor : Task_ID; E : Task_Entry_Index; With_Abort : Boolean) is - Self_Id : constant Task_ID := STPO.Self; - Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call; + Self_Id : constant Task_ID := STPO.Self; + Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call; begin Initialization.Defer_Abort (Self_Id); @@ -817,71 +800,6 @@ package body System.Tasking.Rendezvous is -- Selective_Wait -- -------------------- - -- Compiler interface only. Do not call from within the RTS. - -- See comments on Accept_Call. - - -- source code: - - -- select accept e1 do - -- ...A... - -- end e1; - -- ...B... - -- or accept e2; - -- ...C... - -- end select; - - -- expansion: - - -- A32b : address; - -- declare - -- null; - -- if accept_alternative'size * 2 >= 16#8000_0000# then - -- raise storage_error; - -- end if; - -- A37b : T36b; - -- A37b (1) := (null_body => false, s => 1); - -- A37b (2) := (null_body => true, s => 2); - -- if accept_alternative'size * 2 >= 16#8000_0000# then - -- raise storage_error; - -- end if; - -- S0 : aliased T36b := accept_list'A37b; - -- J1 : select_index := 0; - -- L3 : label - -- L1 : label - -- L2 : label - -- procedure e1A is - -- begin - -- abort_undefer.all; - -- L31b : label - -- ...A... - -- <<L31b>> - -- complete_rendezvous; - -- exception - -- when all others => - -- exceptional_complete_rendezvous (get_gnat_exception); - -- end e1A; - -- begin - -- selective_wait (S0'unchecked_access, simple_mode, A32b, J1); - -- case J1 is - -- when 0 => - -- goto L3; - -- when 1 => - -- e1A; - -- goto L1; - -- when 2 => - -- goto L2; - -- when others => - -- goto L3; - -- end case; - -- <<L1>> - -- ...B... - -- goto L3; - -- <<L2>> - -- ...C... - -- goto L3; - -- <<L3>> - -- end; - procedure Selective_Wait (Open_Accepts : Accept_List_Access; Select_Mode : Select_Modes; @@ -897,6 +815,11 @@ package body System.Tasking.Rendezvous is begin Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + STPO.Write_Lock (Self_Id); if not Self_Id.Callable then @@ -906,8 +829,12 @@ package body System.Tasking.Rendezvous is STPO.Unlock (Self_Id); - -- ??? In some cases abort is deferred more than once. Need to figure - -- out why. + if Single_Lock then + Unlock_RTS; + end if; + + -- ??? In some cases abort is deferred more than once. Need to + -- figure out why this happens. Self_Id.Deferral_Level := 1; @@ -919,15 +846,10 @@ package body System.Tasking.Rendezvous is raise Standard'Abort_Signal; end if; - -- If someone completed this task, this task should not try to - -- access its pending entry calls or queues in this case, as they - -- are being emptied. Wait for abortion to kill us. - -- ????? - -- Recheck the correctness of the above, now that we have made - -- changes. - pragma Assert (Open_Accepts /= null); + Uninterpreted_Data := Null_Address; + Queuing.Select_Task_Entry_Call (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); @@ -940,7 +862,6 @@ package body System.Tasking.Rendezvous is if Entry_Call /= null then if Open_Accepts (Selection).Null_Body then Treatment := Accept_Alternative_Completed; - else Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); Treatment := Accept_Alternative_Selected; @@ -953,195 +874,194 @@ package body System.Tasking.Rendezvous is end if; end if; - -- ?????? - -- Recheck the logic above against the ARM. - -- Handle the select according to the disposition selected above. case Treatment is + when Accept_Alternative_Selected => + -- Ready to rendezvous - when Accept_Alternative_Selected => - - -- Ready to rendezvous - - Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; - - -- In this case the accept body is not Null_Body. Defer abortion - -- until it gets into the accept body. - - pragma Assert (Self_Id.Deferral_Level = 1); + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; - Initialization.Defer_Abort_Nestable (Self_Id); - STPO.Unlock (Self_Id); + -- In this case the accept body is not Null_Body. Defer abort + -- until it gets into the accept body. - when Accept_Alternative_Completed => + pragma Assert (Self_Id.Deferral_Level = 1); - -- Accept body is null, so rendezvous is over immediately. + Initialization.Defer_Abort_Nestable (Self_Id); + STPO.Unlock (Self_Id); - STPO.Unlock (Self_Id); - Caller := Entry_Call.Self; + when Accept_Alternative_Completed => + -- Accept body is null, so rendezvous is over immediately. - STPO.Write_Lock (Caller); - Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); - STPO.Unlock (Caller); - - when Accept_Alternative_Open => + if Parameters.Runtime_Traces then + Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); + end if; - -- Wait for caller. + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; - Self_Id.Open_Accepts := Open_Accepts; - pragma Debug - (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R')); - Wait_For_Call (Self_Id); + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); - pragma Assert (Self_Id.Open_Accepts = null); + when Accept_Alternative_Open => + -- Wait for caller. - -- Self_Id.Common.Call should already be updated by the Caller if - -- not aborted. It might also be ready to do rendezvous even if - -- this wakes up due to an abortion. - -- Therefore, if the call is not empty we need to do the rendezvous - -- if the accept body is not Null_Body. + Self_Id.Open_Accepts := Open_Accepts; + pragma Debug + (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R')); - -- ????? - -- aren't the first two conditions below redundant? + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Select, Self_Id, + Integer (Open_Accepts'Length)); + end if; - if Self_Id.Chosen_Index /= No_Rendezvous and then - Self_Id.Common.Call /= null and then - not Open_Accepts (Self_Id.Chosen_Index).Null_Body - then - Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + Wait_For_Call (Self_Id); - pragma Assert (Self_Id.Deferral_Level = 1); + pragma Assert (Self_Id.Open_Accepts = null); - Initialization.Defer_Abort_Nestable (Self_Id); + -- Self_Id.Common.Call should already be updated by the Caller if + -- not aborted. It might also be ready to do rendezvous even if + -- this wakes up due to an abortion. + -- Therefore, if the call is not empty we need to do the + -- rendezvous if the accept body is not Null_Body. - -- Leave abort deferred until the accept body - end if; + -- Aren't the first two conditions below redundant??? - STPO.Unlock (Self_Id); + if Self_Id.Chosen_Index /= No_Rendezvous + and then Self_Id.Common.Call /= null + and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; - when Else_Selected => - pragma Assert (Self_Id.Open_Accepts = null); + pragma Assert (Self_Id.Deferral_Level = 1); - STPO.Unlock (Self_Id); + Initialization.Defer_Abort_Nestable (Self_Id); - when Terminate_Selected => + -- Leave abort deferred until the accept body + end if; - -- Terminate alternative is open + STPO.Unlock (Self_Id); - Self_Id.Open_Accepts := Open_Accepts; - Self_Id.Common.State := Acceptor_Sleep; - STPO.Unlock (Self_Id); + when Else_Selected => + pragma Assert (Self_Id.Open_Accepts = null); - -- ????? - -- We need to check if a signal is pending on an open interrupt - -- entry. Otherwise this task would become potentially terminatable - -- and, if none of the siblings are active - -- any more, the task could not wake up any more, even though a - -- signal might be pending on an open interrupt entry. - -- ------------- - -- This comment paragraph does not make sense. Is it obsolete? - -- There was no code here to check for pending signals. + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Select_Else); + end if; - -- Notify ancestors that this task is on a terminate alternative. + STPO.Unlock (Self_Id); - Utilities.Make_Passive (Self_Id, Task_Completed => False); + when Terminate_Selected => + -- Terminate alternative is open - -- Wait for normal entry call or termination + Self_Id.Open_Accepts := Open_Accepts; + Self_Id.Common.State := Acceptor_Sleep; + STPO.Unlock (Self_Id); - pragma Assert (Self_Id.ATC_Nesting_Level = 1); + -- Notify ancestors that this task is on a terminate alternative. - STPO.Write_Lock (Self_Id); + Utilities.Make_Passive (Self_Id, Task_Completed => False); - loop - Initialization.Poll_Base_Priority_Change (Self_Id); - exit when Self_Id.Open_Accepts = null; - Sleep (Self_Id, Acceptor_Sleep); - end loop; + -- Wait for normal entry call or termination - Self_Id.Common.State := Runnable; + pragma Assert (Self_Id.ATC_Nesting_Level = 1); - pragma Assert (Self_Id.Open_Accepts = null); + STPO.Write_Lock (Self_Id); - if Self_Id.Terminate_Alternative then + loop + Initialization.Poll_Base_Priority_Change (Self_Id); + exit when Self_Id.Open_Accepts = null; + Sleep (Self_Id, Acceptor_Sleep); + end loop; - -- An entry call should have reset this to False, - -- so we must be aborted. - -- We cannot be in an async. select, since that - -- is not legal, so the abort must be of the entire - -- task. Therefore, we do not need to cancel the - -- terminate alternative. The cleanup will be done - -- in Complete_Master. + Self_Id.Common.State := Runnable; - pragma Assert (Self_Id.Pending_ATC_Level = 0); + pragma Assert (Self_Id.Open_Accepts = null); - pragma Assert (Self_Id.Awake_Count = 0); + if Self_Id.Terminate_Alternative then + -- An entry call should have reset this to False, + -- so we must be aborted. + -- We cannot be in an async. select, since that + -- is not legal, so the abort must be of the entire + -- task. Therefore, we do not need to cancel the + -- terminate alternative. The cleanup will be done + -- in Complete_Master. - -- Trust that it is OK to fall through. + pragma Assert (Self_Id.Pending_ATC_Level = 0); + pragma Assert (Self_Id.Awake_Count = 0); - null; + -- Trust that it is OK to fall through. + null; - else - -- Self_Id.Common.Call and Self_Id.Chosen_Index - -- should already be updated by the Caller. + else + -- Self_Id.Common.Call and Self_Id.Chosen_Index + -- should already be updated by the Caller. - if Self_Id.Chosen_Index /= No_Rendezvous - and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body - then - Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + if Self_Id.Chosen_Index /= No_Rendezvous + and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; - pragma Assert (Self_Id.Deferral_Level = 1); + pragma Assert (Self_Id.Deferral_Level = 1); - -- We need an extra defer here, to keep abort - -- deferred until we get into the accept body + -- We need an extra defer here, to keep abort + -- deferred until we get into the accept body - Initialization.Defer_Abort_Nestable (Self_Id); + Initialization.Defer_Abort_Nestable (Self_Id); + end if; end if; - end if; - STPO.Unlock (Self_Id); + STPO.Unlock (Self_Id); - when No_Alternative_Open => + when No_Alternative_Open => + -- In this case, Index will be No_Rendezvous on return, which + -- should cause a Program_Error if it is not a Delay_Mode. - -- In this case, Index will be No_Rendezvous on return, which - -- should cause a Program_Error if it is not a Delay_Mode. + -- If delay alternative exists (Delay_Mode) we should suspend + -- until the delay expires. - -- If delay alternative exists (Delay_Mode) we should suspend - -- until the delay expires. + Self_Id.Open_Accepts := null; - Self_Id.Open_Accepts := null; + if Select_Mode = Delay_Mode then + Self_Id.Common.State := Delay_Sleep; - if Select_Mode = Delay_Mode then - Self_Id.Common.State := Delay_Sleep; + loop + Initialization.Poll_Base_Priority_Change (Self_Id); + exit when + Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level; + Sleep (Self_Id, Delay_Sleep); + end loop; - loop - Initialization.Poll_Base_Priority_Change (Self_Id); - exit when Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level; - Sleep (Self_Id, Delay_Sleep); - end loop; + Self_Id.Common.State := Runnable; + STPO.Unlock (Self_Id); - Self_Id.Common.State := Runnable; - STPO.Unlock (Self_Id); + else + STPO.Unlock (Self_Id); - else - STPO.Unlock (Self_Id); - Initialization.Undefer_Abort (Self_Id); - Ada.Exceptions.Raise_Exception (Program_Error'Identity, - "Entry call not a delay mode"); - end if; + if Single_Lock then + Unlock_RTS; + end if; + Initialization.Undefer_Abort (Self_Id); + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "Entry call not a delay mode"); + end if; end case; + if Single_Lock then + Unlock_RTS; + end if; + -- Caller has been chosen. -- Self_Id.Common.Call should already be updated by the Caller. -- Self_Id.Chosen_Index should either be updated by the Caller -- or by Test_Selective_Wait. -- On return, we sill start rendezvous unless the accept body is - -- null. In the latter case, we will have already completed the RV. + -- null. In the latter case, we will have already completed the RV. Index := Self_Id.Chosen_Index; Initialization.Undefer_Abort_Nestable (Self_Id); - end Selective_Wait; ------------------------------------ @@ -1152,8 +1072,7 @@ package body System.Tasking.Rendezvous is procedure Setup_For_Rendezvous_With_Body (Entry_Call : Entry_Call_Link; - Acceptor : Task_ID) - is + Acceptor : Task_ID) is begin Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call; Acceptor.Common.Call := Entry_Call; @@ -1169,17 +1088,25 @@ package body System.Tasking.Rendezvous is -- Task_Count -- ---------------- - -- Compiler interface only. Do not call from within the RTS. - function Task_Count (E : Task_Entry_Index) return Natural is Self_Id : constant Task_ID := STPO.Self; Return_Count : Natural; begin Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + STPO.Write_Lock (Self_Id); Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E)); STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + Initialization.Undefer_Abort (Self_Id); return Return_Count; end Task_Count; @@ -1188,56 +1115,45 @@ package body System.Tasking.Rendezvous is -- Task_Do_Or_Queue -- ---------------------- - -- Call this only with abort deferred and holding no locks. - -- May propagate an exception, including Abort_Signal & Tasking_Error. - -- ????? - -- See Check_Callable. Check all call contexts to verify - -- it is OK to raise an exception. - - -- Find out whether Entry_Call can be accepted immediately. - -- If the Acceptor is not callable, raise Tasking_Error. - -- If the rendezvous can start, initiate it. - -- If the accept-body is trivial, also complete the rendezvous. - -- If the acceptor is not ready, enqueue the call. - - -- ????? - -- This should have a special case for Accept_Call and - -- Accept_Trivial, so that - -- we don't have the loop setup overhead, below. - - -- ????? - -- The call state Done is used here and elsewhere to include - -- both the case of normal successful completion, and the case - -- of an exception being raised. The difference is that if an - -- exception is raised no one will pay attention to the fact - -- that State = Done. Instead the exception will be raised in - -- Undefer_Abort, and control will skip past the place where - -- we normally would resume from an entry call. - function Task_Do_Or_Queue (Self_ID : Task_ID; Entry_Call : Entry_Call_Link; With_Abort : Boolean) return Boolean is - E : constant Task_Entry_Index := Task_Entry_Index (Entry_Call.E); - Old_State : constant Entry_Call_State := Entry_Call.State; - Acceptor : constant Task_ID := Entry_Call.Called_Task; - Parent : constant Task_ID := Acceptor.Common.Parent; + E : constant Task_Entry_Index := + Task_Entry_Index (Entry_Call.E); + Old_State : constant Entry_Call_State := Entry_Call.State; + Acceptor : constant Task_ID := Entry_Call.Called_Task; + Parent : constant Task_ID := Acceptor.Common.Parent; Parent_Locked : Boolean := False; - Null_Body : Boolean; + Null_Body : Boolean; begin + -- Find out whether Entry_Call can be accepted immediately. + -- If the Acceptor is not callable, return False. + -- If the rendezvous can start, initiate it. + -- If the accept-body is trivial, also complete the rendezvous. + -- If the acceptor is not ready, enqueue the call. + + -- This should have a special case for Accept_Call and Accept_Trivial, + -- so that we don't have the loop setup overhead, below. + + -- The call state Done is used here and elsewhere to include both the + -- case of normal successful completion, and the case of an exception + -- being raised. The difference is that if an exception is raised no one + -- will pay attention to the fact that State = Done. Instead the + -- exception will be raised in Undefer_Abort, and control will skip past + -- the place where we normally would resume from an entry call. + pragma Assert (not Queuing.Onqueue (Entry_Call)); - -- We rely that the call is off-queue for protection, - -- that the caller will not exit the Entry_Caller_Sleep, - -- and so will not reuse the call record for another call. + -- We rely that the call is off-queue for protection, that the caller + -- will not exit the Entry_Caller_Sleep, and so will not reuse the call + -- record for another call. -- We rely on the Caller's lock for call State mod's. -- We can't lock Acceptor.Parent while holding Acceptor, -- so lock it in advance if we expect to need to lock it. - -- ????? - -- Is there some better solution? if Acceptor.Terminate_Alternative then STPO.Write_Lock (Parent); @@ -1246,18 +1162,13 @@ package body System.Tasking.Rendezvous is STPO.Write_Lock (Acceptor); - -- If the acceptor is not callable, abort the call - -- and raise Tasking_Error. The call is not aborted - -- for an asynchronous call, since Cancel_Task_Entry_Call - -- will do the cancelation in that case. - -- ????? ..... - -- Does the above still make sense? + -- If the acceptor is not callable, abort the call and return False. if not Acceptor.Callable then STPO.Unlock (Acceptor); if Parent_Locked then - STPO.Unlock (Acceptor.Common.Parent); + STPO.Unlock (Parent); end if; pragma Assert (Entry_Call.State < Done); @@ -1269,6 +1180,7 @@ package body System.Tasking.Rendezvous is Entry_Call.Exception_To_Raise := Tasking_Error'Identity; Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); STPO.Unlock (Entry_Call.Self); + return False; end if; @@ -1291,7 +1203,6 @@ package body System.Tasking.Rendezvous is end if; if Acceptor.Terminate_Alternative then - -- Cancel terminate alternative. -- See matching code in Selective_Wait and -- Vulnerable_Complete_Master. @@ -1307,8 +1218,8 @@ package body System.Tasking.Rendezvous is Parent.Awake_Count := Parent.Awake_Count + 1; - if Parent.Common.State = Master_Completion_Sleep and then - Acceptor.Master_of_Task = Parent.Master_Within + if Parent.Common.State = Master_Completion_Sleep + and then Acceptor.Master_of_Task = Parent.Master_Within then Parent.Common.Wait_Count := Parent.Common.Wait_Count + 1; @@ -1317,7 +1228,6 @@ package body System.Tasking.Rendezvous is end if; if Null_Body then - -- Rendezvous is over immediately. STPO.Wakeup (Acceptor, Acceptor_Sleep); @@ -1379,13 +1289,12 @@ package body System.Tasking.Rendezvous is STPO.Unlock (Parent); end if; - if Old_State /= Entry_Call.State and then - Entry_Call.State = Now_Abortable and then - Entry_Call.Mode > Simple_Call and then - - -- Asynchronous_Call or Conditional_Call + if Old_State /= Entry_Call.State + and then Entry_Call.State = Now_Abortable + and then Entry_Call.Mode > Simple_Call + and then Entry_Call.Self /= Self_ID - Entry_Call.Self /= Self_ID + -- Asynchronous_Call or Conditional_Call then -- Because of ATCB lock ordering rule @@ -1437,6 +1346,10 @@ package body System.Tasking.Rendezvous is Entry_Call : Entry_Call_Link; begin + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Call, Acceptor, Entry_Index (E)); + end if; + if Mode = Simple_Call or else Mode = Conditional_Call then Call_Synchronous (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful); @@ -1466,6 +1379,10 @@ package body System.Tasking.Rendezvous is Entry_Call.Called_PO := Null_Address; Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + if Single_Lock then + Lock_RTS; + end if; + if not Task_Do_Or_Queue (Self_Id, Entry_Call, With_Abort => True) then @@ -1473,7 +1390,17 @@ package body System.Tasking.Rendezvous is pragma Debug (Debug.Trace (Self_Id, "TEC: exited to ATC level: " & ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + + if Single_Lock then + Unlock_RTS; + end if; + Initialization.Undefer_Abort (Self_Id); + + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Missed, Acceptor); + end if; + raise Tasking_Error; end if; @@ -1488,6 +1415,10 @@ package body System.Tasking.Rendezvous is Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call); end if; + if Single_Lock then + Unlock_RTS; + end if; + -- Note: following assignment needs to be atomic. Rendezvous_Successful := Entry_Call.State = Done; @@ -1498,14 +1429,13 @@ package body System.Tasking.Rendezvous is -- Task_Entry_Caller -- ----------------------- - -- Compiler interface only. - function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_ID is Self_Id : constant Task_ID := STPO.Self; Entry_Call : Entry_Call_Link; begin Entry_Call := Self_Id.Common.Call; + for Depth in 1 .. D loop Entry_Call := Entry_Call.Acceptor_Prev_Call; pragma Assert (Entry_Call /= null); @@ -1518,8 +1448,6 @@ package body System.Tasking.Rendezvous is -- Timed_Selective_Wait -- -------------------------- - -- Compiler interface only. Do not call from within the RTS. - procedure Timed_Selective_Wait (Open_Accepts : Accept_List_Access; Select_Mode : Select_Modes; @@ -1535,7 +1463,8 @@ package body System.Tasking.Rendezvous is Selection : Select_Index; Open_Alternative : Boolean; Timedout : Boolean := False; - Yielded : Boolean := False; + Yielded : Boolean := True; + begin pragma Assert (Select_Mode = Delay_Mode); @@ -1543,6 +1472,10 @@ package body System.Tasking.Rendezvous is -- If we are aborted here, the effect will be pending + if Single_Lock then + Lock_RTS; + end if; + STPO.Write_Lock (Self_Id); if not Self_Id.Callable then @@ -1551,6 +1484,11 @@ package body System.Tasking.Rendezvous is pragma Assert (Self_Id.Pending_Action); STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + Initialization.Undefer_Abort (Self_Id); -- Should never get here ??? @@ -1559,12 +1497,7 @@ package body System.Tasking.Rendezvous is raise Standard'Abort_Signal; end if; - -- If someone completed this task, this task should not try to - -- access its pending entry calls or queues in this case, as they - -- are being emptied. Wait for abortion to kill us. - -- ????? - -- Recheck the correctness of the above, now that we have made - -- changes. + Uninterpreted_Data := Null_Address; pragma Assert (Open_Accepts /= null); @@ -1596,115 +1529,124 @@ package body System.Tasking.Rendezvous is -- Handle the select according to the disposition selected above. case Treatment is + when Accept_Alternative_Selected => + -- Ready to rendezvous + -- In this case the accept body is not Null_Body. Defer abort + -- until it gets into the accept body. - when Accept_Alternative_Selected => - - -- Ready to rendezvous - -- In this case the accept body is not Null_Body. Defer abortion - -- until it gets into the accept body. - - Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; - Initialization.Defer_Abort (Self_Id); - STPO.Unlock (Self_Id); - - when Accept_Alternative_Completed => + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + Initialization.Defer_Abort (Self_Id); + STPO.Unlock (Self_Id); - -- Rendezvous is over + when Accept_Alternative_Completed => + -- Rendezvous is over - STPO.Unlock (Self_Id); - Caller := Entry_Call.Self; + if Parameters.Runtime_Traces then + Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); + end if; - STPO.Write_Lock (Caller); - Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); - STPO.Unlock (Caller); + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; - when Accept_Alternative_Open => + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); - -- Wait for caller. + when Accept_Alternative_Open => + -- Wait for caller. - Self_Id.Open_Accepts := Open_Accepts; + Self_Id.Open_Accepts := Open_Accepts; - -- Wait for a normal call and a pending action until the - -- Wakeup_Time is reached. + -- Wait for a normal call and a pending action until the + -- Wakeup_Time is reached. - Self_Id.Common.State := Acceptor_Sleep; + Self_Id.Common.State := Acceptor_Sleep; - loop - Initialization.Poll_Base_Priority_Change (Self_Id); - exit when Self_Id.Open_Accepts = null; + loop + Initialization.Poll_Base_Priority_Change (Self_Id); + exit when Self_Id.Open_Accepts = null; - if Timedout then - Sleep (Self_Id, Acceptor_Sleep); - else - STPO.Timed_Sleep (Self_Id, Timeout, Mode, - Acceptor_Sleep, Timedout, Yielded); - end if; + if Timedout then + Sleep (Self_Id, Acceptor_Sleep); + else + if Parameters.Runtime_Traces then + Send_Trace_Info (WT_Select, + Self_Id, + Integer (Open_Accepts'Length), + Timeout); + end if; - if Timedout then - Self_Id.Open_Accepts := null; - end if; - end loop; + STPO.Timed_Sleep (Self_Id, Timeout, Mode, + Acceptor_Sleep, Timedout, Yielded); + end if; - Self_Id.Common.State := Runnable; + if Timedout then + Self_Id.Open_Accepts := null; - -- Self_Id.Common.Call should already be updated by the Caller if - -- not aborted. It might also be ready to do rendezvous even if - -- this wakes up due to an abortion. - -- Therefore, if the call is not empty we need to do the rendezvous - -- if the accept body is not Null_Body. + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Timeout); + end if; + end if; + end loop; - if Self_Id.Chosen_Index /= No_Rendezvous and then - Self_Id.Common.Call /= null and then - not Open_Accepts (Self_Id.Chosen_Index).Null_Body - then - Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + Self_Id.Common.State := Runnable; - pragma Assert (Self_Id.Deferral_Level = 1); + -- Self_Id.Common.Call should already be updated by the Caller if + -- not aborted. It might also be ready to do rendezvous even if + -- this wakes up due to an abortion. + -- Therefore, if the call is not empty we need to do the + -- rendezvous if the accept body is not Null_Body. - Initialization.Defer_Abort_Nestable (Self_Id); + if Self_Id.Chosen_Index /= No_Rendezvous + and then Self_Id.Common.Call /= null + and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; - -- Leave abort deferred until the accept body + pragma Assert (Self_Id.Deferral_Level = 1); - end if; + Initialization.Defer_Abort_Nestable (Self_Id); - STPO.Unlock (Self_Id); - if not Yielded then - Yield; - end if; + -- Leave abort deferred until the accept body + end if; - when No_Alternative_Open => + STPO.Unlock (Self_Id); - -- In this case, Index will be No_Rendezvous on return. We sleep - -- for the time we need to. - -- Wait for a signal or timeout. A wakeup can be made - -- for several reasons: - -- 1) Delay is expired - -- 2) Pending_Action needs to be checked - -- (Abortion, Priority change) - -- 3) Spurious wakeup + when No_Alternative_Open => + -- In this case, Index will be No_Rendezvous on return. We sleep + -- for the time we need to. + -- Wait for a signal or timeout. A wakeup can be made + -- for several reasons: + -- 1) Delay is expired + -- 2) Pending_Action needs to be checked + -- (Abortion, Priority change) + -- 3) Spurious wakeup - Self_Id.Open_Accepts := null; - Self_Id.Common.State := Acceptor_Sleep; + Self_Id.Open_Accepts := null; + Self_Id.Common.State := Acceptor_Sleep; - Initialization.Poll_Base_Priority_Change (Self_Id); + Initialization.Poll_Base_Priority_Change (Self_Id); - STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep, - Timedout, Yielded); + STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep, + Timedout, Yielded); - Self_Id.Common.State := Runnable; + Self_Id.Common.State := Runnable; - STPO.Unlock (Self_Id); + STPO.Unlock (Self_Id); - if not Yielded then - Yield; - end if; + when others => + -- Should never get here + pragma Assert (False); + null; + end case; - when others => - -- Should never get here ??? + if Single_Lock then + Unlock_RTS; + end if; - pragma Assert (False); - null; - end case; + if not Yielded then + Yield; + end if; -- Caller has been chosen @@ -1717,15 +1659,12 @@ package body System.Tasking.Rendezvous is Initialization.Undefer_Abort_Nestable (Self_Id); -- Start rendezvous, if not already completed - end Timed_Selective_Wait; --------------------------- -- Timed_Task_Entry_Call -- --------------------------- - -- Compiler interface only. Do not call from within the RTS. - procedure Timed_Task_Entry_Call (Acceptor : Task_ID; E : Task_Entry_Index; @@ -1737,6 +1676,7 @@ package body System.Tasking.Rendezvous is Self_Id : constant Task_ID := STPO.Self; Level : ATC_Level; Entry_Call : Entry_Call_Link; + Yielded : Boolean; begin Initialization.Defer_Abort (Self_Id); @@ -1746,6 +1686,11 @@ package body System.Tasking.Rendezvous is (Debug.Trace (Self_Id, "TTEC: entered ATC level: " & ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + if Parameters.Runtime_Traces then + Send_Trace_Info (WT_Call, Acceptor, + Entry_Index (E), Timeout); + end if; + Level := Self_Id.ATC_Nesting_Level; Entry_Call := Self_Id.Entry_Calls (Level)'Access; Entry_Call.Next := null; @@ -1770,6 +1715,10 @@ package body System.Tasking.Rendezvous is -- Note: the caller will undefer abortion on return (see WARNING above) + if Single_Lock then + Lock_RTS; + end if; + if not Task_Do_Or_Queue (Self_Id, Entry_Call, With_Abort => True) then @@ -1779,12 +1728,29 @@ package body System.Tasking.Rendezvous is (Debug.Trace (Self_Id, "TTEC: exited to ATC level: " & ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + if Single_Lock then + Unlock_RTS; + end if; + Initialization.Undefer_Abort (Self_Id); + + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Missed, Acceptor); + end if; raise Tasking_Error; end if; + Write_Lock (Self_Id); Entry_Calls.Wait_For_Completion_With_Timeout - (Self_Id, Entry_Call, Timeout, Mode); + (Entry_Call, Timeout, Mode, Yielded); + Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + -- ??? Do we need to yield in case Yielded is False + Rendezvous_Successful := Entry_Call.State = Done; Initialization.Undefer_Abort (Self_Id); Entry_Calls.Check_Exception (Self_Id, Entry_Call); diff --git a/gcc/ada/s-tasren.ads b/gcc/ada/s-tasren.ads index 97c21428b58..7bdeb97bbd7 100644 --- a/gcc/ada/s-tasren.ads +++ b/gcc/ada/s-tasren.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.26 $ -- +-- $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- -- @@ -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). -- -- -- ------------------------------------------------------------------------------ @@ -44,8 +43,6 @@ with System.Tasking.Protected_Objects.Entries; -- used for Protection_Entries package System.Tasking.Rendezvous is - -- This interface is described in the document - -- Gnu Ada Runtime Library Interface (GNARLI). package STPE renames System.Tasking.Protected_Objects.Entries; @@ -55,7 +52,15 @@ package System.Tasking.Rendezvous is Uninterpreted_Data : System.Address; Mode : Call_Modes; Rendezvous_Successful : out Boolean); - -- General entry call + -- General entry call used to implement ATC or conditional entry calls. + -- Compiler interface only. Do not call from within the RTS. + -- Acceptor is the ID of the acceptor task. + -- E is the entry index requested. + -- Uninterpreted_Data represents the parameters of the entry. It is + -- constructed by the compiler for the caller and the callee; therefore, + -- the run time never needs to decode this data. + -- Mode can be either Asynchronous_Call (ATC) or Conditional_Call. + -- Rendezvous_Successful is set to True on return if the call was serviced. procedure Timed_Task_Entry_Call (Acceptor : Task_ID; @@ -65,33 +70,174 @@ package System.Tasking.Rendezvous is Mode : Delay_Modes; Rendezvous_Successful : out Boolean); -- Timed entry call without using ATC. + -- Compiler interface only. Do not call from within the RTS. + -- See Task_Entry_Call for details on Acceptor, E and Uninterpreted_Data. + -- Timeout is the value of the time out. + -- Mode determines whether the delay is relative or absolute. procedure Call_Simple (Acceptor : Task_ID; E : Task_Entry_Index; Uninterpreted_Data : System.Address); - -- Simple entry call + -- Simple entry call. + -- Compiler interface only. Do not call from within the RTS. + -- + -- source: + -- T.E1 (Params); + -- + -- expansion: + -- declare + -- P : parms := (parm1, parm2, parm3); + -- X : Task_Entry_Index := 1; + -- begin + -- Call_Simple (t._task_id, X, P'Address); + -- parm1 := P.param1; + -- parm2 := P.param2; + -- ... + -- end; procedure Cancel_Task_Entry_Call (Cancelled : out Boolean); - -- Cancel pending task entry call + -- Cancel pending asynchronous task entry call. + -- Compiler interface only. Do not call from within the RTS. + -- See Exp_Ch9.Expand_N_Asynchronous_Select for code expansion. procedure Requeue_Task_Entry (Acceptor : Task_ID; E : Task_Entry_Index; With_Abort : Boolean); + -- Requeue from a task entry to a task entry. + -- Compiler interface only. Do not call from within the RTS. + -- The code generation for task entry requeues is different from that for + -- protected entry requeues. There is a "goto" that skips around the call + -- to Complete_Rendezvous, so that Requeue_Task_Entry must also do the work + -- of Complete_Rendezvous. The difference is that it does not report that + -- the call's State = Done. + -- + -- source: + -- accept e1 do + -- ...A... + -- requeue e2; + -- ...B... + -- end e1; + -- + -- expansion: + -- A62b : address; + -- L61b : label + -- begin + -- accept_call (1, A62b); + -- ...A... + -- requeue_task_entry (tTV!(t)._task_id, 2, false); + -- goto L61b; + -- ...B... + -- complete_rendezvous; + -- <<L61b>> + -- exception + -- when others => + -- exceptional_complete_rendezvous (current_exception); + -- end; procedure Requeue_Protected_To_Task_Entry (Object : STPE.Protection_Entries_Access; Acceptor : Task_ID; E : Task_Entry_Index; With_Abort : Boolean); + -- Requeue from a protected entry to a task entry. + -- Compiler interface only. Do not call from within the RTS. + -- + -- source: + -- entry e2 when b is + -- begin + -- b := false; + -- ...A... + -- requeue t.e2; + -- end e2; + -- + -- expansion: + -- procedure rPT__E14b (O : address; P : address; E : + -- protected_entry_index) is + -- type rTVP is access rTV; + -- freeze rTVP [] + -- _object : rTVP := rTVP!(O); + -- begin + -- declare + -- rR : protection renames _object._object; + -- vP : integer renames _object.v; + -- bP : boolean renames _object.b; + -- begin + -- b := false; + -- ...A... + -- requeue_protected_to_task_entry (rR'unchecked_access, tTV!(t). + -- _task_id, 2, false); + -- return; + -- end; + -- complete_entry_body (_object._object'unchecked_access, objectF => + -- 0); + -- return; + -- exception + -- when others => + -- abort_undefer.all; + -- exceptional_complete_entry_body (_object._object' + -- unchecked_access, current_exception, objectF => 0); + -- return; + -- end rPT__E14b; procedure Selective_Wait (Open_Accepts : Accept_List_Access; Select_Mode : Select_Modes; Uninterpreted_Data : out System.Address; Index : out Select_Index); - -- Selective wait + -- Implement select statement. + -- Compiler interface only. Do not call from within the RTS. + -- See comments on Accept_Call. + -- + -- source: + -- select accept e1 do + -- ...A... + -- end e1; + -- ...B... + -- or accept e2; + -- ...C... + -- end select; + -- + -- expansion: + -- A32b : address; + -- declare + -- A37b : T36b; + -- A37b (1) := (null_body => false, s => 1); + -- A37b (2) := (null_body => true, s => 2); + -- S0 : aliased T36b := accept_list'A37b; + -- J1 : select_index := 0; + -- procedure e1A is + -- begin + -- abort_undefer.all; + -- ...A... + -- <<L31b>> + -- complete_rendezvous; + -- exception + -- when all others => + -- exceptional_complete_rendezvous (get_gnat_exception); + -- end e1A; + -- begin + -- selective_wait (S0'unchecked_access, simple_mode, A32b, J1); + -- case J1 is + -- when 0 => + -- goto L3; + -- when 1 => + -- e1A; + -- goto L1; + -- when 2 => + -- goto L2; + -- when others => + -- goto L3; + -- end case; + -- <<L1>> + -- ...B... + -- goto L3; + -- <<L2>> + -- ...C... + -- goto L3; + -- <<L3>> + -- end; procedure Timed_Selective_Wait (Open_Accepts : Accept_List_Access; @@ -101,28 +247,67 @@ package System.Tasking.Rendezvous is Mode : Delay_Modes; Index : out Select_Index); -- Selective wait with timeout without using ATC. + -- Compiler interface only. Do not call from within the RTS. procedure Accept_Call (E : Task_Entry_Index; Uninterpreted_Data : out System.Address); - -- Accept an entry call + -- Accept an entry call. + -- Compiler interface only. Do not call from within the RTS. + -- + -- source: + -- accept E do ...A... end E; + -- expansion: + -- A27b : address; + -- L26b : label + -- begin + -- accept_call (1, A27b); + -- ...A... + -- complete_rendezvous; + -- <<L26b>> + -- exception + -- when all others => + -- exceptional_complete_rendezvous (get_gnat_exception); + -- end; + -- + -- The handler for Abort_Signal (*all* others) is to handle the case when + -- the acceptor is aborted between Accept_Call and the corresponding + -- Complete_Rendezvous call. We need to wake up the caller in this case. + -- + -- See also Selective_Wait procedure Accept_Trivial (E : Task_Entry_Index); - -- Accept an entry call that has no parameters and no body + -- Accept an entry call that has no parameters and no body. + -- Compiler interface only. Do not call from within the RTS. + -- This should only be called when there is no accept body, or the accept + -- body is empty. + -- + -- source: + -- accept E; + -- expansion: + -- accept_trivial (1); + -- + -- The compiler is also able to recognize the following and + -- translate it the same way. + -- + -- accept E do null; end E; function Task_Count (E : Task_Entry_Index) return Natural; -- Return number of tasks waiting on the entry E (of current task) + -- Compiler interface only. Do not call from within the RTS. function Callable (T : Task_ID) return Boolean; - -- Return T'CALLABLE + -- Return T'Callable + -- Compiler interface. Do not call from within the RTS, except for body of + -- Ada.Task_Identification. type Task_Entry_Nesting_Depth is new Task_Entry_Index range 0 .. Max_Task_Entry; function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_ID; - -- Return E'Caller. This will only work if called from within an - -- accept statement that is handling E, as required by the - -- LRM (C.7.1(14)). + -- Return E'Caller. This will only work if called from within an + -- accept statement that is handling E, as required by the LRM (C.7.1(14)). + -- Compiler interface only. Do not call from within the RTS. procedure Complete_Rendezvous; -- Called by acceptor to wake up caller @@ -138,13 +323,14 @@ package System.Tasking.Rendezvous is (Self_ID : Task_ID; Entry_Call : Entry_Call_Link; With_Abort : Boolean) return Boolean; - -- Call this only with abort deferred and holding lock of Acceptor. + -- Call this only with abort deferred and holding no locks, except + -- the global RTS lock when Single_Lock is True which must be owned. -- Returns False iff the call cannot be served or queued, as is the -- case if the caller is not callable; i.e., a False return value -- indicates that Tasking_Error should be raised. -- Either initiate the entry call, such that the accepting task is -- free to execute the rendezvous, queue the call on the acceptor's - -- queue, or cancel the call. Conditional calls that cannot be + -- queue, or cancel the call. Conditional calls that cannot be -- accepted immediately are cancelled. end System.Tasking.Rendezvous; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 9fe7f891b95..1d99b0e3db2 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -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). -- -- -- ------------------------------------------------------------------------------ @@ -50,6 +49,8 @@ with System.Address_Image; with System.Parameters; -- used for Size_Type +-- Single_Lock +-- Runtime_Traces with System.Task_Info; -- used for Task_Info_Type @@ -63,7 +64,7 @@ with System.Task_Primitives.Operations; -- Sleep -- Wakeup -- Get_Priority --- Lock/Unlock_All_Tasks_List +-- Lock/Unlock_RTS -- New_ATCB with System.Soft_Links; @@ -112,6 +113,9 @@ with System.Storage_Elements; with System.Standard_Library; -- used for Exception_Trace +with System.Traces.Tasking; +-- used for Send_Trace_Info + package body System.Tasking.Stages is package STPO renames System.Task_Primitives.Operations; @@ -121,23 +125,13 @@ package body System.Tasking.Stages is use Ada.Exceptions; - use System.Task_Primitives; - use System.Task_Primitives.Operations; - use System.Task_Info; - - procedure Wakeup_Entry_Caller - (Self_ID : Task_ID; - Entry_Call : Entry_Call_Link; - New_State : Entry_Call_State) - renames Initialization.Wakeup_Entry_Caller; + use Parameters; + use Task_Primitives; + use Task_Primitives.Operations; + use Task_Info; - procedure Cancel_Queued_Entry_Calls (T : Task_ID) - renames Utilities.Cancel_Queued_Entry_Calls; - - procedure Abort_One_Task - (Self_ID : Task_ID; - T : Task_ID) - renames Utilities.Abort_One_Task; + use System.Traces; + use System.Traces.Tasking; ----------------------- -- Local Subprograms -- @@ -171,11 +165,12 @@ package body System.Tasking.Stages is -- Signal to Self_ID's activator that Self_ID has -- completed activation. -- - -- Does not defer abortion (unlike Complete_Activation). + -- Call this procedure with abort deferred. procedure Abort_Dependents (Self_ID : Task_ID); - -- Abort all the dependents of Self at our current master - -- nesting level. + -- Abort all the direct dependents of Self at its current master + -- nesting level, plus all of their dependents, transitively. + -- RTS_Lock should be locked by the caller. procedure Vulnerable_Free_Task (T : Task_ID); -- Recover all runtime system storage associated with the task T. @@ -199,29 +194,24 @@ package body System.Tasking.Stages is -- Abort_Dependents -- ---------------------- - -- Abort all the direct dependents of Self at its current master - -- nesting level, plus all of their dependents, transitively. - -- No locks should be held when this routine is called. - procedure Abort_Dependents (Self_ID : Task_ID) is C : Task_ID; P : Task_ID; begin - Lock_All_Tasks_List; - C := All_Tasks_List; + while C /= null loop P := C.Common.Parent; + while P /= null loop if P = Self_ID then - -- ??? C is supposed to take care of its own dependents, so - -- there should be no need to take worry about them. Need to - -- double check this. + -- there should be no need to worry about them. Need to double + -- check this. if C.Master_of_Task = Self_ID.Master_Within then - Abort_One_Task (Self_ID, C); + Utilities.Abort_One_Task (Self_ID, C); C.Dependents_Aborted := True; end if; @@ -235,7 +225,6 @@ package body System.Tasking.Stages is end loop; Self_ID.Dependents_Aborted := True; - Unlock_All_Tasks_List; end Abort_Dependents; ----------------- @@ -258,7 +247,7 @@ package body System.Tasking.Stages is -- task. That satisfies our in-order-of-creation ATCB locking policy. -- At one point, we may also lock the parent, if the parent is - -- different from the activator. That is also consistent with the + -- different from the activator. That is also consistent with the -- lock ordering policy, since the activator cannot be created -- before the parent. @@ -268,15 +257,13 @@ package body System.Tasking.Stages is -- the counts until we see that the thread creation is successful. -- If the thread creation fails, we do need to close the entries - -- of the task. The first phase, of dequeuing calls, only requires + -- of the task. The first phase, of dequeuing calls, only requires -- locking the acceptor's ATCB, but the waking up of the callers - -- requires locking the caller's ATCB. We cannot safely do this - -- while we are holding other locks. Therefore, the queue-clearing + -- requires locking the caller's ATCB. We cannot safely do this + -- while we are holding other locks. Therefore, the queue-clearing -- operation is done in a separate pass over the activation chain. - procedure Activate_Tasks - (Chain_Access : Activation_Chain_Access) - is + procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is Self_ID : constant Task_ID := STPO.Self; P : Task_ID; C : Task_ID; @@ -293,21 +280,16 @@ package body System.Tasking.Stages is pragma Assert (Self_ID.Common.Wait_Count = 0); - -- Lock All_Tasks_L, to prevent activated tasks + -- Lock RTS_Lock, to prevent activated tasks -- from racing ahead before we finish activating the chain. - -- ????? - -- Is there some less heavy-handed way? - -- In an earlier version, we used the activator's lock here, - -- but that violated the locking order rule when we had - -- to lock the parent later. - - Lock_All_Tasks_List; + Lock_RTS; -- Check that all task bodies have been elaborated. C := Chain_Access.T_ID; Last_C := null; + while C /= null loop if C.Common.Elaborated /= null and then not C.Common.Elaborated.all @@ -327,7 +309,7 @@ package body System.Tasking.Stages is Chain_Access.T_ID := Last_C; if not All_Elaborated then - Unlock_All_Tasks_List; + Unlock_RTS; Initialization.Undefer_Abort_Nestable (Self_ID); Raise_Exception (Program_Error'Identity, "Some tasks have not been elaborated"); @@ -338,6 +320,7 @@ package body System.Tasking.Stages is -- activation. So create it now. C := Chain_Access.T_ID; + while C /= null loop if C.Common.State /= Terminated then pragma Assert (C.Common.State = Unactivated); @@ -360,7 +343,7 @@ package body System.Tasking.Stages is -- There would be a race between the created task and -- the creator to do the following initialization, - -- if we did not have a Lock/Unlock_All_Tasks_List pair + -- if we did not have a Lock/Unlock_RTS pair -- in the task wrapper, to prevent it from racing ahead. if Success then @@ -393,7 +376,9 @@ package body System.Tasking.Stages is C := C.Common.Activation_Link; end loop; - Unlock_All_Tasks_List; + if not Single_Lock then + Unlock_RTS; + end if; -- Close the entries of any tasks that failed thread creation, -- and count those that have not finished activation. @@ -409,7 +394,7 @@ package body System.Tasking.Stages is C.Common.Activator := null; C.Common.State := Terminated; C.Callable := False; - Cancel_Queued_Entry_Calls (C); + Utilities.Cancel_Queued_Entry_Calls (C); elsif C.Common.Activator /= null then Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; @@ -434,6 +419,10 @@ package body System.Tasking.Stages is Self_ID.Common.State := Runnable; Unlock (Self_ID); + if Single_Lock then + Unlock_RTS; + end if; + -- Remove the tasks from the chain. Chain_Access.T_ID := null; @@ -452,15 +441,27 @@ package body System.Tasking.Stages is procedure Complete_Activation is Self_ID : constant Task_ID := STPO.Self; - begin Initialization.Defer_Abort_Nestable (Self_ID); + + if Single_Lock then + Lock_RTS; + end if; + Vulnerable_Complete_Activation (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + Initialization.Undefer_Abort_Nestable (Self_ID); - -- ????? + -- ??? -- Why do we need to allow for nested deferral here? + if Runtime_Traces then + Send_Trace_Info (T_Activate); + end if; end Complete_Activation; --------------------- @@ -484,7 +485,6 @@ package body System.Tasking.Stages is procedure Complete_Task is Self_ID : constant Task_ID := STPO.Self; - begin pragma Assert (Self_ID.Deferral_Level > 0); @@ -492,7 +492,6 @@ package body System.Tasking.Stages is -- All of our dependents have terminated. -- Never undefer abort again! - end Complete_Task; ----------------- @@ -552,11 +551,11 @@ package body System.Tasking.Stages is Raise_Exception (Storage_Error'Identity, "Cannot allocate task"); end; - -- All_Tasks_L is used by Abort_Dependents and Abort_Tasks. + -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. -- Up to this point, it is possible that we may be part of -- a family of tasks that is being aborted. - Lock_All_Tasks_List; + Lock_RTS; Write_Lock (Self_ID); -- Now, we must check that we have not been aborted. @@ -570,7 +569,7 @@ package body System.Tasking.Stages is or else Chain.T_ID.Common.State = Unactivated); Unlock (Self_ID); - Unlock_All_Tasks_List; + Unlock_RTS; Initialization.Undefer_Abort_Nestable (Self_ID); -- ??? Should never get here @@ -584,7 +583,7 @@ package body System.Tasking.Stages is if not Success then Unlock (Self_ID); - Unlock_All_Tasks_List; + Unlock_RTS; Initialization.Undefer_Abort_Nestable (Self_ID); Raise_Exception (Storage_Error'Identity, "Failed to initialize task"); @@ -600,7 +599,7 @@ package body System.Tasking.Stages is T.Common.Task_Image := Task_Image; Unlock (Self_ID); - Unlock_All_Tasks_List; + Unlock_RTS; -- Create TSD as early as possible in the creation of a task, since it -- may be used by the operation of Ada code within the task. @@ -611,6 +610,10 @@ package body System.Tasking.Stages is Initialization.Initialize_Attributes_Link.all (T); Created_Task := T; Initialization.Undefer_Abort_Nestable (Self_ID); + + if Runtime_Traces then + Send_Trace_Info (T_Create, T); + end if; end Create_Task; -------------------- @@ -618,10 +621,8 @@ package body System.Tasking.Stages is -------------------- function Current_Master return Master_Level is - Self_ID : constant Task_ID := STPO.Self; - begin - return Self_ID.Master_Within; + return STPO.Self.Master_Within; end Current_Master; ------------------ @@ -653,10 +654,10 @@ package body System.Tasking.Stages is Initialization.Defer_Abort_Nestable (Self_ID); - -- ???? + -- ??? -- Experimentation has shown that abort is sometimes (but not -- always) already deferred when this is called. - -- That may indicate an error. Find out what is going on. + -- That may indicate an error. Find out what is going on. C := Chain.T_ID; @@ -666,6 +667,7 @@ package body System.Tasking.Stages is Temp := C.Common.Activation_Link; if C.Common.State = Unactivated then + Lock_RTS; Write_Lock (C); for J in 1 .. C.Entry_Num loop @@ -674,7 +676,10 @@ package body System.Tasking.Stages is end loop; Unlock (C); + Initialization.Remove_From_All_Tasks_List (C); + Unlock_RTS; + Vulnerable_Free_Task (C); C := Temp; end if; @@ -688,7 +693,7 @@ package body System.Tasking.Stages is -- Finalize_Global_Tasks -- --------------------------- - -- ???? + -- ??? -- We have a potential problem here if finalization of global -- objects does anything with signals or the timer server, since -- by that time those servers have terminated. @@ -699,13 +704,12 @@ package body System.Tasking.Stages is -- using the global finalization chain. procedure Finalize_Global_Tasks is - Self_ID : constant Task_ID := STPO.Self; - Zero_Independent : Boolean; + Self_ID : constant Task_ID := STPO.Self; + Ignore : Boolean; begin if Self_ID.Deferral_Level = 0 then - - -- ?????? + -- ??? -- In principle, we should be able to predict whether -- abort is already deferred here (and it should not be deferred -- yet but in practice it seems Finalize_Global_Tasks is being @@ -715,7 +719,6 @@ package body System.Tasking.Stages is Initialization.Defer_Abort_Nestable (Self_ID); -- Never undefer again!!! - end if; -- This code is only executed by the environment task @@ -733,30 +736,45 @@ package body System.Tasking.Stages is -- Force termination of "independent" library-level server tasks. + Lock_RTS; + Abort_Dependents (Self_ID); + if not Single_Lock then + Unlock_RTS; + end if; + -- We need to explicitly wait for the task to be -- terminated here because on true concurrent system, we -- may end this procedure before the tasks are really -- terminated. + Write_Lock (Self_ID); + loop - Write_Lock (Self_ID); - Zero_Independent := Utilities.Independent_Task_Count = 0; - Unlock (Self_ID); + exit when Utilities.Independent_Task_Count = 0; -- We used to yield here, but this did not take into account -- low priority tasks that would cause dead lock in some cases. -- See 8126-020. - Timed_Delay (Self_ID, 0.01, System.OS_Primitives.Relative); - exit when Zero_Independent; + Timed_Sleep + (Self_ID, 0.01, System.OS_Primitives.Relative, + Self_ID.Common.State, Ignore, Ignore); end loop; -- ??? On multi-processor environments, it seems that the above loop -- isn't sufficient, so we need to add an additional delay. - Timed_Delay (Self_ID, 0.1, System.OS_Primitives.Relative); + Timed_Sleep + (Self_ID, 0.01, System.OS_Primitives.Relative, + Self_ID.Common.State, Ignore, Ignore); + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; -- Complete the environment task. @@ -778,7 +796,8 @@ package body System.Tasking.Stages is SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access; -- Don't bother trying to finalize Initialization.Global_Task_Lock - -- and System.Task_Primitives.All_Tasks_L. + -- and System.Task_Primitives.RTS_Lock. + end Finalize_Global_Tasks; --------------- @@ -790,7 +809,6 @@ package body System.Tasking.Stages is begin if T.Common.State = Terminated then - -- It is not safe to call Abort_Defer or Write_Lock at this stage Initialization.Task_Lock (Self_Id); @@ -799,7 +817,10 @@ package body System.Tasking.Stages is Free_Task_Image (T.Common.Task_Image); end if; + Lock_RTS; Initialization.Remove_From_All_Tasks_List (T); + Unlock_RTS; + Initialization.Task_Unlock (Self_Id); System.Task_Primitives.Operations.Finalize_TCB (T); @@ -914,14 +935,14 @@ package body System.Tasking.Stages is Enter_Task (Self_ID); - -- We lock All_Tasks_L to wait for activator to finish activating + -- We lock RTS_Lock to wait for activator to finish activating -- the rest of the chain, so that everyone in the chain comes out -- in priority order. -- This also protects the value of -- Self_ID.Common.Activator.Common.Wait_Count. - Lock_All_Tasks_List; - Unlock_All_Tasks_List; + Lock_RTS; + Unlock_RTS; begin -- We are separating the following portion of the code in order to @@ -939,7 +960,6 @@ package body System.Tasking.Stages is -- allowed. Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg); - Terminate_Task (Self_ID); exception @@ -983,16 +1003,18 @@ package body System.Tasking.Stages is -- calls to Task_Lock and Task_Unlock. That was not really a solution, -- since the operation Task_Unlock continued to access the ATCB after -- unlocking, after which the parent was observed to race ahead, - -- deallocate the ATCB, and then reallocate it to another task. The + -- deallocate the ATCB, and then reallocate it to another task. The -- call to Undefer_Abortion in Task_Unlock by the "terminated" task was - -- overwriting the data of the new task that reused the ATCB! To solve + -- overwriting the data of the new task that reused the ATCB! To solve -- this problem, we introduced the new operation Final_Task_Unlock. procedure Terminate_Task (Self_ID : Task_ID) is Environment_Task : constant Task_ID := STPO.Environment_Task; begin - pragma Assert (Self_ID.Common.Activator = null); + if Runtime_Traces then + Send_Trace_Info (T_Terminate); + end if; -- Since GCC cannot allocate stack chunks efficiently without reordering -- some of the allocations, we have to handle this unexpected situation @@ -1003,23 +1025,38 @@ package body System.Tasking.Stages is Vulnerable_Complete_Task (Self_ID); end if; + Initialization.Task_Lock (Self_ID); + + if Single_Lock then + Lock_RTS; + end if; + -- Check if the current task is an independent task -- If so, decrement the Independent_Task_Count value. if Self_ID.Master_of_Task = 2 then - Write_Lock (Environment_Task); - Utilities.Independent_Task_Count := - Utilities.Independent_Task_Count - 1; - Unlock (Environment_Task); + if Single_Lock then + Utilities.Independent_Task_Count := + Utilities.Independent_Task_Count - 1; + + else + Write_Lock (Environment_Task); + Utilities.Independent_Task_Count := + Utilities.Independent_Task_Count - 1; + Unlock (Environment_Task); + end if; end if; -- Unprotect the guard page if needed. Stack_Guard (Self_ID, False); - Initialization.Task_Lock (Self_ID); Utilities.Make_Passive (Self_ID, Task_Completed => True); + if Single_Lock then + Unlock_RTS; + end if; + pragma Assert (Check_Exit (Self_ID)); SSL.Destroy_TSD (Self_ID.Common.Compiler_Data); @@ -1042,9 +1079,19 @@ package body System.Tasking.Stages is begin Initialization.Defer_Abort_Nestable (Self_ID); + + if Single_Lock then + Lock_RTS; + end if; + Write_Lock (T); Result := T.Common.State = Terminated; Unlock (T); + + if Single_Lock then + Unlock_RTS; + end if; + Initialization.Undefer_Abort_Nestable (Self_ID); return Result; end Terminated; @@ -1053,19 +1100,16 @@ package body System.Tasking.Stages is -- Vulnerable_Complete_Activation -- ------------------------------------ - -- Only call this procedure with abortion deferred. - -- As in several other places, the locks of the activator and activated - -- task are both locked here. This follows our deadlock prevention lock + -- task are both locked here. This follows our deadlock prevention lock -- ordering policy, since the activated task must be created after the -- activator. procedure Vulnerable_Complete_Activation (Self_ID : Task_ID) is - Activator : Task_ID := Self_ID.Common.Activator; + Activator : constant Task_ID := Self_ID.Common.Activator; begin - pragma Debug - (Debug.Trace (Self_ID, "V_Complete_Activation", 'C')); + pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C')); Write_Lock (Activator); Write_Lock (Self_ID); @@ -1102,7 +1146,7 @@ package body System.Tasking.Stages is Unlock (Activator); -- After the activation, active priority should be the same - -- as base priority. We must unlock the Activator first, + -- as base priority. We must unlock the Activator first, -- though, since it should not wait if we have lower priority. if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then @@ -1124,7 +1168,7 @@ package body System.Tasking.Stages is To_Be_Freed : Task_ID; -- This is a list of ATCBs to be freed, after we have released - -- all RTS locks. This is necessary because of the locking order + -- all RTS locks. This is necessary because of the locking order -- rules, since the storage manager uses Global_Task_Lock. pragma Warnings (Off); @@ -1133,9 +1177,16 @@ package body System.Tasking.Stages is -- Temporary error-checking code below. This is part of the checks -- added in the new run time. Call it only inside a pragma Assert. + ----------------------------- + -- Check_Unactivated_Tasks -- + ----------------------------- + function Check_Unactivated_Tasks return Boolean is begin - Lock_All_Tasks_List; + if not Single_Lock then + Lock_RTS; + end if; + Write_Lock (Self_ID); C := All_Tasks_List; @@ -1158,14 +1209,17 @@ package body System.Tasking.Stages is end loop; Unlock (Self_ID); - Unlock_All_Tasks_List; + + if not Single_Lock then + Unlock_RTS; + end if; + return True; end Check_Unactivated_Tasks; -- Start of processing for Vulnerable_Complete_Master begin - pragma Debug (Debug.Trace (Self_ID, "V_Complete_Master", 'C')); @@ -1179,7 +1233,7 @@ package body System.Tasking.Stages is -- zero for new tasks, and the task should not exit the -- sleep-loops that use this count until the count reaches zero. - Lock_All_Tasks_List; + Lock_RTS; Write_Lock (Self_ID); C := All_Tasks_List; @@ -1191,7 +1245,7 @@ package body System.Tasking.Stages is C.Common.Activator := null; C.Common.State := Terminated; C.Callable := False; - Cancel_Queued_Entry_Calls (C); + Utilities.Cancel_Queued_Entry_Calls (C); Unlock (C); end if; @@ -1210,7 +1264,10 @@ package body System.Tasking.Stages is Self_ID.Common.State := Master_Completion_Sleep; Unlock (Self_ID); - Unlock_All_Tasks_List; + + if not Single_Lock then + Unlock_RTS; + end if; -- Wait until dependent tasks are all terminated or ready to terminate. -- While waiting, the task may be awakened if the task's priority needs @@ -1219,6 +1276,7 @@ package body System.Tasking.Stages is -- to zero. Write_Lock (Self_ID); + loop Initialization.Poll_Base_Priority_Change (Self_ID); exit when Self_ID.Common.Wait_Count = 0; @@ -1228,10 +1286,15 @@ package body System.Tasking.Stages is if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level and then not Self_ID.Dependents_Aborted then - Unlock (Self_ID); - Abort_Dependents (Self_ID); - Write_Lock (Self_ID); - + if Single_Lock then + Abort_Dependents (Self_ID); + else + Unlock (Self_ID); + Lock_RTS; + Abort_Dependents (Self_ID); + Unlock_RTS; + Write_Lock (Self_ID); + end if; else Sleep (Self_ID, Master_Completion_Sleep); end if; @@ -1247,41 +1310,42 @@ package body System.Tasking.Stages is pragma Assert (Check_Unactivated_Tasks); if Self_ID.Alive_Count > 1 then - - -- ????? - -- Consider finding a way to skip the following extra steps if - -- there are no dependents with terminate alternatives. This - -- could be done by adding another count to the ATCB, similar to - -- Awake_Count, but keeping track of count of tasks that are on - -- terminate alternatives. + -- ??? + -- Consider finding a way to skip the following extra steps if there + -- are no dependents with terminate alternatives. This could be done + -- by adding another count to the ATCB, similar to Awake_Count, but + -- keeping track of tasks that are on terminate alternatives. pragma Assert (Self_ID.Common.Wait_Count = 0); -- Force any remaining dependents to terminate, by aborting them. + if not Single_Lock then + Lock_RTS; + end if; + Abort_Dependents (Self_ID); -- Above, when we "abort" the dependents we are simply using this -- operation for convenience. We are not required to support the full -- abort-statement semantics; in particular, we are not required to - -- immediately cancel any queued or in-service entry calls. That is + -- immediately cancel any queued or in-service entry calls. That is -- good, because if we tried to cancel a call we would need to lock - -- the caller, in order to wake the caller up. Our anti-deadlock + -- the caller, in order to wake the caller up. Our anti-deadlock -- rules prevent us from doing that without releasing the locks on C - -- and Self_ID. Releasing and retaking those locks would be - -- wasteful, at best, and should not be considered further without - -- more detailed analysis of potential concurrent accesses to the + -- and Self_ID. Releasing and retaking those locks would be wasteful + -- at best, and should not be considered further without more + -- detailed analysis of potential concurrent accesses to the -- ATCBs of C and Self_ID. -- Count how many "alive" dependent tasks this master currently - -- has, and record this in Wait_Count. - -- This count should start at zero, since it is initialized to - -- zero for new tasks, and the task should not exit the - -- sleep-loops that use this count until the count reaches zero. + -- has, and record this in Wait_Count. This count should start at + -- zero, since it is initialized to zero for new tasks, and the + -- task should not exit the sleep-loops that use this count until + -- the count reaches zero. pragma Assert (Self_ID.Common.Wait_Count = 0); - Lock_All_Tasks_List; Write_Lock (Self_ID); C := All_Tasks_List; @@ -1304,7 +1368,10 @@ package body System.Tasking.Stages is Self_ID.Common.State := Master_Phase_2_Sleep; Unlock (Self_ID); - Unlock_All_Tasks_List; + + if not Single_Lock then + Unlock_RTS; + end if; -- Wait for all counted tasks to finish terminating themselves. @@ -1322,9 +1389,6 @@ package body System.Tasking.Stages is -- We don't wake up for abortion here. We are already terminating -- just as fast as we can, so there is no point. - -- ???? - -- Consider whether we want to bother checking for priority - -- changes in the loop above, though. -- Remove terminated tasks from the list of Self_ID's dependents, but -- don't free their ATCBs yet, because of lock order restrictions, @@ -1332,7 +1396,10 @@ package body System.Tasking.Stages is -- other locks. Instead, we put those ATCBs to be freed onto a -- temporary list, called To_Be_Freed. - Lock_All_Tasks_List; + if not Single_Lock then + Lock_RTS; + end if; + C := All_Tasks_List; P := null; @@ -1355,7 +1422,7 @@ package body System.Tasking.Stages is end if; end loop; - Unlock_All_Tasks_List; + Unlock_RTS; -- Free all the ATCBs on the list To_Be_Freed. @@ -1377,7 +1444,7 @@ package body System.Tasking.Stages is -- otherwise occur during finalization of library-level objects. -- A better solution might be to hook task objects into the -- finalization chain and deallocate the ATCB when the task - -- object is deallocated. However, this change is not likely + -- object is deallocated. However, this change is not likely -- to gain anything significant, since all this storage should -- be recovered en-masse when the process exits. @@ -1390,14 +1457,16 @@ package body System.Tasking.Stages is if T.Interrupt_Entry and Interrupt_Manager_ID /= null then declare - Detach_Interrupt_Entries_Index : Task_Entry_Index := 6; + Detach_Interrupt_Entries_Index : Task_Entry_Index := 1; -- Corresponds to the entry index of System.Interrupts. -- Interrupt_Manager.Detach_Interrupt_Entries. -- Be sure to update this value when changing -- Interrupt_Manager specs. type Param_Type is access all Task_ID; + Param : aliased Param_Type := T'Access; + begin System.Tasking.Rendezvous.Call_Simple (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index, @@ -1423,25 +1492,22 @@ package body System.Tasking.Stages is end if; end loop; - -- It might seem nice to let the terminated task deallocate - -- its own ATCB. That would not cover the case of unactivated - -- tasks. It also would force us to keep the underlying thread - -- around past termination, since references to the ATCB are - -- possible past termination. Currently, we get rid of the - -- thread as soon as the task terminates, and let the parent - -- recover the ATCB later. + -- It might seem nice to let the terminated task deallocate its own + -- ATCB. That would not cover the case of unactivated tasks. It also + -- would force us to keep the underlying thread around past termination, + -- since references to the ATCB are possible past termination. + -- Currently, we get rid of the thread as soon as the task terminates, + -- and let the parent recover the ATCB later. - -- ???? -- Some day, if we want to recover the ATCB earlier, at task - -- termination, we could consider using "fat task IDs", that - -- include the serial number with the ATCB pointer, to catch - -- references to tasks that no longer have ATCBs. It is not - -- clear how much this would gain, since the user-level task - -- object would still be occupying storage. + -- termination, we could consider using "fat task IDs", that include the + -- serial number with the ATCB pointer, to catch references to tasks + -- that no longer have ATCBs. It is not clear how much this would gain, + -- since the user-level task object would still be occupying storage. -- Make next master level up active. - -- We don't need to lock the ATCB, since the value is only - -- updated by each task for itself. + -- We don't need to lock the ATCB, since the value is only updated by + -- each task for itself. Self_ID.Master_Within := CM - 1; end Vulnerable_Complete_Master; @@ -1450,11 +1516,11 @@ package body System.Tasking.Stages is -- Vulnerable_Complete_Task -- ------------------------------ - -- Complete the calling task. + -- Complete the calling task -- This procedure must be called with abort deferred. (That's why the -- name has "Vulnerable" in it.) It should only be called by Complete_Task - -- and Finalizate_Global_Tasks (for the environment task). + -- and Finalize_Global_Tasks (for the environment task). -- The effect is similar to that of Complete_Master. Differences include -- the closing of entries here, and computation of the number of active @@ -1476,24 +1542,31 @@ package body System.Tasking.Stages is pragma Assert (Self_ID.Open_Accepts = null); pragma Assert (Self_ID.ATC_Nesting_Level = 1); - pragma Debug - (Debug.Trace (Self_ID, "V_Complete_Task", 'C')); + pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C')); + + if Single_Lock then + Lock_RTS; + end if; Write_Lock (Self_ID); Self_ID.Callable := False; - -- In theory, Self should have no pending entry calls - -- left on its call-stack. Each async. select statement should - -- clean its own call, and blocking entry calls should - -- defer abort until the calls are cancelled, then clean up. + -- In theory, Self should have no pending entry calls left on its + -- call-stack. Each async. select statement should clean its own call, + -- and blocking entry calls should defer abort until the calls are + -- cancelled, then clean up. - Cancel_Queued_Entry_Calls (Self_ID); + Utilities.Cancel_Queued_Entry_Calls (Self_ID); Unlock (Self_ID); if Self_ID.Common.Activator /= null then Vulnerable_Complete_Activation (Self_ID); end if; + if Single_Lock then + Unlock_RTS; + end if; + -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2 -- we may have dependent tasks for which we need to wait. -- Otherwise, we can just exit. @@ -1501,7 +1574,6 @@ package body System.Tasking.Stages is if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then Vulnerable_Complete_Master (Self_ID); end if; - end Vulnerable_Complete_Task; -------------------------- @@ -1511,8 +1583,10 @@ package body System.Tasking.Stages is -- Recover all runtime system storage associated with the task T. -- This should only be called after T has terminated and will no -- longer be referenced. + -- For tasks created by an allocator that fails, due to an exception, -- it is called from Expunge_Unactivated_Tasks. + -- For tasks created by elaboration of task object declarations it -- is called from the finalization code of the Task_Wrapper procedure. -- It is also called from Unchecked_Deallocation, for objects that @@ -1523,12 +1597,22 @@ package body System.Tasking.Stages is pragma Debug (Debug.Trace ("Vulnerable_Free_Task", T, 'C')); + if Single_Lock then + Lock_RTS; + end if; + Write_Lock (T); Initialization.Finalize_Attributes_Link.all (T); Unlock (T); + + if Single_Lock then + Unlock_RTS; + end if; + if T.Common.Task_Image /= null then Free_Task_Image (T.Common.Task_Image); end if; + System.Task_Primitives.Operations.Finalize_TCB (T); end Vulnerable_Free_Task; diff --git a/gcc/ada/s-tasuti.adb b/gcc/ada/s-tasuti.adb index af729643c15..546b1679288 100644 --- a/gcc/ada/s-tasuti.adb +++ b/gcc/ada/s-tasuti.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.67 $ +-- $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). -- -- -- ------------------------------------------------------------------------------ @@ -51,7 +50,7 @@ with System.Task_Primitives.Operations; -- Unlock -- Sleep -- Abort_Task --- Lock/Unlock_All_Tasks_List +-- Lock/Unlock_RTS with System.Tasking.Initialization; -- Used for Defer_Abort @@ -65,56 +64,42 @@ with System.Tasking.Queuing; with System.Tasking.Debug; -- used for Trace +with System.Parameters; +-- used for Single_Lock +-- Runtime_Traces + +with System.Traces.Tasking; +-- used for Send_Trace_Info + with Unchecked_Conversion; package body System.Tasking.Utilities is package STPO renames System.Task_Primitives.Operations; - use System.Tasking.Debug; - use System.Task_Primitives; - use System.Task_Primitives.Operations; - - procedure Locked_Abort_To_Level - (Self_Id : Task_ID; - T : Task_ID; - L : ATC_Level) - renames - Initialization.Locked_Abort_To_Level; - - procedure Defer_Abort (Self_Id : Task_ID) renames - System.Tasking.Initialization.Defer_Abort; - - procedure Defer_Abort_Nestable (Self_Id : Task_ID) renames - System.Tasking.Initialization.Defer_Abort_Nestable; - - procedure Undefer_Abort (Self_Id : Task_ID) renames - System.Tasking.Initialization.Undefer_Abort; - - procedure Undefer_Abort_Nestable (Self_Id : Task_ID) renames - System.Tasking.Initialization.Undefer_Abort_Nestable; + use Parameters; + use Tasking.Debug; + use Task_Primitives; + use Task_Primitives.Operations; - procedure Wakeup_Entry_Caller - (Self_Id : Task_ID; - Entry_Call : Entry_Call_Link; - New_State : Entry_Call_State) - renames - Initialization.Wakeup_Entry_Caller; + use System.Traces; + use System.Traces.Tasking; - ---------------- - -- Abort_Task -- - ---------------- + -------------------- + -- Abort_One_Task -- + -------------------- -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but: - -- (1) caller should be holding no locks + -- (1) caller should be holding no locks except RTS_Lock when Single_Lock -- (2) may be called for tasks that have not yet been activated -- (3) always aborts whole task - procedure Abort_One_Task - (Self_ID : Task_ID; - T : Task_ID) - is + procedure Abort_One_Task (Self_ID : Task_ID; T : Task_ID) is begin + if Parameters.Runtime_Traces then + Send_Trace_Info (T_Abort, Self_ID, T); + end if; + Write_Lock (T); if T.Common.State = Unactivated then @@ -124,7 +109,7 @@ package body System.Tasking.Utilities is Cancel_Queued_Entry_Calls (T); elsif T.Common.State /= Terminated then - Locked_Abort_To_Level (Self_ID, T, 0); + Initialization.Locked_Abort_To_Level (Self_ID, T, 0); end if; Unlock (T); @@ -148,27 +133,23 @@ package body System.Tasking.Utilities is P : Task_ID; begin - -- ???? - -- Since this is a "potentially blocking operation", we should - -- add a separate check here that we are not inside a protected - -- operation. - - Defer_Abort_Nestable (Self_Id); + Initialization.Defer_Abort_Nestable (Self_Id); -- ????? -- Really should not be nested deferral here. -- Patch for code generation error that defers abort before -- evaluating parameters of an entry call (at least, timed entry -- calls), and so may propagate an exception that causes abort - -- to remain undeferred indefinitely. See C97404B. When all + -- to remain undeferred indefinitely. See C97404B. When all -- such bugs are fixed, this patch can be removed. + Lock_RTS; + for J in Tasks'Range loop C := Tasks (J); Abort_One_Task (Self_Id, C); end loop; - Lock_All_Tasks_List; C := All_Tasks_List; while C /= null loop @@ -188,17 +169,16 @@ package body System.Tasking.Utilities is C := C.Common.All_Tasks_Link; end loop; - Unlock_All_Tasks_List; - Undefer_Abort_Nestable (Self_Id); + Unlock_RTS; + Initialization.Undefer_Abort_Nestable (Self_Id); end Abort_Tasks; ------------------------------- -- Cancel_Queued_Entry_Calls -- ------------------------------- - -- Cancel any entry calls queued on target task. Call this only while - -- holding T locked, and nothing more. This should only be called by T, - -- unless T is a terminated previously unactivated task. + -- This should only be called by T, unless T is a terminated previously + -- unactivated task. procedure Cancel_Queued_Entry_Calls (T : Task_ID) is Next_Entry_Call : Entry_Call_Link; @@ -214,7 +194,6 @@ package body System.Tasking.Utilities is Queuing.Dequeue_Head (T.Entry_Queues (J), Entry_Call); while Entry_Call /= null loop - -- Leave Entry_Call.Done = False, since this is cancelled Caller := Entry_Call.Self; @@ -223,7 +202,8 @@ package body System.Tasking.Utilities is Level := Entry_Call.Level - 1; Unlock (T); Write_Lock (Entry_Call.Self); - Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled); + Initialization.Wakeup_Entry_Caller + (Self_Id, Entry_Call, Cancelled); Unlock (Entry_Call.Self); Write_Lock (T); Entry_Call.State := Done; @@ -277,27 +257,6 @@ package body System.Tasking.Utilities is -- Make_Independent -- ---------------------- - -- Move the current task to the outermost level (level 2) of the master - -- hierarchy of the environment task. That is one level further out - -- than normal tasks defined in library-level packages (level 3). The - -- environment task will wait for level 3 tasks to terminate normally, - -- then it will abort all the level 2 tasks. See Finalize_Global_Tasks - -- procedure for more information. - - -- This is a dangerous operation, and should only be used on nested tasks - -- or tasks that depend on any objects that might be finalized earlier than - -- the termination of the environment task. It is for internal use by the - -- GNARL, to prevent such internal server tasks from preventing a partition - -- from terminating. - - -- Also note that the run time assumes that the parent of an independent - -- task is the environment task. If this is not the case, Make_Independent - -- will change the task's parent. This assumption is particularly - -- important for master level completion and for the computation of - -- Independent_Task_Count. - - -- See procedures Init_RTS and Finalize_Global_Tasks for related code. - procedure Make_Independent is Self_Id : constant Task_ID := STPO.Self; Environment_Task : constant Task_ID := STPO.Environment_Task; @@ -309,7 +268,12 @@ package body System.Tasking.Utilities is Known_Tasks (Self_Id.Known_Tasks_Index) := null; end if; - Defer_Abort (Self_Id); + Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + Write_Lock (Environment_Task); Write_Lock (Self_Id); @@ -352,20 +316,19 @@ package body System.Tasking.Utilities is end if; Unlock (Environment_Task); - Undefer_Abort (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); end Make_Independent; ------------------ -- Make_Passive -- ------------------ - -- Update counts to indicate current task is either terminated - -- or accepting on a terminate alternative. Call holding no locks. - - procedure Make_Passive - (Self_ID : Task_ID; - Task_Completed : Boolean) - is + procedure Make_Passive (Self_ID : Task_ID; Task_Completed : Boolean) is C : Task_ID := Self_ID; P : Task_ID := C.Common.Parent; @@ -433,8 +396,7 @@ package body System.Tasking.Utilities is -- is waiting (with zero Awake_Count) in Phase 2 of -- Complete_Master. - pragma Debug - (Debug.Trace (Self_ID, "Make_Passive: Phase 2", 'M')); + pragma Debug (Debug.Trace (Self_ID, "Make_Passive: Phase 2", 'M')); pragma Assert (P /= null); @@ -474,7 +436,6 @@ package body System.Tasking.Utilities is if P.Common.State = Master_Phase_2_Sleep and then C.Master_of_Task = P.Master_Within - then pragma Assert (P.Common.Wait_Count > 0); P.Common.Wait_Count := P.Common.Wait_Count - 1; @@ -538,8 +499,8 @@ package body System.Tasking.Utilities is -- P has non-passive dependents. - if P.Common.State = Master_Completion_Sleep and then - C.Master_of_Task = P.Master_Within + if P.Common.State = Master_Completion_Sleep + and then C.Master_of_Task = P.Master_Within then pragma Debug (Debug.Trace diff --git a/gcc/ada/s-tasuti.ads b/gcc/ada/s-tasuti.ads index 6d605bc394a..6fc816c7afe 100644 --- a/gcc/ada/s-tasuti.ads +++ b/gcc/ada/s-tasuti.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.34 $ -- +-- $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- -- @@ -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). -- -- -- ------------------------------------------------------------------------------ @@ -49,18 +48,24 @@ package System.Tasking.Utilities is --------------------------------- procedure Make_Independent; - -- Move the current task to the outermost level (level 1) of the master - -- master hierarchy of the environment task. This is one level further - -- out than normal tasks defined in library-level packages (level 2). - -- The environment task will wait for level 2 tasks to terminate normally, - -- then it will abort all the level 1 tasks. See Finalize_Global_Tasks + -- Move the current task to the outermost level (level 2) of the master + -- hierarchy of the environment task. That is one level further out + -- than normal tasks defined in library-level packages (level 3). The + -- environment task will wait for level 3 tasks to terminate normally, + -- then it will abort all the level 2 tasks. See Finalize_Global_Tasks -- procedure for more information. -- -- This is a dangerous operation, and should only be used on nested tasks -- or tasks that depend on any objects that might be finalized earlier than - -- the termination of the environment task. It is for internal use by - -- GNARL, to prevent such internal server tasks from preventing a - -- partition from terminating. + -- the termination of the environment task. It is for internal use by the + -- GNARL, to prevent such internal server tasks from preventing a partition + -- from terminating. + -- + -- Also note that the run time assumes that the parent of an independent + -- task is the environment task. If this is not the case, Make_Independent + -- will change the task's parent. This assumption is particularly + -- important for master level completion and for the computation of + -- Independent_Task_Count. Independent_Task_Count : Natural := 0; -- Number of independent task. This counter is incremented each time @@ -75,7 +80,7 @@ package System.Tasking.Utilities is procedure Cancel_Queued_Entry_Calls (T : Task_ID); -- Cancel any entry calls queued on target task. - -- Do not call this while holding any locks. + -- Call this while holding T's lock (or RTS_Lock in Single_Lock mode). procedure Exit_One_ATC_Level (Self_ID : Task_ID); pragma Inline (Exit_One_ATC_Level); @@ -83,9 +88,7 @@ package System.Tasking.Utilities is -- This is a bit of common code for all entry calls. -- The effect is to exit one level of ATC nesting. - procedure Abort_One_Task - (Self_ID : Task_ID; - T : Task_ID); + procedure Abort_One_Task (Self_ID : Task_ID; T : Task_ID); -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but: -- (1) caller should be holding no locks -- (2) may be called for tasks that have not yet been activated @@ -95,10 +98,10 @@ package System.Tasking.Utilities is -- Abort_Tasks is called to initiate abortion, however, the actual -- abortion is done by abortee by means of Abort_Handler - procedure Make_Passive - (Self_ID : Task_ID; - Task_Completed : Boolean); + procedure Make_Passive (Self_ID : Task_ID; Task_Completed : Boolean); -- Update counts to indicate current task is either terminated - -- or accepting on a terminate alternative. Call holding no locks. + -- or accepting on a terminate alternative. + -- Call holding no locks except Global_Task_Lock when calling from + -- Terminate_Task, and RTS_Lock when Single_Lock is True. end System.Tasking.Utilities; diff --git a/gcc/ada/s-tataat.adb b/gcc/ada/s-tataat.adb index a7109fbfd9a..2261b95c1ae 100644 --- a/gcc/ada/s-tataat.adb +++ b/gcc/ada/s-tataat.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.14 $ +-- $Revision$ -- -- --- Copyright (C) 1995-1999 Florida State University -- +-- Copyright (C) 1995-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- -- @@ -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). -- -- -- ------------------------------------------------------------------------------ @@ -40,7 +39,7 @@ with System.Storage_Elements; with System.Task_Primitives.Operations; -- used for Write_Lock -- Unlock --- Lock/Unlock_All_Tasks_List +-- Lock/Unlock_RTS with System.Tasking.Initialization; -- used for Defer_Abort @@ -50,8 +49,8 @@ with Unchecked_Conversion; package body System.Tasking.Task_Attributes is - use Task_Primitives.Operations, - System.Tasking.Initialization; + use Task_Primitives.Operations; + use Tasking.Initialization; function To_Access_Node is new Unchecked_Conversion (Access_Address, Access_Node); @@ -70,7 +69,7 @@ package body System.Tasking.Task_Attributes is begin Defer_Abortion; - Write_Lock (All_Attrs_L'Access); + Lock_RTS; -- Remove this instantiation from the list of all instantiations. @@ -93,7 +92,6 @@ package body System.Tasking.Task_Attributes is end; if X.Index /= 0 then - -- Free location of this attribute, for reuse. In_Use := In_Use and not (2**Natural (X.Index)); @@ -106,8 +104,6 @@ package body System.Tasking.Task_Attributes is -- all tasks, and deallocate the nodes. -- Deallocation does finalization, if necessary. - Lock_All_Tasks_List; - declare C : System.Tasking.Task_ID := All_Tasks_List; P : Access_Node; @@ -131,8 +127,7 @@ package body System.Tasking.Task_Attributes is P.Next := Q.Next; end if; - -- Can't Deallocate now since we are holding the All_Tasks_L - -- lock. + -- Can't Deallocate now since we are holding RTS_Lock. Q.Next := To_Be_Freed; To_Be_Freed := Q; @@ -142,11 +137,9 @@ package body System.Tasking.Task_Attributes is C := C.Common.All_Tasks_Link; end loop; end; - - Unlock_All_Tasks_List; end if; - Unlock (All_Attrs_L'Access); + Unlock_RTS; while To_Be_Freed /= null loop Q := To_Be_Freed; @@ -193,19 +186,19 @@ package body System.Tasking.Task_Attributes is -- Initialize Attributes -- --------------------------- - -- This is to be called by System.Task_Stages.Create_Task. + -- This is to be called by System.Tasking.Stages.Create_Task. -- It relies on their being no concurrent access to this TCB, - -- so it does not defer abortion or lock T.L. + -- so it does not defer abortion nor lock T.L. procedure Initialize_Attributes (T : Task_ID) is P : Access_Instance; - begin - Write_Lock (All_Attrs_L'Access); + Lock_RTS; -- Initialize all the direct-access attributes of this task. P := All_Attributes; + while P /= null loop if P.Index /= 0 then T.Direct_Attributes (P.Index) := @@ -215,7 +208,7 @@ package body System.Tasking.Task_Attributes is P := P.Next; end loop; - Unlock (All_Attrs_L'Access); + Unlock_RTS; exception when others => null; diff --git a/gcc/ada/s-tataat.ads b/gcc/ada/s-tataat.ads index 84463e477f3..b59a80c88e8 100644 --- a/gcc/ada/s-tataat.ads +++ b/gcc/ada/s-tataat.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.9 $ +-- $Revision$ -- -- --- Copyright (C) 1995-2000 Florida State University -- +-- Copyright (C) 1995-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- -- @@ -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,8 +49,14 @@ package System.Tasking.Task_Attributes is type Node; type Access_Node is access all Node; + -- This needs comments ??? + type Dummy_Wrapper; type Access_Dummy_Wrapper is access all Dummy_Wrapper; + for Access_Dummy_Wrapper'Storage_Size use 0; + -- This is a stand-in for the generic type Wrapper defined in + -- Ada.Task_Attributes. The real objects allocated are always + -- of type Wrapper, no Dummy_Wrapper objects are ever created. type Deallocator is access procedure (P : in out Access_Node); -- Called to deallocate an Wrapper. P is a pointer to a Node within. @@ -98,13 +103,6 @@ package System.Tasking.Task_Attributes is -- A linked list of all indirectly access attributes, -- which includes all those that require finalization. - All_Attrs_L : aliased System.Task_Primitives.RTS_Lock; - -- Protects In_Use, Next_Indirect_Index, and All_Attributes. - -- Deadlock prevention order of locking: - -- 1) All_Attrs_L - -- 2) All_Tasks_L - -- 3) any TCB.L - procedure Initialize_Attributes (T : Task_ID); -- Initialize all attributes created via Ada.Task_Attributes for T. -- This must be called by the creator of the task, inside Create_Task, diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb index fa37450cef8..962e56d8d32 100644 --- a/gcc/ada/s-tpoben.adb +++ b/gcc/ada/s-tpoben.adb @@ -1,15 +1,14 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- --- E N T R I E S -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES -- -- -- -- B o d y -- -- -- --- $Revision: 1.11 $ +-- $Revision$ -- -- --- Copyright (C) 1991-2001, Florida State University -- +-- 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- -- @@ -30,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). -- -- -- ------------------------------------------------------------------------------ @@ -65,12 +63,16 @@ pragma Elaborate_All (System.Tasking.Initialization); -- this insures that tasking is initialized if any protected objects are -- created. +with System.Parameters; +-- used for Single_Lock + package body System.Tasking.Protected_Objects.Entries is package STPO renames System.Task_Primitives.Operations; + use Parameters; + use Task_Primitives.Operations; use Ada.Exceptions; - use STPO; Locking_Policy : Character; pragma Import (C, Locking_Policy, "__gl_locking_policy"); @@ -93,8 +95,11 @@ package body System.Tasking.Protected_Objects.Entries is STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); - if Ceiling_Violation then + if Single_Lock then + Lock_RTS; + end if; + if Ceiling_Violation then -- Dip our own priority down to ceiling of lock. -- See similar code in Tasking.Entry_Calls.Lock_Server. @@ -103,12 +108,21 @@ package body System.Tasking.Protected_Objects.Entries is Self_ID.New_Base_Priority := Object.Ceiling; Initialization.Change_Base_Priority (Self_ID); STPO.Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); if Ceiling_Violation then Raise_Exception (Program_Error'Identity, "Ceiling Violation"); end if; + if Single_Lock then + Lock_RTS; + end if; + Object.Old_Base_Priority := Old_Base_Priority; Object.Pending_Action := True; end if; @@ -121,16 +135,24 @@ package body System.Tasking.Protected_Objects.Entries is while Entry_Call /= null loop Caller := Entry_Call.Self; Entry_Call.Exception_To_Raise := Program_Error'Identity; + STPO.Write_Lock (Caller); Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); STPO.Unlock (Caller); + exit when Entry_Call = Object.Entry_Queues (E).Tail; Entry_Call := Entry_Call.Next; end loop; end loop; Object.Finalized := True; + + if Single_Lock then + Unlock_RTS; + end if; + STPO.Unlock (Object.L'Unrestricted_Access); + STPO.Finalize_Lock (Object.L'Unrestricted_Access); end Finalize; @@ -142,6 +164,7 @@ package body System.Tasking.Protected_Objects.Entries is (Object : Protection_Entries_Access) return Boolean is + pragma Warnings (Off, Object); begin return False; end Has_Interrupt_Or_Attach_Handler; @@ -197,6 +220,11 @@ package body System.Tasking.Protected_Objects.Entries is procedure Lock_Entries (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) is begin + if Object.Finalized then + Raise_Exception + (Program_Error'Identity, "Protected Object is finalized"); + end if; + -- The lock is made without defering abortion. -- Therefore the abortion has to be deferred before calling this @@ -214,6 +242,11 @@ package body System.Tasking.Protected_Objects.Entries is procedure Lock_Entries (Object : Protection_Entries_Access) is Ceiling_Violation : Boolean; begin + if Object.Finalized then + Raise_Exception + (Program_Error'Identity, "Protected Object is finalized"); + end if; + pragma Assert (STPO.Self.Deferral_Level > 0); Write_Lock (Object.L'Access, Ceiling_Violation); @@ -229,6 +262,11 @@ package body System.Tasking.Protected_Objects.Entries is procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is Ceiling_Violation : Boolean; begin + if Object.Finalized then + Raise_Exception + (Program_Error'Identity, "Protected Object is finalized"); + end if; + Read_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads index 58b600d69a2..1bd72364a9a 100644 --- a/gcc/ada/s-tpoben.ads +++ b/gcc/ada/s-tpoben.ads @@ -1,13 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- --- E N T R I E S -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES -- -- -- -- S p e c -- -- -- --- $Revision: 1.12 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb index 2e865821bc9..d3ffa6e17d0 100644 --- a/gcc/ada/s-tpobop.adb +++ b/gcc/ada/s-tpobop.adb @@ -7,9 +7,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.13 $ +-- $Revision$ -- -- --- Copyright (C) 1991-2001, Florida State University -- +-- 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- -- @@ -30,8 +30,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). -- -- -- ------------------------------------------------------------------------------ @@ -63,6 +62,7 @@ with System.Task_Primitives.Operations; with System.Tasking.Entry_Calls; -- used for Wait_For_Completion -- Wait_Until_Abortable +-- Wait_For_Completion_With_Timeout with System.Tasking.Initialization; -- Used for Defer_Abort, @@ -86,15 +86,25 @@ with System.Tasking.Rendezvous; with System.Tasking.Debug; -- used for Trace +with System.Parameters; +-- used for Single_Lock +-- Runtime_Traces + +with System.Traces.Tasking; +-- used for Send_Trace_Info + package body System.Tasking.Protected_Objects.Operations is package STPO renames System.Task_Primitives.Operations; + use Parameters; use Task_Primitives; - use Tasking; use Ada.Exceptions; use Entries; + use System.Traces; + use System.Traces.Tasking; + ----------------------- -- Local Subprograms -- ----------------------- @@ -183,7 +193,7 @@ package body System.Tasking.Protected_Objects.Operations is -- has been "cancelled". -- Enqueued should be true if there is any chance that the call - -- is still on a queue. It seems to be safe to make it True if + -- is still on a queue. It seems to be safe to make it True if -- the call was Onqueue at some point before return from -- Protected_Entry_Call. @@ -192,12 +202,12 @@ package body System.Tasking.Protected_Objects.Operations is -- ????? -- The need for Enqueued is less obvious. - -- The "if enqueued()" tests are not necessary, since both + -- The "if enqueued ()" tests are not necessary, since both -- Cancel_Protected_Entry_Call and Protected_Entry_Call must - -- do the same test internally, with locking. The one that + -- do the same test internally, with locking. The one that -- makes cancellation conditional may be a useful heuristic -- since at least 1/2 the time the call should be off-queue - -- by that point. The other one seems totally useless, since + -- by that point. The other one seems totally useless, since -- Protected_Entry_Call must do the same check and then -- possibly wait for the call to be abortable, internally. @@ -206,8 +216,7 @@ package body System.Tasking.Protected_Objects.Operations is -- No other task can access the call record at this point. procedure Cancel_Protected_Entry_Call - (Block : in out Communication_Block) - is + (Block : in out Communication_Block) is begin Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled); end Cancel_Protected_Entry_Call; @@ -248,7 +257,6 @@ package body System.Tasking.Protected_Objects.Operations is Ex : Ada.Exceptions.Exception_Id) is Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; - begin pragma Debug (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P')); @@ -257,18 +265,16 @@ package body System.Tasking.Protected_Objects.Operations is -- a protected operation. if Entry_Call /= null then - -- The call was not requeued. Entry_Call.Exception_To_Raise := Ex; --- ????? --- The caller should do the following, after return from this --- procedure, if Call_In_Progress /= null --- Write_Lock (Entry_Call.Self); --- Initialization.Wakeup_Entry_Caller (STPO.Self, Entry_Call, Done); --- Unlock (Entry_Call.Self); + -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or + -- PO_Service_Entries on return. + end if; + if Runtime_Traces then + Send_Trace_Info (PO_Done, Entry_Call.Self); end if; end Exceptional_Complete_Entry_Body; @@ -286,6 +292,7 @@ package body System.Tasking.Protected_Objects.Operations is New_Object : Protection_Entries_Access; Ceiling_Violation : Boolean; Barrier_Value : Boolean; + Result : Boolean; begin -- When the Action procedure for an entry body returns, it is either @@ -318,7 +325,18 @@ package body System.Tasking.Protected_Objects.Operations is -- Body of current entry served call to completion Object.Call_In_Progress := null; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; else -- Body of current entry requeued the call @@ -328,13 +346,23 @@ package body System.Tasking.Protected_Objects.Operations is -- Call was requeued to a task - if not Rendezvous.Task_Do_Or_Queue + if Single_Lock then + STPO.Lock_RTS; + end if; + + Result := Rendezvous.Task_Do_Or_Queue (Self_ID, Entry_Call, - With_Abort => Entry_Call.Requeue_With_Abort) - then + With_Abort => Entry_Call.Requeue_With_Abort); + + if not Result then Queuing.Broadcast_Program_Error - (Self_ID, Object, Entry_Call); + (Self_ID, Object, Entry_Call, RTS_Locked => True); + end if; + + if Single_Lock then + STPO.Unlock_RTS; end if; + return; end if; @@ -392,10 +420,18 @@ package body System.Tasking.Protected_Objects.Operations is else -- Conditional_Call and With_Abort + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Entry_Call.Self); pragma Assert (Entry_Call.State >= Was_Abortable); Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; end if; exception @@ -416,6 +452,7 @@ package body System.Tasking.Protected_Objects.Operations is Caller : Task_ID; New_Object : Protection_Entries_Access; Ceiling_Violation : Boolean; + Result : Boolean; begin loop @@ -433,6 +470,11 @@ package body System.Tasking.Protected_Objects.Operations is Object.Call_In_Progress := Entry_Call; begin + if Runtime_Traces then + Send_Trace_Info (PO_Run, Self_ID, + Entry_Call.Self, Entry_Index (E)); + end if; + pragma Debug (Debug.Trace (Self_ID, "POSE: start entry body", 'P')); Object.Entry_Bodies ( @@ -447,10 +489,19 @@ package body System.Tasking.Protected_Objects.Operations is if Object.Call_In_Progress /= null then Object.Call_In_Progress := null; Caller := Entry_Call.Self; + + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Caller); Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); STPO.Unlock (Caller); + if Single_Lock then + STPO.Unlock_RTS; + end if; + else -- Call needs to be requeued @@ -460,12 +511,21 @@ package body System.Tasking.Protected_Objects.Operations is -- Call is to be requeued to a task entry - if not Rendezvous.Task_Do_Or_Queue + if Single_Lock then + STPO.Lock_RTS; + end if; + + Result := Rendezvous.Task_Do_Or_Queue (Self_ID, Entry_Call, - With_Abort => Entry_Call.Requeue_With_Abort) - then + With_Abort => Entry_Call.Requeue_With_Abort); + + if not Result then Queuing.Broadcast_Program_Error - (Self_ID, Object, Entry_Call); + (Self_ID, Object, Entry_Call, RTS_Locked => True); + end if; + + if Single_Lock then + STPO.Unlock_RTS; end if; else @@ -569,29 +629,27 @@ package body System.Tasking.Protected_Objects.Operations is -- end if; -- end; - -- See also Cancel_Protected_Entry_Call for code expansion of - -- asynchronous entry call. + -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous + -- entry call. - -- The initial part of this procedure does not need to lock the - -- the calling task's ATCB, up to the point where the call record - -- first may be queued (PO_Do_Or_Queue), since before that no - -- other task will have access to the record. + -- The initial part of this procedure does not need to lock the the calling + -- task's ATCB, up to the point where the call record first may be queued + -- (PO_Do_Or_Queue), since before that no other task will have access to + -- the record. - -- If this is a call made inside of an abort deferred region, - -- the call should be never abortable. + -- If this is a call made inside of an abort deferred region, the call + -- should be never abortable. - -- If the call was not queued abortably, we need to wait - -- until it is before proceeding with the abortable part. + -- If the call was not queued abortably, we need to wait until it is before + -- proceeding with the abortable part. - -- There are some heuristics here, just to save time for - -- frequently occurring cases. For example, we check - -- Initially_Abortable to try to avoid calling the procedure - -- Wait_Until_Abortable, since the normal case for async. - -- entry calls is to be queued abortably. + -- There are some heuristics here, just to save time for frequently + -- occurring cases. For example, we check Initially_Abortable to try to + -- avoid calling the procedure Wait_Until_Abortable, since the normal case + -- for async. entry calls is to be queued abortably. - -- Another heuristic uses the Block.Enqueued to try to avoid - -- calling Cancel_Protected_Entry_Call if the call can be - -- served immediately. + -- Another heuristic uses the Block.Enqueued to try to avoid calling + -- Cancel_Protected_Entry_Call if the call can be served immediately. procedure Protected_Entry_Call (Object : Protection_Entries_Access; @@ -609,9 +667,13 @@ package body System.Tasking.Protected_Objects.Operations is pragma Debug (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P')); + if Runtime_Traces then + Send_Trace_Info (PO_Call, Entry_Index (E)); + end if; + if Self_ID.ATC_Nesting_Level = ATC_Level'Last then - Raise_Exception (Storage_Error'Identity, - "not enough ATC nesting levels"); + Raise_Exception + (Storage_Error'Identity, "not enough ATC nesting levels"); end if; Initialization.Defer_Abort (Self_ID); @@ -685,16 +747,29 @@ package body System.Tasking.Protected_Objects.Operations is -- Try to avoid an expensive call. if not Initially_Abortable then - Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); + if Single_Lock then + STPO.Lock_RTS; + Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); + STPO.Unlock_RTS; + else + Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); + end if; end if; elsif Mode < Asynchronous_Call then -- Simple_Call or Conditional_Call - STPO.Write_Lock (Self_ID); - Entry_Calls.Wait_For_Completion (Self_ID, Entry_Call); - STPO.Unlock (Self_ID); + if Single_Lock then + STPO.Lock_RTS; + Entry_Calls.Wait_For_Completion (Entry_Call); + STPO.Unlock_RTS; + else + STPO.Write_Lock (Self_ID); + Entry_Calls.Wait_For_Completion (Entry_Call); + STPO.Unlock (Self_ID); + end if; + Block.Cancelled := Entry_Call.State = Cancelled; else @@ -704,15 +779,14 @@ package body System.Tasking.Protected_Objects.Operations is Initialization.Undefer_Abort (Self_ID); Entry_Calls.Check_Exception (Self_ID, Entry_Call); - end Protected_Entry_Call; ---------------------------- -- Protected_Entry_Caller -- ---------------------------- - function Protected_Entry_Caller (Object : Protection_Entries'Class) - return Task_ID is + function Protected_Entry_Caller + (Object : Protection_Entries'Class) return Task_ID is begin return Object.Call_In_Progress.Self; end Protected_Entry_Caller; @@ -810,27 +884,23 @@ package body System.Tasking.Protected_Objects.Operations is E : Protected_Entry_Index; With_Abort : Boolean) is - Self_ID : constant Task_ID := STPO.Self; - Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call; + Self_ID : constant Task_ID := STPO.Self; + Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call; begin Initialization.Defer_Abort (Self_ID); - STPO.Write_Lock (Self_ID); + + -- We do not need to lock Self_ID here since the call is not abortable + -- at this point, and therefore, the caller cannot cancel the call. + Entry_Call.Needs_Requeue := True; Entry_Call.Requeue_With_Abort := With_Abort; Entry_Call.Called_PO := To_Address (New_Object); Entry_Call.Called_Task := null; - STPO.Unlock (Self_ID); Entry_Call.E := Entry_Index (E); Initialization.Undefer_Abort (Self_ID); end Requeue_Task_To_Protected_Entry; - -- ?????? - -- Do we really need to lock Self_ID above? - -- Might the caller be trying to cancel? - -- If so, it should fail, since the call state should not be - -- abortable while the call is in service. - --------------------- -- Service_Entries -- --------------------- @@ -855,70 +925,90 @@ package body System.Tasking.Protected_Objects.Operations is Mode : Delay_Modes; Entry_Call_Successful : out Boolean) is - Self_ID : Task_ID := STPO.Self; + Self_Id : constant Task_ID := STPO.Self; Entry_Call : Entry_Call_Link; Ceiling_Violation : Boolean; + Yielded : Boolean; begin - if Self_ID.ATC_Nesting_Level = ATC_Level'Last then + if Self_Id.ATC_Nesting_Level = ATC_Level'Last then Raise_Exception (Storage_Error'Identity, "not enough ATC nesting levels"); end if; - Initialization.Defer_Abort (Self_ID); + if Runtime_Traces then + Send_Trace_Info (POT_Call, Entry_Index (E), Timeout); + end if; + + Initialization.Defer_Abort (Self_Id); Lock_Entries (Object, Ceiling_Violation); if Ceiling_Violation then - Initialization.Undefer_Abort (Self_ID); + Initialization.Undefer_Abort (Self_Id); raise Program_Error; end if; - Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1; + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; pragma Debug - (Debug.Trace (Self_ID, "TPEC: exited to ATC level: " & - ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); + (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); Entry_Call := - Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; + Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; Entry_Call.Next := null; Entry_Call.Mode := Timed_Call; Entry_Call.Cancellation_Attempted := False; - if Self_ID.Deferral_Level > 1 then + if Self_Id.Deferral_Level > 1 then Entry_Call.State := Never_Abortable; else Entry_Call.State := Now_Abortable; end if; Entry_Call.E := Entry_Index (E); - Entry_Call.Prio := STPO.Get_Priority (Self_ID); + Entry_Call.Prio := STPO.Get_Priority (Self_Id); Entry_Call.Uninterpreted_Data := Uninterpreted_Data; Entry_Call.Called_PO := To_Address (Object); Entry_Call.Called_Task := null; Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; - PO_Do_Or_Queue (Self_ID, Object, Entry_Call, With_Abort => True); - PO_Service_Entries (Self_ID, Object); + PO_Do_Or_Queue (Self_Id, Object, Entry_Call, With_Abort => True); + PO_Service_Entries (Self_Id, Object); Unlock_Entries (Object); -- Try to avoid waiting for completed or cancelled calls. if Entry_Call.State >= Done then - Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1; + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1; pragma Debug - (Debug.Trace (Self_ID, "TPEC: exited to ATC level: " & - ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); + (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); Entry_Call_Successful := Entry_Call.State = Done; - Initialization.Undefer_Abort (Self_ID); - Entry_Calls.Check_Exception (Self_ID, Entry_Call); + Initialization.Undefer_Abort (Self_Id); + Entry_Calls.Check_Exception (Self_Id, Entry_Call); return; end if; + if Single_Lock then + STPO.Lock_RTS; + else + STPO.Write_Lock (Self_Id); + end if; + Entry_Calls.Wait_For_Completion_With_Timeout - (Self_ID, Entry_Call, Timeout, Mode); - Initialization.Undefer_Abort (Self_ID); + (Entry_Call, Timeout, Mode, Yielded); + + if Single_Lock then + STPO.Unlock_RTS; + else + STPO.Unlock (Self_Id); + end if; + + -- ??? Do we need to yield in case Yielded is False + + Initialization.Undefer_Abort (Self_Id); Entry_Call_Successful := Entry_Call.State = Done; - Entry_Calls.Check_Exception (Self_ID, Entry_Call); + Entry_Calls.Check_Exception (Self_Id, Entry_Call); end Timed_Protected_Entry_Call; ---------------------------- @@ -953,7 +1043,6 @@ package body System.Tasking.Protected_Objects.Operations is With_Abort : Boolean) is Old : Entry_Call_State := Entry_Call.State; - begin pragma Assert (Old < Done); @@ -963,6 +1052,10 @@ package body System.Tasking.Protected_Objects.Operations is if Old < Was_Abortable and then Entry_Call.State = Now_Abortable then + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Entry_Call.Self); if Entry_Call.Self.Common.State = Async_Select_Sleep then @@ -970,6 +1063,11 @@ package body System.Tasking.Protected_Objects.Operations is end if; STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; elsif Entry_Call.Mode = Conditional_Call then diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb index 7b2005da9b3..27270b2fb41 100644 --- a/gcc/ada/s-tposen.adb +++ b/gcc/ada/s-tposen.adb @@ -1,15 +1,14 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- --- S I N G L E _ E N T R Y -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY -- -- -- -- B o d y -- -- -- -- $Revision$ -- -- --- Copyright (C) 1998-2001 Ada Core Technologies -- +-- 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- -- @@ -30,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). -- -- -- ------------------------------------------------------------------------------ @@ -73,14 +71,14 @@ with System.Task_Primitives.Operations; with Ada.Exceptions; -- used for Exception_Id; -with Unchecked_Conversion; +with System.Parameters; +-- used for Single_Lock package body System.Tasking.Protected_Objects.Single_Entry is package STPO renames System.Task_Primitives.Operations; - function To_Address is new - Unchecked_Conversion (Protection_Entry_Access, System.Address); + use Parameters; ----------------------- -- Local Subprograms -- @@ -110,9 +108,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is -- The caller is waiting on Entry_Caller_Sleep, in -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. - procedure Wait_For_Completion - (Self_ID : Task_ID; - Entry_Call : Entry_Call_Link); + procedure Wait_For_Completion (Entry_Call : Entry_Call_Link); pragma Inline (Wait_For_Completion); -- This procedure suspends the calling task until the specified entry call -- has either been completed or cancelled. On exit, the call will not be @@ -120,13 +116,11 @@ package body System.Tasking.Protected_Objects.Single_Entry is -- Call this only when holding Self_ID locked. procedure Wait_For_Completion_With_Timeout - (Self_ID : Task_ID; - Entry_Call : Entry_Call_Link; + (Entry_Call : Entry_Call_Link; Wakeup_Time : Duration; Mode : Delay_Modes); -- Same as Wait_For_Completion but it waits for a timeout with the value -- specified in Wakeup_Time as well. - -- Self_ID will be locked by this procedure. procedure Check_Exception (Self_ID : Task_ID; @@ -153,6 +147,8 @@ package body System.Tasking.Protected_Objects.Single_Entry is (Self_ID : Task_ID; Entry_Call : Entry_Call_Link) is + pragma Warnings (Off, Self_ID); + procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); @@ -178,72 +174,70 @@ package body System.Tasking.Protected_Objects.Single_Entry is Caller : constant Task_ID := Entry_Call.Self; begin Entry_Call.Exception_To_Raise := Program_Error'Identity; + + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Caller); Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; end Send_Program_Error; ------------------------- -- Wait_For_Completion -- ------------------------- - -- Call this only when holding Self_ID locked - - procedure Wait_For_Completion - (Self_ID : Task_ID; - Entry_Call : Entry_Call_Link) is + procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is + Self_Id : constant Task_ID := Entry_Call.Self; begin - pragma Assert (Self_ID = Entry_Call.Self); - Self_ID.Common.State := Entry_Caller_Sleep; - - STPO.Sleep (Self_ID, Entry_Caller_Sleep); - - Self_ID.Common.State := Runnable; + Self_Id.Common.State := Entry_Caller_Sleep; + STPO.Sleep (Self_Id, Entry_Caller_Sleep); + Self_Id.Common.State := Runnable; end Wait_For_Completion; -------------------------------------- -- Wait_For_Completion_With_Timeout -- -------------------------------------- - -- This routine will lock Self_ID. - - -- This procedure waits for the entry call to - -- be served, with a timeout. It tries to cancel the - -- call if the timeout expires before the call is served. - - -- If we wake up from the timed sleep operation here, - -- it may be for the following possible reasons: - - -- 1) The entry call is done being served. - -- 2) The timeout has expired (Timedout = True) - - -- Once the timeout has expired we may need to continue to wait if - -- the call is already being serviced. In that case, we want to go - -- back to sleep, but without any timeout. The variable Timedout is - -- used to control this. If the Timedout flag is set, we do not need - -- to Sleep with a timeout. We just sleep until we get a wakeup for - -- some status change. - procedure Wait_For_Completion_With_Timeout - (Self_ID : Task_ID; - Entry_Call : Entry_Call_Link; + (Entry_Call : Entry_Call_Link; Wakeup_Time : Duration; Mode : Delay_Modes) is + Self_Id : constant Task_ID := Entry_Call.Self; Timedout : Boolean; Yielded : Boolean; use type Ada.Exceptions.Exception_Id; begin - STPO.Write_Lock (Self_ID); + -- This procedure waits for the entry call to be served, with a timeout. + -- It tries to cancel the call if the timeout expires before the call is + -- served. + + -- If we wake up from the timed sleep operation here, it may be for the + -- following possible reasons: + + -- 1) The entry call is done being served. + -- 2) The timeout has expired (Timedout = True) + + -- Once the timeout has expired we may need to continue to wait if the + -- call is already being serviced. In that case, we want to go back to + -- sleep, but without any timeout. The variable Timedout is used to + -- control this. If the Timedout flag is set, we do not need to Sleep + -- with a timeout. We just sleep until we get a wakeup for some status + -- change. - pragma Assert (Entry_Call.Self = Self_ID); pragma Assert (Entry_Call.Mode = Timed_Call); - Self_ID.Common.State := Entry_Caller_Sleep; + Self_Id.Common.State := Entry_Caller_Sleep; STPO.Timed_Sleep - (Self_ID, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded); + (Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded); if Timedout then Entry_Call.State := Cancelled; @@ -251,8 +245,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is Entry_Call.State := Done; end if; - Self_ID.Common.State := Runnable; - STPO.Unlock (Self_ID); + Self_Id.Common.State := Runnable; end Wait_For_Completion_With_Timeout; ------------------------- @@ -280,7 +273,10 @@ package body System.Tasking.Protected_Objects.Single_Entry is Entry_Call : Entry_Call_Link; New_State : Entry_Call_State) is + pragma Warnings (Off, Self_ID); + Caller : constant Task_ID := Entry_Call.Self; + begin pragma Assert (New_State = Done or else New_State = Cancelled); pragma Assert @@ -300,10 +296,12 @@ package body System.Tasking.Protected_Objects.Single_Entry is -------------------------------- procedure Complete_Single_Entry_Body (Object : Protection_Entry_Access) is + pragma Warnings (Off, Object); + begin - -- Nothing needs to be done since - -- Object.Call_In_Progress.Exception_To_Raise has already been set to - -- Null_Id + -- Nothing needs to do (Object.Call_In_Progress.Exception_To_Raise + -- has already been set to Null_Id). + null; end Complete_Single_Entry_Body; @@ -328,8 +326,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is Compiler_Info : System.Address; Entry_Body : Entry_Body_Access) is - Init_Priority : Integer := Ceiling_Priority; - + Init_Priority : Integer := Ceiling_Priority; begin if Init_Priority = Unspecified_Priority then Init_Priority := System.Priority'Last; @@ -406,16 +403,35 @@ package body System.Tasking.Protected_Objects.Single_Entry is Object.Entry_Body.Action (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); Object.Call_In_Progress := null; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; elsif Entry_Call.Mode /= Conditional_Call then Object.Entry_Queue := Entry_Call; else -- Conditional_Call + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Entry_Call.Self); Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled); STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; end if; exception @@ -471,9 +487,17 @@ package body System.Tasking.Protected_Objects.Single_Entry is pragma Assert (Entry_Call.State /= Cancelled); if Entry_Call.State /= Done then + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Self_Id); - Wait_For_Completion (Self_Id, Entry_Call'Access); + Wait_For_Completion (Entry_Call'Access); STPO.Unlock (Self_Id); + + if Single_Lock then + STPO.Unlock_RTS; + end if; end if; Check_Exception (Self_Id, Entry_Call'Access); @@ -517,9 +541,18 @@ package body System.Tasking.Protected_Objects.Single_Entry is (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); Object.Call_In_Progress := null; Caller := Entry_Call.Self; + + if Single_Lock then + STPO.Lock_RTS; + end if; + STPO.Write_Lock (Caller); Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; end if; end if; @@ -572,8 +605,19 @@ package body System.Tasking.Protected_Objects.Single_Entry is return; end if; - Wait_For_Completion_With_Timeout - (Self_Id, Entry_Call'Access, Timeout, Mode); + if Single_Lock then + STPO.Lock_RTS; + else + STPO.Write_Lock (Self_Id); + end if; + + Wait_For_Completion_With_Timeout (Entry_Call'Access, Timeout, Mode); + + if Single_Lock then + STPO.Unlock_RTS; + else + STPO.Unlock (Self_Id); + end if; pragma Assert (Entry_Call.State >= Done); diff --git a/gcc/ada/s-tposen.ads b/gcc/ada/s-tposen.ads index 9ae62378065..5d59098932b 100644 --- a/gcc/ada/s-tposen.ads +++ b/gcc/ada/s-tposen.ads @@ -1,15 +1,14 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- --- S I N G L E _ E N T R Y -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY -- -- -- -- S p e c -- -- -- --- $Revision: 1.3 $ +-- $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- -- @@ -264,7 +263,7 @@ package System.Tasking.Protected_Objects.Single_Entry is procedure Exceptional_Complete_Single_Entry_Body (Object : Protection_Entry_Access; Ex : Ada.Exceptions.Exception_Id); - -- Perform all of the functions of Complete_Entry_Body. In addition, + -- Perform all of the functions of Complete_Entry_Body. In addition, -- report in Ex the exception whose propagation terminated the entry -- body to the runtime system. diff --git a/gcc/ada/s-traceb.adb b/gcc/ada/s-traceb.adb index 65d6cd0df9f..6230bc8d6d6 100644 --- a/gcc/ada/s-traceb.adb +++ b/gcc/ada/s-traceb.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.4 $ +-- $Revision$ -- -- --- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 1999-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- -- diff --git a/gcc/ada/s-traceb.ads b/gcc/ada/s-traceb.ads index 13f0e88728d..06fbf6ca069 100644 --- a/gcc/ada/s-traceb.ads +++ b/gcc/ada/s-traceb.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.7 $ +-- $Revision$ -- -- --- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- +-- Copyright (C) 1999-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- -- diff --git a/gcc/ada/s-unstyp.ads b/gcc/ada/s-unstyp.ads index 0b315a84c1f..ddbea1660fe 100644 --- a/gcc/ada/s-unstyp.ads +++ b/gcc/ada/s-unstyp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.20 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -37,7 +37,7 @@ -- correspond in size to the standard signed types declared in Standard. -- and (unlike the types in Interfaces have corresponding names). It -- also contains some related definitions for other specialized types --- used only by the expander. +-- used by the compiler in connection with packed array types. package System.Unsigned_Types is pragma Pure (Unsigned_Types); diff --git a/gcc/ada/s-widenu.adb b/gcc/ada/s-widenu.adb index 80a255ebf46..375664f344d 100644 --- a/gcc/ada/s-widenu.adb +++ b/gcc/ada/s-widenu.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.9 $ +-- $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- -- @@ -47,6 +47,8 @@ package body System.Wid_Enum is Lo, Hi : Natural) return Natural is + pragma Warnings (Off, Names); + W : Natural; type Natural_8 is range 0 .. 2 ** 7 - 1; @@ -78,6 +80,8 @@ package body System.Wid_Enum is Lo, Hi : Natural) return Natural is + pragma Warnings (Off, Names); + W : Natural; type Natural_16 is range 0 .. 2 ** 15 - 1; @@ -109,6 +113,8 @@ package body System.Wid_Enum is Lo, Hi : Natural) return Natural is + pragma Warnings (Off, Names); + W : Natural; type Natural_32 is range 0 .. 2 ** 31 - 1; diff --git a/gcc/ada/scn-nlit.adb b/gcc/ada/scn-nlit.adb index d1fc9ea325f..0edb5d4c224 100644 --- a/gcc/ada/scn-nlit.adb +++ b/gcc/ada/scn-nlit.adb @@ -356,7 +356,7 @@ begin -- This is especially useful when parsing garbled input. elsif Operating_Mode /= Check_Syntax - and then (Errors_Detected = 0 or else Try_Semantics) + and then (Serious_Errors_Detected = 0 or else Try_Semantics) then Set_Intval (Token_Node, UI_Num_Value * UI_Base ** UI_Scale); diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb index ae0e1125e50..7f17959ec9b 100644 --- a/gcc/ada/scn.adb +++ b/gcc/ada/scn.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -1061,7 +1061,7 @@ package body Scn is -- Special check for || to give nice message if Source (Scan_Ptr + 1) = '|' then - Error_Msg_S ("""||"" should be `OR ELSE`"); + Error_Msg_S ("""'|'|"" should be `OR ELSE`"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Or; return; @@ -1163,8 +1163,8 @@ package body Scn is else -- Upper half characters may possibly be identifier letters - -- but can never be digits, so Identifier_Character can be - -- used to test for a valid start of identifier character. + -- but can never be digits, so Identifier_Char can be used + -- to test for a valid start of identifier character. if Identifier_Char (Source (Scan_Ptr)) then Name_Len := 0; @@ -1357,30 +1357,44 @@ package body Scn is Sptr : constant Source_Ptr := Scan_Ptr; Code : Char_Code; Err : Boolean; + Chr : Character; begin Scan_Wide (Source, Scan_Ptr, Code, Err); - Accumulate_Checksum (Code); + + -- If error, signal error if Err then Error_Illegal_Wide_Character; + + -- If the character scanned is a normal identifier + -- character, then we treat it that way. + + elsif In_Character_Range (Code) + and then Identifier_Char (Get_Character (Code)) + then + Chr := Get_Character (Code); + Accumulate_Checksum (Chr); + Store_Encoded_Character + (Get_Char_Code (Fold_Lower (Chr))); + + -- Character is not normal identifier character, store + -- it in encoded form. + else + Accumulate_Checksum (Code); Store_Encoded_Character (Code); - end if; - -- Make sure we are allowing wide characters in identifiers. - -- Note that we allow wide character notation for an OK - -- identifier character. This in particular allows bracket - -- or other notation to be used for upper half letters. + -- Make sure we are allowing wide characters in + -- identifiers. Note that we allow wide character + -- notation for an OK identifier character. This + -- in particular allows bracket or other notation + -- to be used for upper half letters. - if Identifier_Character_Set /= 'w' - and then - (not In_Character_Range (Code) - or else - not Identifier_Char (Get_Character (Code))) - then - Error_Msg - ("wide character not allowed in identifier", Sptr); + if Identifier_Character_Set /= 'w' then + Error_Msg + ("wide character not allowed in identifier", Sptr); + end if; end if; end; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 1eb315d481e..be09269b891 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.290 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- @@ -552,7 +552,7 @@ package body Sem is -- a real internal error which we complain about. when N_Empty => - pragma Assert (Errors_Detected /= 0); + pragma Assert (Serious_Errors_Detected /= 0); null; -- A call to analyze the error node is simply ignored, to avoid diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 4a5bafd9b67..49e352707b4 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -422,13 +422,13 @@ package body Sem_Aggr is then if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then Apply_Compile_Time_Constraint_Error - (Exp, "value not in range of}?", + (Exp, "value not in range of}?", CE_Range_Check_Failed, Ent => Base_Type (Check_Typ), Typ => Base_Type (Check_Typ)); elsif Is_Out_Of_Range (Exp, Check_Typ) then Apply_Compile_Time_Constraint_Error - (Exp, "value not in range of}?", + (Exp, "value not in range of}?", CE_Range_Check_Failed, Ent => Check_Typ, Typ => Check_Typ); @@ -630,7 +630,6 @@ package body Sem_Aggr is Itype := Create_Itype (E_Array_Subtype, N); Set_First_Rep_Item (Itype, First_Rep_Item (Typ)); - Set_Component_Type (Itype, Component_Type (Typ)); Set_Convention (Itype, Convention (Typ)); Set_Depends_On_Private (Itype, Has_Private_Component (Typ)); Set_Etype (Itype, Base_Type (Typ)); @@ -745,7 +744,7 @@ package body Sem_Aggr is Ind : Entity_Id; begin - if Has_Record_Rep_Clause (Base_Type (T)) then + if Has_Record_Rep_Clause (T) then return; elsif Present (Next_Discriminant (Disc)) then @@ -821,7 +820,6 @@ package body Sem_Aggr is C_Node := Make_Character_Literal (P, Name_Find, C); Set_Etype (C_Node, Any_Character); - Set_Analyzed (C_Node); Append_To (Exprs, C_Node); P := P + 1; @@ -995,7 +993,9 @@ package body Sem_Aggr is if Raises_Constraint_Error (N) then Aggr_Subtyp := Etype (N); - Rewrite (N, Make_Raise_Constraint_Error (Sloc (N))); + Rewrite (N, + Make_Raise_Constraint_Error (Sloc (N), + Reason => CE_Range_Check_Failed)); Set_Raises_Constraint_Error (N); Set_Etype (N, Aggr_Subtyp); Set_Analyzed (N); @@ -1476,6 +1476,12 @@ package body Sem_Aggr is return Failure; end if; + -- Protect against cascaded errors + + if Etype (Index_Typ) = Any_Type then + return Failure; + end if; + -- STEP 2: Process named components if No (Expressions (N)) then @@ -2588,7 +2594,7 @@ package body Sem_Aggr is -- If this is an extension aggregate, the component list must -- include all components that are not in the given ancestor -- type. Otherwise, the component list must include components - -- of all ancestors. + -- of all ancestors, starting with the root. if Nkind (N) = N_Extension_Aggregate then Root_Typ := Base_Type (Etype (Ancestor_Part (N))); @@ -2609,10 +2615,14 @@ package body Sem_Aggr is -- If we don't get a full declaration, then we have some -- error which will get signalled later so skip this part. + -- Otherwise, gather components of root that apply to the + -- aggregate type. We use the base type in case there is an + -- applicable girder constraint that renames the discriminants + -- of the root. if Nkind (Dnode) = N_Full_Type_Declaration then Record_Def := Type_Definition (Dnode); - Gather_Components (Typ, + Gather_Components (Base_Type (Typ), Component_List (Record_Def), Governed_By => New_Assoc_List, Into => Components, @@ -2668,7 +2678,7 @@ package body Sem_Aggr is if Null_Present (Record_Def) then null; else - Gather_Components (Typ, + Gather_Components (Base_Type (Typ), Component_List (Record_Def), Governed_By => New_Assoc_List, Into => Components, diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index bee8fe78290..32ab795b6c0 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.7 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -48,7 +48,6 @@ with Sem; use Sem; with Sem_Cat; use Sem_Cat; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; -with Sem_Ch13; use Sem_Ch13; with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; @@ -232,9 +231,6 @@ package body Sem_Attr is -- as referenced, since the image function could possibly end up -- referencing any of the literals indirectly. - procedure Check_Enumeration_Type; - -- Verify that prefix of attribute N is an enumeration type - procedure Check_Fixed_Point_Type; -- Verify that prefix of attribute N is a fixed type @@ -444,6 +440,10 @@ package body Sem_Attr is elsif Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) then + if not Is_Library_Level_Entity (Entity (P)) then + Check_Restriction (No_Implicit_Dynamic_Code, P); + end if; + Build_Access_Subprogram_Type (P); return; @@ -453,7 +453,7 @@ package body Sem_Attr is and then Is_Overloadable (Entity (Selector_Name (P)))) then if Ekind (Entity (Selector_Name (P))) = E_Entry then - Error_Attr ("Prefix of % attribute must be subprogram", P); + Error_Attr ("prefix of % attribute must be subprogram", P); end if; Build_Access_Subprogram_Type (Selector_Name (P)); @@ -942,19 +942,6 @@ package body Sem_Attr is end Check_Enum_Image; ---------------------------- - -- Check_Enumeration_Type -- - ---------------------------- - - procedure Check_Enumeration_Type is - begin - Check_Type; - - if not Is_Enumeration_Type (P_Type) then - Error_Attr ("prefix of % attribute must be enumeration type", P); - end if; - end Check_Enumeration_Type; - - ---------------------------- -- Check_Fixed_Point_Type -- ---------------------------- @@ -1342,7 +1329,7 @@ package body Sem_Attr is if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then - Error_Attr (" prefix of % attribute must be generic type", N); + Error_Attr ("prefix of % attribute must be generic type", N); elsif Is_Generic_Actual_Type (Entity (P)) or In_Instance @@ -1352,12 +1339,12 @@ package body Sem_Attr is elsif Is_Generic_Type (Entity (P)) then if not Is_Indefinite_Subtype (Entity (P)) then Error_Attr - (" prefix of % attribute must be indefinite generic type", N); + ("prefix of % attribute must be indefinite generic type", N); end if; else Error_Attr - (" prefix of % attribute must be indefinite generic type", N); + ("prefix of % attribute must be indefinite generic type", N); end if; Set_Etype (N, Standard_Boolean); @@ -1549,8 +1536,14 @@ package body Sem_Attr is -- applies to other entity-denoting expressions. if (Is_Entity_Name (P)) then - if Is_Subprogram (Entity (P)) - or else Is_Object (Entity (P)) + if Is_Subprogram (Entity (P)) then + if not Is_Library_Level_Entity (Entity (P)) then + Check_Restriction (No_Implicit_Dynamic_Code, P); + end if; + + Set_Address_Taken (Entity (P)); + + elsif Is_Object (Entity (P)) or else Ekind (Entity (P)) = E_Label then Set_Address_Taken (Entity (P)); @@ -2144,13 +2137,34 @@ package body Sem_Attr is end if; elsif Nkind (P) = N_Indexed_Component then - Ent := Entity (Prefix (P)); + if not Is_Entity_Name (Prefix (P)) + or else No (Entity (Prefix (P))) + or else Ekind (Entity (Prefix (P))) /= E_Entry_Family + then + if Nkind (Prefix (P)) = N_Selected_Component + and then Present (Entity (Selector_Name (Prefix (P)))) + and then Ekind (Entity (Selector_Name (Prefix (P)))) = + E_Entry_Family + then + Error_Attr + ("attribute % must apply to entry of current task", P); - if Ekind (Ent) /= E_Entry_Family then - Error_Attr ("invalid entry family name", P); + else + Error_Attr ("invalid entry family name", P); + end if; return; + + else + Ent := Entity (Prefix (P)); end if; + elsif Nkind (P) = N_Selected_Component + and then Present (Entity (Selector_Name (P))) + and then Ekind (Entity (Selector_Name (P))) = E_Entry + then + Error_Attr + ("attribute % must apply to entry of current task", P); + else Error_Attr ("invalid entry name", N); return; @@ -2175,8 +2189,8 @@ package body Sem_Attr is then null; else - Error_Msg_N - ("Count must apply to entry of current task", N); + Error_Attr + ("Attribute % must apply to entry of current task", N); end if; end if; @@ -2188,7 +2202,7 @@ package body Sem_Attr is and then Ekind (S) /= E_Entry and then Ekind (S) /= E_Entry_Family then - Error_Attr ("Count cannot appear in inner unit", N); + Error_Attr ("Attribute % cannot appear in inner unit", N); elsif Ekind (Scope (Ent)) = E_Protected_Type and then not Has_Completion (Scope (Ent)) @@ -2666,28 +2680,6 @@ package body Sem_Attr is Resolve (E2, P_Base_Type); Set_Etype (N, P_Base_Type); - ---------------------------- - -- Max_Interrupt_Priority -- - ---------------------------- - - when Attribute_Max_Interrupt_Priority => - Standard_Attribute - (UI_To_Int - (Expr_Value - (Expression - (Parent (RTE (RE_Max_Interrupt_Priority)))))); - - ------------------ - -- Max_Priority -- - ------------------ - - when Attribute_Max_Priority => - Standard_Attribute - (UI_To_Int - (Expr_Value - (Expression - (Parent (RTE (RE_Max_Priority)))))); - ---------------------------------- -- Max_Size_In_Storage_Elements -- ---------------------------------- @@ -3314,20 +3306,6 @@ package body Sem_Attr is Set_Etype (N, Standard_Boolean); Check_Task_Prefix; - ---------- - -- Tick -- - ---------- - - when Attribute_Tick => - Check_Standard_Prefix; - Rewrite (N, - Make_Real_Literal (Loc, - UR_From_Components ( - Num => UI_From_Int (Ttypes.System_Tick_Nanoseconds), - Den => UI_From_Int (9), - Rbase => 10))); - Analyze (N); - ---------------- -- To_Address -- ---------------- @@ -3794,7 +3772,7 @@ package body Sem_Attr is elsif Is_Out_Of_Range (N, T) then Apply_Compile_Time_Constraint_Error - (N, "value not in range of}?"); + (N, "value not in range of}?", CE_Range_Check_Failed); elsif not Range_Checks_Suppressed (T) then Enable_Range_Check (N); @@ -4404,7 +4382,8 @@ package body Sem_Attr is if Raises_Constraint_Error (N) then CE_Node := - Make_Raise_Constraint_Error (Sloc (N)); + Make_Raise_Constraint_Error (Sloc (N), + Reason => CE_Range_Check_Failed); Set_Etype (CE_Node, Etype (N)); Set_Raises_Constraint_Error (CE_Node); Check_Expressions; @@ -5261,7 +5240,7 @@ package body Sem_Attr is Expr_Value (Type_Low_Bound (P_Base_Type)) then Apply_Compile_Time_Constraint_Error - (N, "Pred of type''First"); + (N, "Pred of type''First", CE_Overflow_Check_Failed); Check_Expressions; return; end if; @@ -5571,7 +5550,7 @@ package body Sem_Attr is Expr_Value (Type_High_Bound (P_Base_Type)) then Apply_Compile_Time_Constraint_Error - (N, "Succ of type''Last"); + (N, "Succ of type''Last", CE_Overflow_Check_Failed); Check_Expressions; return; else @@ -5677,7 +5656,7 @@ package body Sem_Attr is Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type)) then Apply_Compile_Time_Constraint_Error - (N, "Val expression out of range"); + (N, "Val expression out of range", CE_Range_Check_Failed); Check_Expressions; return; else @@ -5988,8 +5967,6 @@ package body Sem_Attr is Attribute_First_Bit | Attribute_Input | Attribute_Last_Bit | - Attribute_Max_Interrupt_Priority | - Attribute_Max_Priority | Attribute_Maximum_Alignment | Attribute_Output | Attribute_Partition_ID | @@ -6000,7 +5977,6 @@ package body Sem_Attr is Attribute_Storage_Unit | Attribute_Tag | Attribute_Terminated | - Attribute_Tick | Attribute_To_Address | Attribute_UET_Address | Attribute_Unchecked_Access | @@ -6262,6 +6238,7 @@ package body Sem_Attr is end if; Resolve (Prefix (P), Etype (Prefix (P))); + Generate_Reference (Entity (Selector_Name (P)), P); elsif Is_Overloaded (P) then @@ -6423,7 +6400,9 @@ package body Sem_Attr is ("?non-local pointer cannot point to local object", P); Error_Msg_N ("?Program_Error will be raised at run time", P); - Rewrite (N, Make_Raise_Program_Error (Loc)); + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)); Set_Etype (N, Typ); return; diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index ccbc3f49d4c..47be4b1851d 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.26 $ +-- $Revision$ -- -- --- Copyright (C) 1992-1999, 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- -- @@ -209,7 +209,6 @@ package Sem_Attr is -- value indicating whether or not the body of the designated library -- unit has been elaborated yet. - -------------- -- Enum_Rep -- -------------- @@ -305,29 +304,6 @@ package Sem_Attr is -- This attribute is identical to the Object_Size attribute. It is -- provided for compatibility with the DEC attribute of this name. - ---------------------------- - -- Max_Interrupt_Priority -- - ---------------------------- - - Attribute_Max_Interrupt_Priority => True, - -- - -- Standard'Max_Interrupt_Priority (Standard is the only permissible - -- prefix), provides the value System.Max_Interrupt_Priority, and is - -- intended primarily for constructing this definition in package - -- System (see note above in Default_Bit_Order description}. This - -- is a static attribute. - - ------------------ - -- Max_Priority -- - ------------------ - - Attribute_Max_Priority => True, - -- - -- Standard'Max_Priority (Standard is the only permissible prefix) - -- provides the value System.Max_Priority, and is intended primarily - -- for constructing this definition in package System (see note above - -- in Default_Bit_Order description). This is a static attribute. - ----------------------- -- Maximum_Alignment -- ----------------------- @@ -431,17 +407,6 @@ package Sem_Attr is -- for constructing this definition in package System (see note above -- in Default_Bit_Order description). The is a static attribute. - ---------- - -- Tick -- - ---------- - - Attribute_Tick => True, - -- - -- Standard'Tick (Standard is the only permissible prefix) provides - -- the value System.Tick, and is intended primarily for constructing - -- this definition in package System (see note above in description - -- of Default_Bit_Order). This is a static attribute. - ---------------- -- To_Address -- ---------------- diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 8b5f6a4ff49..d15bd1e71a4 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -8,7 +8,7 @@ -- -- -- $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- -- @@ -331,6 +331,8 @@ package body Sem_Case is ----------- procedure No_OP (C : Node_Id) is + pragma Warnings (Off, C); + begin null; end No_OP; @@ -577,12 +579,14 @@ package body Sem_Case is else if Is_Out_Of_Range (L, E) then Apply_Compile_Time_Constraint_Error - (L, "static value out of range"); + (L, "static value out of range", + CE_Range_Check_Failed); end if; if Is_Out_Of_Range (H, E) then Apply_Compile_Time_Constraint_Error - (H, "static value out of range"); + (H, "static value out of range", + CE_Range_Check_Failed); end if; end if; end if; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index a85d8a1a364..cec474a3de1 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -93,6 +93,13 @@ package body Sem_Ch10 is -- N is the compilation unit whose list of context items receives the -- implicit with_clauses. + function Get_Parent_Entity (Unit : Node_Id) return Entity_Id; + -- Get defining entity of parent unit of a child unit. In most cases this + -- is the defining entity of the unit, but for a child instance whose + -- parent needs a body for inlining, the instantiation node of the parent + -- has not yet been rewritten as a package declaration, and the entity has + -- to be retrieved from the Instance_Spec of the unit. + procedure Implicit_With_On_Parent (Child_Unit : Node_Id; N : Node_Id); -- If the main unit is a child unit, implicit withs are also added for -- all its ancestors. @@ -233,7 +240,7 @@ package body Sem_Ch10 is Semantics (Lib_Unit); if not Analyzed (Proper_Body (Unit_Node)) then - if Errors_Detected > 0 then + if Serious_Errors_Detected > 0 then Error_Msg_N ("subunit not analyzed (errors in parent unit)", N); else Error_Msg_N ("missing stub for subunit", N); @@ -401,7 +408,7 @@ package body Sem_Ch10 is -- Set the entities of all parents in the program_unit_name. Generate_Parent_References ( - Unit_Node, Defining_Entity (Unit (Parent_Spec (Unit_Node)))); + Unit_Node, Get_Parent_Entity (Unit (Parent_Spec (Unit_Node)))); end if; -- All components of the context: with-clauses, library unit, ancestors @@ -1061,7 +1068,7 @@ package body Sem_Ch10 is Analyze_Subprogram_Body (N); - if Errors_Detected = 0 then + if Serious_Errors_Detected = 0 then Analyze_Proper_Body (N, Empty); end if; @@ -1619,7 +1626,7 @@ package body Sem_Ch10 is Unum : Unit_Number_Type; Sel : Node_Id; - procedure Decorate_Tagged_Type (T : Entity_Id; Kind : Entity_Kind); + procedure Decorate_Tagged_Type (T : Entity_Id); -- Set basic attributes of type, including its class_wide type. function In_Chain (E : Entity_Id) return Boolean; @@ -1630,7 +1637,7 @@ package body Sem_Ch10 is -- Decorate_Tagged_Type -- -------------------------- - procedure Decorate_Tagged_Type (T : Entity_Id; Kind : Entity_Kind) is + procedure Decorate_Tagged_Type (T : Entity_Id) is CW : Entity_Id; begin @@ -1847,7 +1854,7 @@ package body Sem_Ch10 is -- to type and build its class-wide type. Init_Size_Align (Typ); - Decorate_Tagged_Type (Typ, E_Record_Type); + Decorate_Tagged_Type (Typ); end if; else @@ -1887,7 +1894,7 @@ package body Sem_Ch10 is Error_Msg_N ("type must be declared tagged", N); elsif not Analyzed (Decl) then - Decorate_Tagged_Type (Typ, E_Private_Type); + Decorate_Tagged_Type (Typ); end if; Set_Entity (Sel, Typ); @@ -2175,6 +2182,19 @@ package body Sem_Ch10 is New_Nodes_OK := New_Nodes_OK - 1; end Expand_With_Clause; + ----------------------- + -- Get_Parent_Entity -- + ----------------------- + + function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is + begin + if Nkind (Unit) = N_Package_Instantiation then + return Defining_Entity (Specification (Instance_Spec (Unit))); + else + return Defining_Entity (Unit); + end if; + end Get_Parent_Entity; + ----------------------------- -- Implicit_With_On_Parent -- ----------------------------- @@ -2187,7 +2207,7 @@ package body Sem_Ch10 is P : constant Node_Id := Parent_Spec (Child_Unit); P_Unit : constant Node_Id := Unit (P); - P_Name : Entity_Id := Defining_Entity (P_Unit); + P_Name : Entity_Id := Get_Parent_Entity (P_Unit); Withn : Node_Id; function Build_Ancestor_Name (P : Node_Id) return Node_Id; @@ -2518,7 +2538,7 @@ package body Sem_Ch10 is begin P := Unit (Parent_Spec (Lib_Unit)); - P_Name := Defining_Entity (P); + P_Name := Get_Parent_Entity (P); if Etype (P_Name) = Any_Type then return; diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index 2a3536b642a..436d3277e5c 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.96 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -324,10 +324,6 @@ package body Sem_Ch11 is if Is_Entity_Name (Exception_Id) then Exception_Name := Entity (Exception_Id); - - if Present (Renamed_Object (Exception_Name)) then - Set_Entity (Exception_Id, Renamed_Object (Exception_Name)); - end if; end if; if No (Exception_Name) diff --git a/gcc/ada/sem_ch11.ads b/gcc/ada/sem_ch11.ads index a56ddee2aa4..a7148fbbacc 100644 --- a/gcc/ada/sem_ch11.ads +++ b/gcc/ada/sem_ch11.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.9 $ -- +-- $Revision$ -- -- --- Copyright (C) 1992-1998 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- -- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 1222ee522fa..9d783ac492f 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -321,7 +321,7 @@ package body Sem_Ch12 is -- Verify that the actuals of the actual instance match the actuals of -- the template for a formal package that is not declared with a box. - procedure Check_Forward_Instantiation (N : Node_Id; Decl : Node_Id); + procedure Check_Forward_Instantiation (Decl : Node_Id); -- If the generic is a local entity and the corresponding body has not -- been seen yet, flag enclosing packages to indicate that it will be -- elaborated after the generic body. Subprograms declared in the same @@ -1228,6 +1228,7 @@ package body Sem_Ch12 is Set_Small_Value (T, Delta_Val); Set_Scalar_Range (T, Scalar_Range (Base)); + Check_Restriction (No_Fixed_Point, Def); end Analyze_Formal_Decimal_Fixed_Point_Type; --------------------------------- @@ -1365,6 +1366,8 @@ package body Sem_Ch12 is Set_Digits_Value (Base, Digits_Value (Standard_Float)); Set_Scalar_Range (Base, Scalar_Range (Standard_Float)); Set_Parent (Base, Parent (Def)); + + Check_Restriction (No_Floating_Point, Def); end Analyze_Formal_Floating_Type; --------------------------------- @@ -1512,6 +1515,8 @@ package body Sem_Ch12 is Set_Delta_Value (Base, Ureal_1); Set_Scalar_Range (Base, Scalar_Range (T)); Set_Parent (Base, Parent (Def)); + + Check_Restriction (No_Fixed_Point, Def); end Analyze_Formal_Ordinary_Fixed_Point_Type; ---------------------------- @@ -2083,7 +2088,7 @@ package body Sem_Ch12 is Formals := Parameter_Specifications (Spec); if Present (Formals) then - Process_Formals (Id, Formals, Spec); + Process_Formals (Formals, Spec); end if; if Nkind (Spec) = N_Function_Specification then @@ -2271,13 +2276,14 @@ package body Sem_Ch12 is ("& is hidden within declaration of instance ", Prefix (Gen_Id)); end if; - -- If renaming, indicate this is an instantiation of renamed unit. + Set_Entity (Gen_Id, Gen_Unit); + + -- If generic is a renaming, get original generic unit. if Present (Renamed_Object (Gen_Unit)) and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package then Gen_Unit := Renamed_Object (Gen_Unit); - Set_Entity (Gen_Id, Gen_Unit); end if; -- Verify that there are no circular instantiations. @@ -2460,7 +2466,7 @@ package body Sem_Ch12 is -- and that cleanup actions should be delayed until after the -- instance body is expanded. - Check_Forward_Instantiation (N, Gen_Decl); + Check_Forward_Instantiation (Gen_Decl); if Nkind (N) = N_Package_Instantiation then declare Enclosing_Master : Entity_Id := Current_Scope; @@ -3075,7 +3081,9 @@ package body Sem_Ch12 is end if; else - -- If renaming, indicate that this is instantiation of renamed unit + Set_Entity (Gen_Id, Gen_Unit); + + -- If renaming, get original unit. if Present (Renamed_Object (Gen_Unit)) and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure @@ -3083,7 +3091,6 @@ package body Sem_Ch12 is Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function) then Gen_Unit := Renamed_Object (Gen_Unit); - Set_Entity (Gen_Id, Gen_Unit); end if; if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then @@ -3199,7 +3206,7 @@ package body Sem_Ch12 is Pending_Instantiations.Increment_Last; Pending_Instantiations.Table (Pending_Instantiations.Last) := (N, Act_Decl, Expander_Active, Current_Sem_Unit); - Check_Forward_Instantiation (N, Gen_Decl); + Check_Forward_Instantiation (Gen_Decl); -- The wrapper package is always delayed, because it does -- not constitute a freeze point, but to insure that the @@ -3568,7 +3575,7 @@ package body Sem_Ch12 is -- Check_Forward_Instantiation -- --------------------------------- - procedure Check_Forward_Instantiation (N : Node_Id; Decl : Node_Id) is + procedure Check_Forward_Instantiation (Decl : Node_Id) is S : Entity_Id; Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl)); @@ -4222,6 +4229,12 @@ package body Sem_Ch12 is return List_Id; -- Apply Copy_Node recursively to the members of a node list. + function In_Defining_Unit_Name (Nam : Node_Id) return Boolean; + -- True if an identifier is part of the defining program unit name + -- of a child unit. The entity of such an identifier must be kept + -- (for ASIS use) even though as the name of an enclosing generic + -- it would otherwise not be preserved in the generic tree. + ----------------------- -- Copy_Descendants -- ----------------------- @@ -4321,6 +4334,19 @@ package body Sem_Ch12 is end if; end Copy_Generic_List; + --------------------------- + -- In_Defining_Unit_Name -- + --------------------------- + + function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is + begin + return Present (Parent (Nam)) + and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name + or else + (Nkind (Parent (Nam)) = N_Expanded_Name + and then In_Defining_Unit_Name (Parent (Nam)))); + end In_Defining_Unit_Name; + -- Start of processing for Copy_Generic_Node begin @@ -4384,7 +4410,7 @@ package body Sem_Ch12 is if No (Current_Instantiated_Parent.Gen_Id) then if No (Ent) or else Nkind (Ent) /= N_Defining_Identifier - or else Nkind (Parent (N)) /= N_Defining_Program_Unit_Name + or else not In_Defining_Unit_Name (N) then Set_Associated_Node (New_N, Empty); end if; @@ -4854,7 +4880,7 @@ package body Sem_Ch12 is Pack_Id : Entity_Id) is F_Node : Node_Id; - Gen_Unit : constant Entity_Id := Entity (Name (Inst_Node)); + Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); Par : constant Entity_Id := Scope (Gen_Unit); Enc_G : Entity_Id; Enc_I : Node_Id; @@ -5148,8 +5174,13 @@ package body Sem_Ch12 is -- If the instantiation is a compilation unit that does not need a -- body then the instantiation node has been rewritten as a package -- declaration for the instance, and we return the original node. + -- If it is a compilation unit and the instance node has not been - -- rewritten, then it is still the unit of the compilation. + -- rewritten, then it is still the unit of the compilation. Finally, + -- if a body is present, this is a parent of the main unit whose body + -- has been compiled for inlining purposes, and the instantiation node + -- has been rewritten with the instance body. + -- Otherwise the instantiation node appears after the declaration. -- If the entity is a formal package, the declaration may have been -- rewritten as a generic declaration (in the case of a formal with a @@ -5157,6 +5188,12 @@ package body Sem_Ch12 is -- is found with a forward search. if Nkind (Parent (Decl)) = N_Compilation_Unit then + if Nkind (Decl) = N_Package_Declaration + and then Present (Corresponding_Body (Decl)) + then + Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); + end if; + if Nkind (Original_Node (Decl)) = N_Package_Instantiation then return Original_Node (Decl); else @@ -6495,7 +6532,7 @@ package body Sem_Ch12 is Loc : constant Source_Ptr := Sloc (Inst_Node); Gen_Id : constant Node_Id := Name (Inst_Node); - Gen_Unit : constant Entity_Id := Entity (Name (Inst_Node)); + Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); Act_Spec : constant Node_Id := Specification (Act_Decl); Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Spec); @@ -6649,6 +6686,13 @@ package body Sem_Ch12 is Inherit_Context (Gen_Body, Inst_Node); end if; + -- Remove the parent instances if they have been placed on the + -- scope stack to compile the body. + + if Parent_Installed then + Remove_Parent (In_Body => True); + end if; + Restore_Private_Views (Act_Decl_Id); Restore_Env; Style_Check := Save_Style_Check; @@ -6658,7 +6702,7 @@ package body Sem_Ch12 is -- (since a common reason for missing the body is that it had errors). elsif Unit_Requires_Body (Gen_Unit) then - if Errors_Detected = 0 then + if Serious_Errors_Detected = 0 then Error_Msg_NE ("cannot find body of generic package &", Inst_Node, Gen_Unit); @@ -6692,13 +6736,6 @@ package body Sem_Ch12 is end if; Expander_Mode_Restore; - - -- Remove the parent instances if they have been placed on the - -- scope stack to compile the body. - - if Parent_Installed then - Remove_Parent (In_Body => True); - end if; end Instantiate_Package_Body; --------------------------------- @@ -6714,7 +6751,7 @@ package body Sem_Ch12 is Decls : List_Id; Gen_Id : constant Node_Id := Name (Inst_Node); - Gen_Unit : constant Entity_Id := Entity (Name (Inst_Node)); + Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); Anon_Id : constant Entity_Id := Defining_Unit_Name (Specification (Act_Decl)); @@ -6875,7 +6912,7 @@ package body Sem_Ch12 is -- raise program error if executed. We generate a subprogram body for -- this purpose. See DEC ac30vso. - elsif Errors_Detected = 0 + elsif Serious_Errors_Detected = 0 and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit then if Ekind (Anon_Id) = E_Procedure then @@ -6892,7 +6929,11 @@ package body Sem_Ch12 is Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => - New_List (Make_Raise_Program_Error (Loc)))); + New_List ( + Make_Raise_Program_Error (Loc, + Reason => + PE_Access_Before_Elaboration)))); + else Act_Body := Make_Subprogram_Body (Loc, @@ -6910,7 +6951,10 @@ package body Sem_Ch12 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Return_Statement (Loc, - Expression => Make_Raise_Program_Error (Loc))))); + Expression => + Make_Raise_Program_Error (Loc, + Reason => + PE_Access_Before_Elaboration))))); end if; Pack_Body := Make_Package_Body (Loc, @@ -7467,6 +7511,16 @@ package body Sem_Ch12 is else Act_T := Entity (Actual); + -- Deal with fixed/floating restrictions + + if Is_Floating_Point_Type (Act_T) then + Check_Restriction (No_Floating_Point, Actual); + elsif Is_Fixed_Point_Type (Act_T) then + Check_Restriction (No_Fixed_Point, Actual); + end if; + + -- Deal with error of using incomplete type as generic actual + if Ekind (Act_T) = E_Incomplete_Type then if No (Underlying_Type (Act_T)) then Error_Msg_N ("premature use of incomplete type", Actual); @@ -7481,6 +7535,8 @@ package body Sem_Ch12 is end if; end if; + -- Deal with error of premature use of private type as generic actual + elsif Is_Private_Type (Act_T) and then Is_Private_Type (Base_Type (Act_T)) and then not Is_Generic_Type (Act_T) @@ -7901,7 +7957,7 @@ package body Sem_Ch12 is procedure Pre_Analyze_Actuals (N : Node_Id) is Assoc : Node_Id; Act : Node_Id; - Errs : Int := Errors_Detected; + Errs : Int := Serious_Errors_Detected; begin Assoc := First (Generic_Associations (N)); @@ -7929,7 +7985,7 @@ package body Sem_Ch12 is Analyze (Act); end if; - if Errs /= Errors_Detected then + if Errs /= Serious_Errors_Detected then Abandon_Instantiation (Act); end if; @@ -7967,6 +8023,15 @@ package body Sem_Ch12 is Next_Entity (E); end loop; + if Is_Generic_Instance (Current_Scope) + and then P /= Current_Scope + then + -- We are within an instance of some sibling. Retain + -- visibility of parent, for proper subsequent cleanup. + + Set_In_Private_Part (P); + end if; + elsif not In_Open_Scopes (Scope (P)) then Set_Is_Immediately_Visible (P, False); end if; @@ -8495,7 +8560,7 @@ package body Sem_Ch12 is Act1 : Node_Id; Act2 : Node_Id; Def : Node_Id; - Gen_Id : Entity_Id := Entity (Name (N2)); + Gen_Id : Entity_Id := Get_Generic_Entity (N2); Ndec : Node_Id; Subp : Entity_Id; Actual : Entity_Id; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index f15850a3b4b..e26fbc669db 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.3 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -44,9 +44,9 @@ with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; +with Snames; use Snames; with Stand; use Stand; with Sinfo; use Sinfo; -with Snames; use Snames; with Table; with Ttypes; use Ttypes; with Tbuild; use Tbuild; @@ -97,6 +97,12 @@ package body Sem_Ch13 is -- for limited types is a legality check, which is why this takes place -- here rather than in exp_ch13, where it was previously. + -- To avoid elaboration anomalies with freeze nodes, for untagged types + -- we generate both a subprogram declaration and a subprogram renaming + -- declaration, so that the attribute specification is handled as a + -- renaming_as_body. For tagged types, the specification is one of the + -- primitive specs. + procedure New_Stream_Procedure (N : Node_Id; Ent : Entity_Id; @@ -249,6 +255,9 @@ package body Sem_Ch13 is Error_Msg_N ("entity must be declared in this scope", Nam); return; + elsif No (U_Ent) then + U_Ent := Ent; + elsif Is_Type (U_Ent) and then not Is_First_Subtype (U_Ent) and then Id /= Attribute_Object_Size @@ -308,6 +317,15 @@ package body Sem_Ch13 is Check_Constant_Address_Clause (Expr, U_Ent); + if Is_Task_Type (Scope (U_Ent)) + and then Comes_From_Source (Scope (U_Ent)) + then + Error_Msg_N + ("?entry address declared for entry in task type", N); + Error_Msg_N + ("\?only one task can be declared of this type", N); + end if; + -- Case of address clause for an object elsif @@ -966,11 +984,12 @@ package body Sem_Ch13 is Set_RM_Size (U_Ent, Size); -- For scalar types, increase Object_Size to power of 2, - -- but not less than 8 in any case, i.e. byte addressable. + -- but not less than a storage unit in any case (i.e., + -- normally this means it will be byte addressable). if Is_Scalar_Type (U_Ent) then - if Size <= 8 then - Init_Esize (U_Ent, 8); + if Size <= System_Storage_Unit then + Init_Esize (U_Ent, System_Storage_Unit); elsif Size <= 16 then Init_Esize (U_Ent, 16); elsif Size <= 32 then @@ -1886,10 +1905,7 @@ package body Sem_Ch13 is Ccount := Ccount + 1; end if; - Set_Has_Record_Rep_Clause (Rectype); - Set_Has_Specified_Layout (Rectype); - - -- A representation like this applies to the base type as well + -- A representation like this applies to the base type Set_Has_Record_Rep_Clause (Base_Type (Rectype)); Set_Has_Non_Standard_Rep (Base_Type (Rectype)); @@ -2750,76 +2766,6 @@ package body Sem_Ch13 is end if; end Get_Alignment_Value; - ------------------------------------- - -- Get_Attribute_Definition_Clause -- - ------------------------------------- - - function Get_Attribute_Definition_Clause - (E : Entity_Id; - Id : Attribute_Id) - return Node_Id - is - N : Node_Id; - - begin - N := First_Rep_Item (E); - while Present (N) loop - if Nkind (N) = N_Attribute_Definition_Clause - and then Get_Attribute_Id (Chars (N)) = Id - then - return N; - else - Next_Rep_Item (N); - end if; - end loop; - - return Empty; - end Get_Attribute_Definition_Clause; - - -------------------- - -- Get_Rep_Pragma -- - -------------------- - - function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id is - N : Node_Id; - Typ : Entity_Id; - - begin - N := First_Rep_Item (E); - - while Present (N) loop - if Nkind (N) = N_Pragma and then Chars (N) = Nam then - - if Nam = Name_Stream_Convert then - - -- For tagged types this pragma is not inherited, so we - -- must verify that it is defined for the given type and - -- not an ancestor. - - Typ := Entity (Expression - (First (Pragma_Argument_Associations (N)))); - - if not Is_Tagged_Type (E) - or else E = Typ - or else (Is_Private_Type (Typ) - and then E = Full_View (Typ)) - then - return N; - else - Next_Rep_Item (N); - end if; - - else - return N; - end if; - else - Next_Rep_Item (N); - end if; - end loop; - - return Empty; - end Get_Rep_Pragma; - ---------------- -- Initialize -- ---------------- @@ -2845,7 +2791,8 @@ package body Sem_Ch13 is return Id = Attribute_Input or else Id = Attribute_Output or else Id = Attribute_Read - or else Id = Attribute_Write; + or else Id = Attribute_Write + or else Id = Attribute_External_Tag; end; end if; end Is_Operational_Item; @@ -2868,6 +2815,7 @@ package body Sem_Ch13 is B : Uint; S : Nat; Ancest : Entity_Id; + R_Typ : constant Entity_Id := Root_Type (T); begin -- If bad type, return 0 @@ -2879,7 +2827,9 @@ package body Sem_Ch13 is -- need to know such a size, but this routine may be called with a -- generic type as part of normal processing. - elsif Is_Generic_Type (Root_Type (T)) then + elsif Is_Generic_Type (R_Typ) + or else R_Typ = Any_Type + then return 0; -- Access types @@ -2890,7 +2840,7 @@ package body Sem_Ch13 is -- Floating-point types elsif Is_Floating_Point_Type (T) then - return UI_To_Int (Esize (Root_Type (T))); + return UI_To_Int (Esize (R_Typ)); -- Discrete types @@ -3057,36 +3007,58 @@ package body Sem_Ch13 is Nam : Name_Id) is Loc : constant Source_Ptr := Sloc (N); - Subp_Id : Entity_Id := Make_Defining_Identifier (Loc, Nam); + Subp_Id : Entity_Id; Subp_Decl : Node_Id; F : Entity_Id; Etyp : Entity_Id; + function Build_Spec return Node_Id; + -- Used for declaration and renaming declaration, so that this is + -- treated as a renaming_as_body. + + ---------------- + -- Build_Spec -- + ---------------- + + function Build_Spec return Node_Id is + begin + Subp_Id := Make_Defining_Identifier (Loc, Nam); + + return + Make_Function_Specification (Loc, + Defining_Unit_Name => Subp_Id, + Parameter_Specifications => + New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Reference_To ( + Designated_Type (Etype (F)), Loc)))), + + Subtype_Mark => + New_Reference_To (Etyp, Loc)); + end Build_Spec; + + -- Start of processing for New_Stream_Function + begin - F := First_Formal (Subp); - Etyp := Etype (Subp); + F := First_Formal (Subp); + Etyp := Etype (Subp); + + if not Is_Tagged_Type (Ent) then + Subp_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Build_Spec); + Insert_Action (N, Subp_Decl); + end if; Subp_Decl := Make_Subprogram_Renaming_Declaration (Loc, - Specification => - - Make_Function_Specification (Loc, - Defining_Unit_Name => Subp_Id, - Parameter_Specifications => - New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_S), - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Reference_To ( - Designated_Type (Etype (F)), Loc)))), - - Subtype_Mark => - New_Reference_To (Etyp, Loc)), - - Name => New_Reference_To (Subp, Loc)); + Specification => Build_Spec, + Name => New_Reference_To (Subp, Loc)); if Is_Tagged_Type (Ent) and then not Is_Limited_Type (Ent) then Set_TSS (Base_Type (Ent), Subp_Id); @@ -3109,39 +3081,58 @@ package body Sem_Ch13 is Out_P : Boolean := False) is Loc : constant Source_Ptr := Sloc (N); - Subp_Id : Entity_Id := Make_Defining_Identifier (Loc, Nam); + Subp_Id : Entity_Id; Subp_Decl : Node_Id; F : Entity_Id; Etyp : Entity_Id; + function Build_Spec return Node_Id; + -- Used for declaration and renaming declaration, so that this is + -- treated as a renaming_as_body. + + function Build_Spec return Node_Id is + begin + Subp_Id := Make_Defining_Identifier (Loc, Nam); + + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Subp_Id, + Parameter_Specifications => + New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Reference_To ( + Designated_Type (Etype (F)), Loc))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_V), + Out_Present => Out_P, + Parameter_Type => + New_Reference_To (Etyp, Loc)))); + end Build_Spec; + + -- Start of processing for New_Stream_Function + begin F := First_Formal (Subp); Etyp := Etype (Next_Formal (F)); + if not Is_Tagged_Type (Ent) then + Subp_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Build_Spec); + Insert_Action (N, Subp_Decl); + end if; + Subp_Decl := Make_Subprogram_Renaming_Declaration (Loc, - Specification => - - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Subp_Id, - Parameter_Specifications => - New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_S), - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Reference_To ( - Designated_Type (Etype (F)), Loc))), - - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_V), - Out_Present => Out_P, - Parameter_Type => - New_Reference_To (Etyp, Loc)))), - Name => New_Reference_To (Subp, Loc)); + Specification => Build_Spec, + Name => New_Reference_To (Subp, Loc)); if Is_Tagged_Type (Ent) and then not Is_Limited_Type (Ent) then Set_TSS (Base_Type (Ent), Subp_Id); @@ -3172,9 +3163,13 @@ package body Sem_Ch13 is return Boolean is begin - -- Cannot apply rep items to generic types + -- Cannot apply rep items that are not operational items + -- to generic types - if Is_Type (T) + if Is_Operational_Item (N) then + return False; + + elsif Is_Type (T) and then Is_Generic_Type (Root_Type (T)) then Error_Msg_N @@ -3195,7 +3190,7 @@ package body Sem_Ch13 is -- illegal but stream attributes and Convention pragmas are correct. elsif Has_Private_Component (T) then - if (Nkind (N) = N_Pragma or else Is_Operational_Item (N)) then + if Nkind (N) = N_Pragma then return False; else Error_Msg_N @@ -3490,7 +3485,7 @@ package body Sem_Ch13 is if Lo < 0 then if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then - Sz := 8; + Sz := Standard_Character_Size; -- May be > 8 on some targets elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then Sz := 16; @@ -3504,7 +3499,7 @@ package body Sem_Ch13 is else if Hi < Uint_2**08 then - Sz := 8; + Sz := Standard_Character_Size; -- May be > 8 on some targets elsif Hi < Uint_2**16 then Sz := 16; @@ -3635,7 +3630,7 @@ package body Sem_Ch13 is -- use the official RM size instead of Esize. See description -- in Einfo "Handling of Type'Size Values" for details. - if Errors_Detected = 0 + if Serious_Errors_Detected = 0 and then Known_Static_RM_Size (Source) and then Known_Static_RM_Size (Target) then @@ -3712,7 +3707,7 @@ package body Sem_Ch13 is -- If both types are access types, we need to check the alignment. -- If the alignment of both is specified, we can do it here. - if Errors_Detected = 0 + if Serious_Errors_Detected = 0 and then Ekind (Source) in Access_Kind and then Ekind (Target) in Access_Kind and then Target_Strict_Alignment diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 5afe5adb208..46ce2823751 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.39 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -26,7 +26,6 @@ -- -- ------------------------------------------------------------------------------ -with Snames; use Snames; with Types; use Types; with Uintp; use Uintp; @@ -80,20 +79,6 @@ package Sem_Ch13 is -- way to meet the requirement. If the type is currently biased, then -- this biased size is used in the initial check, and Biased is False. - function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id; - -- Searches the Rep_Item chain for the given entity E, for an instance - -- of a representation pragma with the given name Nam. If found then - -- the value returned is the N_Pragma node, otherwise Empty is returned. - - function Get_Attribute_Definition_Clause - (E : Entity_Id; - Id : Attribute_Id) - return Node_Id; - -- Searches the Rep_Item chain for a given entity E, for an instance - -- of an attribute definition clause with the given attibute Id Id. If - -- found, the value returned is the N_Attribute_Definition_Clause node, - -- otherwise Empty is returned. - procedure Record_Rep_Item (T : Entity_Id; N : Node_Id); -- N is the node for either a representation pragma or an attribute -- definition clause that applies to type T. This procedure links diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb index f8e85b3c02a..23d4a191430 100644 --- a/gcc/ada/sem_ch2.adb +++ b/gcc/ada/sem_ch2.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.8 $ -- +-- $Revision$ -- -- --- Copyright (C) 1992-1999, 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- -- @@ -27,6 +27,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Errout; use Errout; with Opt; use Opt; with Restrict; use Restrict; with Sem_Ch8; use Sem_Ch8; @@ -64,7 +65,17 @@ package body Sem_Ch2 is procedure Analyze_Identifier (N : Node_Id) is begin - Find_Direct_Name (N); + -- Ignore call if prior errors, and identifier has no name, since + -- this is the result of some kind of previous error generating a + -- junk identifier. + + if Chars (N) in Error_Name_Or_No_Name + and then Total_Errors_Detected /= 0 + then + return; + else + Find_Direct_Name (N); + end if; end Analyze_Identifier; ----------------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 1a43f9ee7f3..b77a3f96784 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -248,8 +248,7 @@ package body Sem_Ch3 is function Build_Scalar_Bound (Bound : Node_Id; Par_T : Entity_Id; - Der_T : Entity_Id; - Loc : Source_Ptr) + Der_T : Entity_Id) return Node_Id; -- The bounds of a derived scalar type are conversions of the bounds of -- the parent type. Optimize the representation if the bounds are literals. @@ -371,9 +370,11 @@ package body Sem_Ch3 is -- Empty for Def_Id indicates that an implicit type must be created, but -- creation is delayed (and must be done by this procedure) because other -- subsidiary implicit types must be created first (which is why Def_Id - -- is an in/out parameter). Related_Nod gives the place where this type has - -- to be inserted in the tree. The Related_Id and Suffix parameters are - -- used to build the associated Implicit type name. + -- is an in/out parameter). The second parameter is a subtype indication + -- node for the constrained array to be created (e.g. something of the + -- form string (1 .. 10)). Related_Nod gives the place where this type + -- has to be inserted in the tree. The Related_Id and Suffix parameters + -- are used to build the associated Implicit type name. procedure Constrain_Concurrent (Def_Id : in out Entity_Id; @@ -407,10 +408,7 @@ package body Sem_Ch3 is -- When constraining a protected type or task type with discriminants, -- constrain the corresponding record with the same discriminant values. - procedure Constrain_Decimal - (Def_Id : Node_Id; - S : Node_Id; - Related_Nod : Node_Id); + procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id); -- Constrain a decimal fixed point type with a digits constraint and/or a -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity. @@ -426,18 +424,12 @@ package body Sem_Ch3 is -- Constrain_Concurrent. See Build_Discrimated_Subtype for an explanation -- of For_Access. - procedure Constrain_Enumeration - (Def_Id : Node_Id; - S : Node_Id; - Related_Nod : Node_Id); + procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id); -- Constrain an enumeration type with a range constraint. This is -- identical to Constrain_Integer, but for the Ekind of the -- resulting subtype. - procedure Constrain_Float - (Def_Id : Node_Id; - S : Node_Id; - Related_Nod : Node_Id); + procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id); -- Constrain a floating point type with either a digits constraint -- and/or a range constraint, building a E_Floating_Point_Subtype. @@ -454,16 +446,10 @@ package body Sem_Ch3 is -- unconstrained array. The Related_Id and Suffix parameters are used to -- build the associated Implicit type name. - procedure Constrain_Integer - (Def_Id : Node_Id; - S : Node_Id; - Related_Nod : Node_Id); + procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id); -- Build subtype of a signed or modular integer type. - procedure Constrain_Ordinary_Fixed - (Def_Id : Node_Id; - S : Node_Id; - Related_Nod : Node_Id); + procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id); -- Constrain an ordinary fixed point type with a range constraint, and -- build an E_Ordinary_Fixed_Point_Subtype entity. @@ -624,6 +610,15 @@ package body Sem_Ch3 is -- type. It is provided so that its Has_Task flag can be set if any of -- the component have Has_Task set. + procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id); + -- Subsidiary to Build_Derived_Record_Type. For untagged records, we + -- build a copy of the declaration tree of the parent, and we create + -- independently the list of components for the derived type. Semantic + -- information uses the component entities, but record representation + -- clauses are validated on the declaration tree. This procedure replaces + -- discriminants and components in the declaration with those that have + -- been created by Inherit_Components. + procedure Set_Fixed_Range (E : Entity_Id; Loc : Source_Ptr; @@ -634,10 +629,9 @@ package body Sem_Ch3 is -- for the constructed range. See body for further details. procedure Set_Scalar_Range_For_Subtype - (Def_Id : Entity_Id; - R : Node_Id; - Subt : Entity_Id; - Related_Nod : Node_Id); + (Def_Id : Entity_Id; + R : Node_Id; + Subt : Entity_Id); -- This routine is used to set the scalar range field for a subtype -- given Def_Id, the entity for the subtype, and R, the range expression -- for the scalar range. Subt provides the parent subtype to be used @@ -723,7 +717,7 @@ package body Sem_Ch3 is if Present (Formals) then New_Scope (Desig_Type); - Process_Formals (Desig_Type, Formals, Parent (T_Def)); + Process_Formals (Formals, Parent (T_Def)); -- A bit of a kludge here, End_Scope requires that the parent -- pointer be set to something reasonable, but Itypes don't @@ -1351,13 +1345,7 @@ package body Sem_Ch3 is Constant_Redeclaration (Id, N, T); Generate_Reference (Prev_Entity, Id, 'c'); - - -- If in main unit, set as referenced, so we do not complain about - -- the full declaration being an unreferenced entity. - - if In_Extended_Main_Source_Unit (Id) then - Set_Referenced (Id); - end if; + Set_Completion_Referenced (Id); if Error_Posted (N) then -- Type mismatch or illegal redeclaration, Do not analyze @@ -1389,13 +1377,13 @@ package body Sem_Ch3 is -- If deferred constant, make sure context is appropriate. We detect -- a deferred constant as a constant declaration with no expression. + -- A deferred constant can appear in a package body if its completion + -- is by means of an interface pragma. if Constant_Present (N) and then No (E) then - if not Is_Package (Current_Scope) - or else In_Private_Part (Current_Scope) - then + if not Is_Package (Current_Scope) then Error_Msg_N ("invalid context for deferred constant declaration", N); Set_Constant_Present (N, False); @@ -1810,6 +1798,40 @@ package body Sem_Ch3 is Check_Restriction (No_Task_Hierarchy, N); Check_Potentially_Blocking_Operation (N); end if; + + -- A rather specialized test. If we see two tasks being declared + -- of the same type in the same object declaration, and the task + -- has an entry with an address clause, we know that program error + -- will be raised at run-time since we can't have two tasks with + -- entries at the same address. + + if Is_Task_Type (Etype (Id)) + and then More_Ids (N) + then + declare + E : Entity_Id; + + begin + E := First_Entity (Etype (Id)); + while Present (E) loop + if Ekind (E) = E_Entry + and then Present (Get_Attribute_Definition_Clause + (E, Attribute_Address)) + then + Error_Msg_N + ("?more than one task with same entry address", N); + Error_Msg_N + ("\?Program_Error will be raised at run time", N); + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Duplicated_Entry_Address)); + exit; + end if; + + Next_Entity (E); + end loop; + end; + end if; end if; -- Some simple constant-propagation: if the expression is a constant @@ -1879,6 +1901,8 @@ package body Sem_Ch3 is -- of the others choice will occur as part of the processing of the parent procedure Analyze_Others_Choice (N : Node_Id) is + pragma Warnings (Off, N); + begin null; end Analyze_Others_Choice; @@ -2179,7 +2203,6 @@ package body Sem_Ch3 is end if; when Concurrent_Kind => - Set_Ekind (Id, Subtype_Kind (Ekind (T))); Set_Corresponding_Record_Type (Id, Corresponding_Record_Type (T)); @@ -2504,13 +2527,7 @@ package body Sem_Ch3 is -- and the second parameter provides the reference location. Generate_Reference (T, T, 'c'); - - -- If in main unit, set as referenced, so we do not complain about - -- the full declaration being an unreferenced entity. - - if In_Extended_Main_Source_Unit (Def_Id) then - Set_Referenced (Def_Id); - end if; + Set_Completion_Referenced (Def_Id); -- For completion of incomplete type, process incomplete dependents -- and always mark the full type as referenced (it is the incomplete @@ -2519,13 +2536,7 @@ package body Sem_Ch3 is elsif Ekind (Prev) = E_Incomplete_Type then Process_Incomplete_Dependents (N, T, Prev); Generate_Reference (Prev, Def_Id, 'c'); - - -- If in main unit, set as referenced, so we do not complain about - -- the full declaration being an unreferenced entity. - - if In_Extended_Main_Source_Unit (Def_Id) then - Set_Referenced (Def_Id); - end if; + Set_Completion_Referenced (Def_Id); -- If not private type or incomplete type completion, this is a real -- definition of a new entity, so record it. @@ -2706,13 +2717,16 @@ package body Sem_Ch3 is Set_First_Index (Implicit_Base, First_Index (T)); Set_Component_Type (Implicit_Base, Element_Type); - Set_Has_Task (Implicit_Base, Has_Task (Element_Type)); + Set_Has_Task (Implicit_Base, Has_Task (Element_Type)); Set_Component_Size (Implicit_Base, Uint_0); - Set_Has_Controlled_Component (Implicit_Base, - Has_Controlled_Component (Element_Type) - or else Is_Controlled (Element_Type)); - Set_Finalize_Storage_Only (Implicit_Base, - Finalize_Storage_Only (Element_Type)); + Set_Has_Controlled_Component + (Implicit_Base, Has_Controlled_Component + (Element_Type) + or else + Is_Controlled (Element_Type)); + Set_Finalize_Storage_Only + (Implicit_Base, Finalize_Storage_Only + (Element_Type)); -- Unconstrained array case @@ -2725,15 +2739,16 @@ package body Sem_Ch3 is Set_Is_Constrained (T, False); Set_First_Index (T, First (Subtype_Marks (Def))); Set_Has_Delayed_Freeze (T, True); - Set_Has_Task (T, Has_Task (Element_Type)); - Set_Has_Controlled_Component (T, - Has_Controlled_Component (Element_Type) - or else Is_Controlled (Element_Type)); - Set_Finalize_Storage_Only (T, - Finalize_Storage_Only (Element_Type)); + Set_Has_Task (T, Has_Task (Element_Type)); + Set_Has_Controlled_Component (T, Has_Controlled_Component + (Element_Type) + or else + Is_Controlled (Element_Type)); + Set_Finalize_Storage_Only (T, Finalize_Storage_Only + (Element_Type)); end if; - Set_Component_Type (T, Element_Type); + Set_Component_Type (Base_Type (T), Element_Type); if Aliased_Present (Def) then Set_Has_Aliased_Components (Etype (T)); @@ -2742,10 +2757,10 @@ package body Sem_Ch3 is Priv := Private_Component (Element_Type); if Present (Priv) then - -- Check for circular definitions. + + -- Check for circular definitions if Priv = Any_Type then - Set_Component_Type (T, Any_Type); Set_Component_Type (Etype (T), Any_Type); -- There is a gap in the visiblity of operations on the composite @@ -2834,12 +2849,14 @@ package body Sem_Ch3 is begin Copy_Node (Pbase, Ibase); - Set_Chars (Ibase, Svg_Chars); - Set_Next_Entity (Ibase, Svg_Next_E); - Set_Sloc (Ibase, Sloc (Derived_Type)); - Set_Scope (Ibase, Scope (Derived_Type)); - Set_Freeze_Node (Ibase, Empty); - Set_Is_Frozen (Ibase, False); + Set_Chars (Ibase, Svg_Chars); + Set_Next_Entity (Ibase, Svg_Next_E); + Set_Sloc (Ibase, Sloc (Derived_Type)); + Set_Scope (Ibase, Scope (Derived_Type)); + Set_Freeze_Node (Ibase, Empty); + Set_Is_Frozen (Ibase, False); + Set_Comes_From_Source (Ibase, False); + Set_Is_First_Subtype (Ibase, False); Set_Etype (Ibase, Pbase); Set_Etype (Derived_Type, Ibase); @@ -3293,9 +3310,9 @@ package body Sem_Ch3 is begin if Nkind (R) = N_Range then Hi := Build_Scalar_Bound - (High_Bound (R), Parent_Type, Implicit_Base, Loc); + (High_Bound (R), Parent_Type, Implicit_Base); Lo := Build_Scalar_Bound - (Low_Bound (R), Parent_Type, Implicit_Base, Loc); + (Low_Bound (R), Parent_Type, Implicit_Base); else -- Constraint is a Range attribute. Replace with the @@ -3324,11 +3341,11 @@ package body Sem_Ch3 is Hi := Build_Scalar_Bound (Type_High_Bound (Parent_Type), - Parent_Type, Implicit_Base, Loc); + Parent_Type, Implicit_Base); Lo := Build_Scalar_Bound (Type_Low_Bound (Parent_Type), - Parent_Type, Implicit_Base, Loc); + Parent_Type, Implicit_Base); end if; Rang_Expr := @@ -3560,9 +3577,9 @@ package body Sem_Ch3 is -------------------------------- procedure Build_Derived_Private_Type - (N : Node_Id; - Parent_Type : Entity_Id; - Derived_Type : Entity_Id; + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id; Is_Completion : Boolean; Derive_Subps : Boolean := True) is @@ -3579,6 +3596,10 @@ package body Sem_Ch3 is -- Copy derived type declaration, replace parent with its full view, -- and analyze new declaration. + -------------------- + -- Copy_And_Build -- + -------------------- + procedure Copy_And_Build is Full_N : Node_Id; @@ -3729,18 +3750,34 @@ package body Sem_Ch3 is return; end if; - -- Inherit the discriminants of the full view, but - -- keep the proper parent type. + -- If full view of parent is a record type, Build full view as + -- a derivation from the parent's full view. Partial view remains + -- private. + + if not Is_Private_Type (Full_View (Parent_Type)) then + Full_Der := Make_Defining_Identifier (Sloc (Derived_Type), + Chars (Derived_Type)); + Set_Is_Itype (Full_Der); + Set_Has_Private_Declaration (Full_Der); + Set_Has_Private_Declaration (Derived_Type); + Set_Associated_Node_For_Itype (Full_Der, N); + Set_Parent (Full_Der, Parent (Derived_Type)); + Set_Full_View (Derived_Type, Full_Der); + + Full_P := Full_View (Parent_Type); + Exchange_Declarations (Parent_Type); + Copy_And_Build; + Exchange_Declarations (Full_P); - -- ??? this looks wrong, we are replacing (and thus, - -- erasing) the partial view! + else + Build_Derived_Record_Type + (N, Full_View (Parent_Type), Derived_Type, + Derive_Subps => False); + end if; -- In any case, the primitive operations are inherited from -- the parent type, not from the internal full view. - Build_Derived_Record_Type - (N, Full_View (Parent_Type), Derived_Type, - Derive_Subps => False); Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type)); if Derive_Subps then @@ -3748,8 +3785,7 @@ package body Sem_Ch3 is end if; else - - -- Untagged type, No discriminants on either view. + -- Untagged type, No discriminants on either view if Nkind (Subtype_Indication (Type_Definition (N))) = N_Subtype_Indication @@ -3767,17 +3803,17 @@ package body Sem_Ch3 is end if; Set_Girder_Constraint (Derived_Type, No_Elist); - Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); - Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); - Set_Has_Controlled_Component (Derived_Type, - Has_Controlled_Component (Parent_Type)); + Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); + Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); + Set_Has_Controlled_Component + (Derived_Type, Has_Controlled_Component + (Parent_Type)); - -- Direct controlled types do not inherit the Finalize_Storage_Only - -- flag. + -- Direct controlled types do not inherit Finalize_Storage_Only flag if not Is_Controlled (Parent_Type) then - Set_Finalize_Storage_Only (Derived_Type, - Finalize_Storage_Only (Parent_Type)); + Set_Finalize_Storage_Only + (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type)); end if; -- Construct the implicit full view by deriving from full @@ -3912,11 +3948,11 @@ package body Sem_Ch3 is -- type T (...) is new R (...) [with ...]; -- The representation clauses of T can specify a completely different - -- record layout from R's. Hence a same component can be placed in two very - -- different positions in objects of type T and R. If R and T are tagged - -- types, representation clauses for T can only specify the layout of non - -- inherited components, thus components that are common in R and T have - -- the same position in objects of type R or T. + -- record layout from R's. Hence the same component can be placed in + -- two very different positions in objects of type T and R. If R and T + -- are tagged types, representation clauses for T can only specify the + -- layout of non inherited components, thus components that are common + -- in R and T have the same position in objects of type R and T. -- This has two implications. The first is that the entire tree for R's -- declaration needs to be copied for T in the untagged case, so that @@ -4364,17 +4400,17 @@ package body Sem_Ch3 is New_Indic : Node_Id; Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type); - Discriminant_Specs : constant Boolean - := Present (Discriminant_Specifications (N)); - Private_Extension : constant Boolean - := (Nkind (N) = N_Private_Extension_Declaration); + Discriminant_Specs : constant Boolean := + Present (Discriminant_Specifications (N)); + Private_Extension : constant Boolean := + (Nkind (N) = N_Private_Extension_Declaration); Constraint_Present : Boolean; Inherit_Discrims : Boolean := False; - Save_Etype : Entity_Id; - Save_Discr_Constr : Elist_Id; - Save_Next_Entity : Entity_Id; + Save_Etype : Entity_Id; + Save_Discr_Constr : Elist_Id; + Save_Next_Entity : Entity_Id; begin if Ekind (Parent_Type) = E_Record_Type_With_Private @@ -4827,12 +4863,11 @@ package body Sem_Ch3 is Set_Has_Primitive_Operations (Derived_Type, Has_Primitive_Operations (Parent_Base)); - -- Direct controlled types do not inherit the Finalize_Storage_Only - -- flag. + -- Direct controlled types do not inherit Finalize_Storage_Only flag if not Is_Controlled (Parent_Type) then - Set_Finalize_Storage_Only (Derived_Type, - Finalize_Storage_Only (Parent_Type)); + Set_Finalize_Storage_Only + (Derived_Type, Finalize_Storage_Only (Parent_Type)); end if; -- Set fields for private derived types. @@ -4953,6 +4988,7 @@ package body Sem_Ch3 is (Derived_Type, Save_Discr_Constr); Set_Girder_Constraint (Derived_Type, Expand_To_Girder_Constraint (Parent_Base, Discs)); + Replace_Components (Derived_Type, New_Decl); end if; -- Insert the new derived type declaration @@ -5447,7 +5483,9 @@ package body Sem_Ch3 is is Has_Discrs : constant Boolean := Has_Discriminants (T); Constrained : constant Boolean - := (Has_Discrs and then not Is_Empty_Elmt_List (Elist)) + := (Has_Discrs + and then not Is_Empty_Elmt_List (Elist) + and then not Is_Class_Wide_Type (T)) or else Is_Constrained (T); begin @@ -5544,9 +5582,8 @@ package body Sem_Ch3 is function Build_Scalar_Bound (Bound : Node_Id; Par_T : Entity_Id; - Der_T : Entity_Id; - Loc : Source_Ptr) - return Node_Id + Der_T : Entity_Id) + return Node_Id is New_Bound : Entity_Id; @@ -5816,7 +5853,7 @@ package body Sem_Ch3 is if not Comes_From_Source (E) then pragma Assert - (Errors_Detected > 0 + (Serious_Errors_Detected > 0 or else Subunits_Missing or else not Expander_Active); return; @@ -6274,7 +6311,6 @@ package body Sem_Ch3 is Set_Primitive_Operations (Full, Primitive_Operations (Full_Base)); elsif Is_Concurrent_Type (Full_Base) then - if Has_Discriminants (Full) and then Present (Corresponding_Record_Type (Full_Base)) then @@ -6304,6 +6340,44 @@ package body Sem_Ch3 is Obj_Def : constant Node_Id := Object_Definition (N); New_T : Entity_Id; + procedure Check_Recursive_Declaration (Typ : Entity_Id); + -- If deferred constant is an access type initialized with an + -- allocator, check whether there is an illegal recursion in the + -- definition, through a default value of some record subcomponent. + -- This is normally detected when generating init_procs, but requires + -- this additional mechanism when expansion is disabled. + + procedure Check_Recursive_Declaration (Typ : Entity_Id) is + Comp : Entity_Id; + + begin + if Is_Record_Type (Typ) then + Comp := First_Component (Typ); + + while Present (Comp) loop + if Comes_From_Source (Comp) then + if Present (Expression (Parent (Comp))) + and then Is_Entity_Name (Expression (Parent (Comp))) + and then Entity (Expression (Parent (Comp))) = Prev + then + Error_Msg_Sloc := Sloc (Parent (Comp)); + Error_Msg_NE + ("illegal circularity with declaration for&#", + N, Comp); + return; + + elsif Is_Record_Type (Etype (Comp)) then + Check_Recursive_Declaration (Etype (Comp)); + end if; + end if; + + Next_Component (Comp); + end loop; + end if; + end Check_Recursive_Declaration; + + -- Start of processing for Constant_Redeclaration + begin if Nkind (Parent (Prev)) = N_Object_Declaration then if Nkind (Object_Definition @@ -6345,6 +6419,7 @@ package body Sem_Ch3 is if Ekind (Prev) /= E_Constant or else Present (Expression (Parent (Prev))) + or else Present (Full_View (Prev)) then Enter_Name (Id); @@ -6373,7 +6448,8 @@ package body Sem_Ch3 is Error_Msg_N ("ALIASED required (see declaration#)", N); end if; - -- Check that placement is in private part + -- Check that placement is in private part and that the incomplete + -- declaration appeared in the visible part. if Ekind (Current_Scope) = E_Package and then not In_Private_Part (Current_Scope) @@ -6381,6 +6457,21 @@ package body Sem_Ch3 is Error_Msg_Sloc := Sloc (Prev); Error_Msg_N ("full constant for declaration#" & " must be in private part", N); + + elsif Ekind (Current_Scope) = E_Package + and then List_Containing (Parent (Prev)) + /= Visible_Declarations + (Specification (Unit_Declaration_Node (Current_Scope))) + then + Error_Msg_N + ("deferred constant must be declared in visible part", + Parent (Prev)); + end if; + + if Is_Access_Type (T) + and then Nkind (Expression (N)) = N_Allocator + then + Check_Recursive_Declaration (Designated_Type (T)); end if; end if; end Constant_Redeclaration; @@ -6431,6 +6522,57 @@ package body Sem_Ch3 is return; end if; + if Ekind (T) = E_General_Access_Type + and then Has_Private_Declaration (Desig_Type) + and then In_Open_Scopes (Scope (Desig_Type)) + then + -- Enforce rule that the constraint is illegal if there is + -- an unconstrained view of the designated type. This means + -- that the partial view (either a private type declaration or + -- a derivation from a private type) has no discriminants. + -- (Defect Report 8652/0008, Technical Corrigendum 1, checked + -- by ACATS B371001). + + declare + Pack : Node_Id := Unit_Declaration_Node (Scope (Desig_Type)); + Decls : List_Id; + Decl : Node_Id; + + begin + if Nkind (Pack) = N_Package_Declaration then + Decls := Visible_Declarations (Specification (Pack)); + Decl := First (Decls); + + while Present (Decl) loop + if (Nkind (Decl) = N_Private_Type_Declaration + and then + Chars (Defining_Identifier (Decl)) = + Chars (Desig_Type)) + + or else + (Nkind (Decl) = N_Full_Type_Declaration + and then + Chars (Defining_Identifier (Decl)) = + Chars (Desig_Type) + and then Is_Derived_Type (Desig_Type) + and then + Has_Private_Declaration (Etype (Desig_Type))) + then + if No (Discriminant_Specifications (Decl)) then + Error_Msg_N + ("cannot constrain general access type " & + "if designated type has unconstrained view", S); + end if; + + exit; + end if; + + Next (Decl); + end loop; + end if; + end; + end if; + Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod, For_Access => True); @@ -6560,7 +6702,6 @@ package body Sem_Ch3 is Set_First_Index (Def_Id, First (Constraints (C))); end if; - Set_Component_Type (Def_Id, Component_Type (T)); Set_Is_Constrained (Def_Id, True); Set_Is_Aliased (Def_Id, Is_Aliased (T)); Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); @@ -6621,7 +6762,7 @@ package body Sem_Ch3 is function Is_Discriminant (Expr : Node_Id) return Boolean; -- Returns True if Expr is a discriminant. - function Get_Value (Discrim : Entity_Id) return Node_Id; + function Get_Discr_Value (Discrim : Entity_Id) return Node_Id; -- Find the value of discriminant Discrim in Constraint. ----------------------------------- @@ -6749,11 +6890,11 @@ package body Sem_Ch3 is Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); if Is_Discriminant (Lo_Expr) then - Lo_Expr := Get_Value (Lo_Expr); + Lo_Expr := Get_Discr_Value (Lo_Expr); end if; if Is_Discriminant (Hi_Expr) then - Hi_Expr := Get_Value (Hi_Expr); + Hi_Expr := Get_Discr_Value (Hi_Expr); end if; Range_Node := @@ -6806,7 +6947,7 @@ package body Sem_Ch3 is Expr := Node (Old_Constraint); if Is_Discriminant (Expr) then - Expr := Get_Value (Expr); + Expr := Get_Discr_Value (Expr); end if; Append (New_Copy_Tree (Expr), To => Constr_List); @@ -6867,21 +7008,24 @@ package body Sem_Ch3 is return Def_Id; end Build_Subtype; - --------------- - -- Get_Value -- - --------------- + --------------------- + -- Get_Discr_Value -- + --------------------- - function Get_Value (Discrim : Entity_Id) return Node_Id is + function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is D : Entity_Id := First_Discriminant (Typ); E : Elmt_Id := First_Elmt (Constraints); + G : Elmt_Id; begin - while Present (D) loop - - -- If we are constraining the subtype of a derived tagged type, - -- recover the discriminant of the parent, which appears in - -- the constraint of an inherited component. + -- The discriminant may be declared for the type, in which case we + -- find it by iterating over the list of discriminants. If the + -- discriminant is inherited from a parent type, it appears as the + -- corresponding discriminant of the current type. This will be the + -- case when constraining an inherited component whose constraint is + -- given by a discriminant of the parent. + while Present (D) loop if D = Entity (Discrim) or else Corresponding_Discriminant (D) = Entity (Discrim) then @@ -6892,10 +7036,35 @@ package body Sem_Ch3 is Next_Elmt (E); end loop; + -- The corresponding_Discriminant mechanism is incomplete, because + -- the correspondence between new and old discriminants is not one + -- to one: one new discriminant can constrain several old ones. + -- In that case, scan sequentially the girder_constraint, the list + -- of discriminants of the parents, and the constraints. + + if Is_Derived_Type (Typ) + and then Present (Girder_Constraint (Typ)) + and then Scope (Entity (Discrim)) = Etype (Typ) + then + D := First_Discriminant (Etype (Typ)); + E := First_Elmt (Constraints); + G := First_Elmt (Girder_Constraint (Typ)); + + while Present (D) loop + if D = Entity (Discrim) then + return Node (E); + end if; + + Next_Discriminant (D); + Next_Elmt (E); + Next_Elmt (G); + end loop; + end if; + -- Something is wrong if we did not find the value raise Program_Error; - end Get_Value; + end Get_Discr_Value; --------------------- -- Is_Discriminant -- @@ -7052,11 +7221,7 @@ package body Sem_Ch3 is -- Constrain_Decimal -- ----------------------- - procedure Constrain_Decimal - (Def_Id : Node_Id; - S : Node_Id; - Related_Nod : Node_Id) - is + procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is T : constant Entity_Id := Entity (Subtype_Mark (S)); C : constant Node_Id := Constraint (S); Loc : constant Source_Ptr := Sloc (C); @@ -7115,7 +7280,7 @@ package body Sem_Ch3 is end if; - Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T, Related_Nod); + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T); Set_Discrete_RM_Size (Def_Id); -- Unconditionally delay the freeze, since we cannot set size @@ -7134,6 +7299,7 @@ package body Sem_Ch3 is Related_Nod : Node_Id; For_Access : Boolean := False) is + E : constant Entity_Id := Entity (Subtype_Mark (S)); T : Entity_Id; C : Node_Id; Elist : Elist_Id := New_Elmt_List; @@ -7181,7 +7347,10 @@ package body Sem_Ch3 is Fixup_Bad_Constraint; return; - elsif Is_Constrained (Entity (Subtype_Mark (S))) then + elsif Is_Constrained (E) + or else (Ekind (E) = E_Class_Wide_Subtype + and then Present (Discriminant_Constraint (E))) + then Error_Msg_N ("type is already constrained", Subtype_Mark (S)); Fixup_Bad_Constraint; return; @@ -7210,11 +7379,7 @@ package body Sem_Ch3 is -- Constrain_Enumeration -- --------------------------- - procedure Constrain_Enumeration - (Def_Id : Node_Id; - S : Node_Id; - Related_Nod : Node_Id) - is + procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is T : constant Entity_Id := Entity (Subtype_Mark (S)); C : constant Node_Id := Constraint (S); @@ -7228,8 +7393,7 @@ package body Sem_Ch3 is Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); - Set_Scalar_Range_For_Subtype - (Def_Id, Range_Expression (C), T, Related_Nod); + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); Set_Discrete_RM_Size (Def_Id); @@ -7239,11 +7403,7 @@ package body Sem_Ch3 is -- Constrain_Float -- ---------------------- - procedure Constrain_Float - (Def_Id : Node_Id; - S : Node_Id; - Related_Nod : Node_Id) - is + procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is T : constant Entity_Id := Entity (Subtype_Mark (S)); C : Node_Id; D : Node_Id; @@ -7275,7 +7435,9 @@ package body Sem_Ch3 is if Digits_Value (Def_Id) > Digits_Value (T) then Error_Msg_Uint_1 := Digits_Value (T); Error_Msg_N ("?digits value is too large, maximum is ^", D); - Rais := Make_Raise_Constraint_Error (Sloc (D)); + Rais := + Make_Raise_Constraint_Error (Sloc (D), + Reason => CE_Range_Check_Failed); Insert_Action (Declaration_Node (Def_Id), Rais); end if; @@ -7290,8 +7452,7 @@ package body Sem_Ch3 is -- Range constraint present if Nkind (C) = N_Range_Constraint then - Set_Scalar_Range_For_Subtype - (Def_Id, Range_Expression (C), T, Related_Nod); + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); -- No range constraint present @@ -7344,8 +7505,7 @@ package body Sem_Ch3 is Checks_Off := True; end if; - Process_Range_Expr_In_Decl - (R, T, Related_Nod, Empty_List, Checks_Off); + Process_Range_Expr_In_Decl (R, T, Empty_List, Checks_Off); if not Error_Posted (S) and then @@ -7428,17 +7588,12 @@ package body Sem_Ch3 is -- Constrain_Integer -- ----------------------- - procedure Constrain_Integer - (Def_Id : Node_Id; - S : Node_Id; - Related_Nod : Node_Id) - is + procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is T : constant Entity_Id := Entity (Subtype_Mark (S)); C : constant Node_Id := Constraint (S); begin - Set_Scalar_Range_For_Subtype - (Def_Id, Range_Expression (C), T, Related_Nod); + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); if Is_Modular_Integer_Type (T) then Set_Ekind (Def_Id, E_Modular_Integer_Subtype); @@ -7457,11 +7612,7 @@ package body Sem_Ch3 is -- Constrain_Ordinary_Fixed -- ------------------------------ - procedure Constrain_Ordinary_Fixed - (Def_Id : Node_Id; - S : Node_Id; - Related_Nod : Node_Id) - is + procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is T : constant Entity_Id := Entity (Subtype_Mark (S)); C : Node_Id; D : Node_Id; @@ -7492,7 +7643,9 @@ package body Sem_Ch3 is if Delta_Value (Def_Id) < Delta_Value (T) then Error_Msg_N ("?delta value is too small", D); - Rais := Make_Raise_Constraint_Error (Sloc (D)); + Rais := + Make_Raise_Constraint_Error (Sloc (D), + Reason => CE_Range_Check_Failed); Insert_Action (Declaration_Node (Def_Id), Rais); end if; @@ -7507,8 +7660,7 @@ package body Sem_Ch3 is -- Range constraint present if Nkind (C) = N_Range_Constraint then - Set_Scalar_Range_For_Subtype - (Def_Id, Range_Expression (C), T, Related_Nod); + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); -- No range constraint present @@ -7545,11 +7697,11 @@ package body Sem_Ch3 is begin Lo := Build_Scalar_Bound (Type_Low_Bound (Derived_Type), - Parent_Type, Implicit_Base, Loc); + Parent_Type, Implicit_Base); Hi := Build_Scalar_Bound (Type_High_Bound (Derived_Type), - Parent_Type, Implicit_Base, Loc); + Parent_Type, Implicit_Base); Rng := Make_Range (Loc, @@ -8609,6 +8761,7 @@ package body Sem_Ch3 is if Is_Tagged_Type (T) then Set_Primitive_Operations (T, New_Elmt_List); end if; + return; elsif Is_Unchecked_Union (Parent_Type) then @@ -8818,6 +8971,12 @@ package body Sem_Ch3 is then Set_Discard_Names (T); end if; + + -- Process end label if there is one + + if Present (Def) then + Process_End_Label (Def, 'e', T); + end if; end Enumeration_Type_Declaration; -------------------------- @@ -9174,9 +9333,22 @@ package body Sem_Ch3 is end if; Copy_And_Swap (Prev, Id); - Set_Full_View (Id, Prev); Set_Has_Private_Declaration (Prev); Set_Has_Private_Declaration (Id); + + -- If no error, propagate freeze_node from private to full view. + -- It may have been generated for an early operational item. + + if Present (Freeze_Node (Id)) + and then Serious_Errors_Detected = 0 + and then No (Full_View (Id)) + then + Set_Freeze_Node (Prev, Freeze_Node (Id)); + Set_Freeze_Node (Id, Empty); + Set_First_Rep_Item (Prev, First_Rep_Item (Id)); + end if; + + Set_Full_View (Id, Prev); New_Id := Prev; end if; @@ -10190,17 +10362,22 @@ package body Sem_Ch3 is Set_Has_Delayed_Freeze (CW_Type); -- Customize the class-wide type: It has no prim. op., it cannot be - -- abstract and its Etype points back to the root type + -- abstract and its Etype points back to the specific root type. Set_Ekind (CW_Type, E_Class_Wide_Type); Set_Is_Tagged_Type (CW_Type, True); Set_Primitive_Operations (CW_Type, New_Elmt_List); Set_Is_Abstract (CW_Type, False); - Set_Etype (CW_Type, T); Set_Is_Constrained (CW_Type, False); Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); Init_Size_Align (CW_Type); + if Ekind (T) = E_Class_Wide_Subtype then + Set_Etype (CW_Type, Etype (Base_Type (T))); + else + Set_Etype (CW_Type, T); + end if; + -- If this is the class_wide type of a constrained subtype, it does -- not have discriminants. @@ -10317,7 +10494,7 @@ package body Sem_Ch3 is end if; R := I; - Process_Range_Expr_In_Decl (R, T, Related_Nod); + Process_Range_Expr_In_Decl (R, T); elsif Nkind (I) = N_Subtype_Indication then @@ -10334,8 +10511,7 @@ package body Sem_Ch3 is R := Range_Expression (Constraint (I)); Resolve (R, T); - Process_Range_Expr_In_Decl (R, - Entity (Subtype_Mark (I)), Related_Nod); + Process_Range_Expr_In_Decl (R, Entity (Subtype_Mark (I))); elsif Nkind (I) = N_Attribute_Reference then @@ -11369,7 +11545,6 @@ package body Sem_Ch3 is procedure Process_Range_Expr_In_Decl (R : Node_Id; T : Entity_Id; - Related_Nod : Node_Id; Check_List : List_Id := Empty_List; R_Check_Off : Boolean := False) is @@ -11693,19 +11868,19 @@ package body Sem_Ch3 is Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); when Decimal_Fixed_Point_Kind => - Constrain_Decimal (Def_Id, S, N_Dynamic_Ityp); + Constrain_Decimal (Def_Id, S); when Enumeration_Kind => - Constrain_Enumeration (Def_Id, S, N_Dynamic_Ityp); + Constrain_Enumeration (Def_Id, S); when Ordinary_Fixed_Point_Kind => - Constrain_Ordinary_Fixed (Def_Id, S, N_Dynamic_Ityp); + Constrain_Ordinary_Fixed (Def_Id, S); when Float_Kind => - Constrain_Float (Def_Id, S, N_Dynamic_Ityp); + Constrain_Float (Def_Id, S); when Integer_Kind => - Constrain_Integer (Def_Id, S, N_Dynamic_Ityp); + Constrain_Integer (Def_Id, S); when E_Record_Type | E_Record_Subtype | @@ -11787,7 +11962,7 @@ package body Sem_Ch3 is -- private tagged types where the full view omits the word tagged. Is_Tagged := Tagged_Present (Def) - or else (Errors_Detected > 0 and then Is_Tagged_Type (T)); + or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T)); -- Records constitute a scope for the component declarations within. -- The scope is created prior to the processing of these declarations. @@ -11943,10 +12118,75 @@ package body Sem_Ch3 is end if; if Present (Def) then - Process_End_Label (Def, 'e'); + Process_End_Label (Def, 'e', T); end if; end Record_Type_Definition; + ------------------------ + -- Replace_Components -- + ------------------------ + + procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id) is + function Process (N : Node_Id) return Traverse_Result; + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + Comp : Entity_Id; + + begin + if Nkind (N) = N_Discriminant_Specification then + Comp := First_Discriminant (Typ); + + while Present (Comp) loop + if Chars (Comp) = Chars (Defining_Identifier (N)) then + Set_Defining_Identifier (N, Comp); + exit; + end if; + + Next_Discriminant (Comp); + end loop; + + elsif Nkind (N) = N_Component_Declaration then + Comp := First_Component (Typ); + + while Present (Comp) loop + if Chars (Comp) = Chars (Defining_Identifier (N)) then + Set_Defining_Identifier (N, Comp); + exit; + end if; + + Next_Component (Comp); + end loop; + end if; + + return OK; + end Process; + + procedure Replace is new Traverse_Proc (Process); + + -- Start of processing for Replace_Components + + begin + Replace (Decl); + end Replace_Components; + + ------------------------------- + -- Set_Completion_Referenced -- + ------------------------------- + + procedure Set_Completion_Referenced (E : Entity_Id) is + begin + -- If in main unit, mark entity that is a completion as referenced, + -- warnings go on the partial view when needed. + + if In_Extended_Main_Source_Unit (E) then + Set_Referenced (E); + end if; + end Set_Completion_Referenced; + --------------------- -- Set_Fixed_Range -- --------------------- @@ -12021,10 +12261,9 @@ package body Sem_Ch3 is ---------------------------------- procedure Set_Scalar_Range_For_Subtype - (Def_Id : Entity_Id; - R : Node_Id; - Subt : Entity_Id; - Related_Nod : Node_Id) + (Def_Id : Entity_Id; + R : Node_Id; + Subt : Entity_Id) is Kind : constant Entity_Kind := Ekind (Def_Id); begin @@ -12044,7 +12283,7 @@ package body Sem_Ch3 is -- catch possible premature use in the bounds themselves. Set_Ekind (Def_Id, E_Void); - Process_Range_Expr_In_Decl (R, Subt, Related_Nod); + Process_Range_Expr_In_Decl (R, Subt); Set_Ekind (Def_Id, Kind); end Set_Scalar_Range_For_Subtype; diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 5a1671feccd..fd379bc231c 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -186,7 +186,6 @@ package Sem_Ch3 is procedure Process_Range_Expr_In_Decl (R : Node_Id; T : Entity_Id; - Related_Nod : Node_Id; Check_List : List_Id := Empty_List; R_Check_Off : Boolean := False); -- Process a range expression that appears in a declaration context. The @@ -216,6 +215,12 @@ package Sem_Ch3 is -- Process the discriminants contained in an N_Full_Type_Declaration or -- N_Incomplete_Type_Decl node N. + procedure Set_Completion_Referenced (E : Entity_Id); + -- If E is the completion of a private or incomplete type declaration, + -- or the completion of a deferred constant declaration, mark the entity + -- as referenced. Warnings on unused entities, if needed, go on the + -- partial view. + procedure Set_Girder_Constraint_From_Discriminant_Constraint (E : Entity_Id); -- E is some record type. This routine computes E's Girder_Constraint diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index bdb2c8b8449..a625f352020 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -341,7 +341,7 @@ package body Sem_Ch4 is procedure Analyze_Allocator (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Sav_Errs : constant Nat := Errors_Detected; + Sav_Errs : constant Nat := Serious_Errors_Detected; E : Node_Id := Expression (N); Acc_Type : Entity_Id; Type_Id : Entity_Id; @@ -441,7 +441,7 @@ package body Sem_Ch4 is Defining_Identifier => Def_Id, Subtype_Indication => Relocate_Node (E))); - if Sav_Errs /= Errors_Detected + if Sav_Errs /= Serious_Errors_Detected and then Nkind (Constraint (E)) = N_Index_Or_Discriminant_Constraint then @@ -467,7 +467,7 @@ package body Sem_Ch4 is -- are probably cascaded errors if Is_Indefinite_Subtype (Type_Id) - and then Errors_Detected = Sav_Errs + and then Serious_Errors_Detected = Sav_Errs then if Is_Class_Wide_Type (Type_Id) then Error_Msg_N @@ -494,7 +494,7 @@ package body Sem_Ch4 is Check_Restriction (No_Local_Allocators, N); end if; - if Errors_Detected > Sav_Errs then + if Serious_Errors_Detected > Sav_Errs then Set_Error_Posted (N); Set_Etype (N, Any_Type); end if; @@ -1335,6 +1335,10 @@ package body Sem_Ch4 is if Is_Access_Type (Array_Type) then Array_Type := Designated_Type (Array_Type); + + if Warn_On_Dereference then + Error_Msg_N ("?implicit dereference", N); + end if; end if; if Is_Array_Type (Array_Type) then @@ -1498,6 +1502,10 @@ package body Sem_Ch4 is if Is_Access_Type (Typ) then Typ := Designated_Type (Typ); + + if Warn_On_Dereference then + Error_Msg_N ("?implicit dereference", N); + end if; end if; if Is_Array_Type (Typ) then @@ -2169,6 +2177,11 @@ package body Sem_Ch4 is while Present (It.Typ) loop if Is_Access_Type (It.Typ) then T := Designated_Type (It.Typ); + + if Warn_On_Dereference then + Error_Msg_N ("?implicit dereference", N); + end if; + else T := It.Typ; end if; @@ -2219,6 +2232,10 @@ package body Sem_Ch4 is if Is_Access_Type (Etype (Nam)) then Insert_Explicit_Dereference (Nam); + + if Warn_On_Dereference then + Error_Msg_N ("?implicit dereference", N); + end if; end if; end if; @@ -2226,7 +2243,6 @@ package body Sem_Ch4 is end loop; Set_Is_Overloaded (N, Is_Overloaded (Sel)); - end if; Get_Next_Interp (I, It); @@ -2414,18 +2430,27 @@ package body Sem_Ch4 is end if; if Is_Access_Type (Prefix_Type) then + + -- A RACW object can never be used as prefix of a selected + -- component since that means it is dereferenced without + -- being a controlling operand of a dispatching operation + -- (RM E.2.2(15)). + if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type) and then Comes_From_Source (N) then - -- A RACW object can never be used as prefix of a selected - -- component since that means it is dereferenced without - -- being a controlling operand of a dispatching operation - -- (RM E.2.2(15)). - Error_Msg_N ("invalid dereference of a remote access to class-wide value", N); + + -- Normal case of selected component applied to access type + + else + if Warn_On_Dereference then + Error_Msg_N ("?implicit dereference", N); + end if; end if; + Prefix_Type := Designated_Type (Prefix_Type); end if; @@ -2466,6 +2491,10 @@ package body Sem_Ch4 is if Is_Access_Type (Etype (Name)) then Insert_Explicit_Dereference (Name); + + if Warn_On_Dereference then + Error_Msg_N ("?implicit dereference", N); + end if; end if; elsif Is_Record_Type (Prefix_Type) then @@ -2656,6 +2685,10 @@ package body Sem_Ch4 is if Is_Access_Type (Etype (Name)) then Insert_Explicit_Dereference (Name); + + if Warn_On_Dereference then + Error_Msg_N ("?implicit dereference", N); + end if; end if; end if; @@ -2693,6 +2726,7 @@ package body Sem_Ch4 is elsif Is_Generic_Type (Prefix_Type) and then Ekind (Prefix_Type) = E_Record_Type_With_Private + and then Prefix_Type /= Etype (Prefix_Type) and then Is_Record_Type (Etype (Prefix_Type)) then -- If this is a derived formal type, the parent may have a @@ -2730,6 +2764,7 @@ package body Sem_Ch4 is Apply_Compile_Time_Constraint_Error (N, "component not present in }?", + CE_Discriminant_Check_Failed, Ent => Prefix_Type, Rep => False); Set_Raises_Constraint_Error (N); return; @@ -2831,6 +2866,10 @@ package body Sem_Ch4 is if Is_Access_Type (Typ) then Typ := Designated_Type (Typ); + + if Warn_On_Dereference then + Error_Msg_N ("?implicit dereference", N); + end if; end if; if Is_Array_Type (Typ) @@ -2868,6 +2907,10 @@ package body Sem_Ch4 is if Is_Access_Type (Array_Type) then Array_Type := Designated_Type (Array_Type); + + if Warn_On_Dereference then + Error_Msg_N ("?implicit dereference", N); + end if; end if; if not Is_Array_Type (Array_Type) then diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 9386a19af6b..bf70923ba9b 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.3 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -436,7 +436,7 @@ package body Sem_Ch5 is end if; Analyze (Handled_Statement_Sequence (N)); - Process_End_Label (Handled_Statement_Sequence (N), 'e'); + Process_End_Label (Handled_Statement_Sequence (N), 'e', Ent); -- Analyze exception handlers if present. Note that the test for -- HSS being present is an error defence against previous errors. @@ -1093,7 +1093,7 @@ package body Sem_Ch5 is New_Scope (Ent); Analyze_Iteration_Scheme (Iteration_Scheme (N)); Analyze_Statements (Statements (N)); - Process_End_Label (N, 'e'); + Process_End_Label (N, 'e', Ent); End_Scope; end Analyze_Loop_Statement; @@ -1105,6 +1105,8 @@ package body Sem_Ch5 is -- null statement, too bad everything isn't as simple as this! procedure Analyze_Null_Statement (N : Node_Id) is + pragma Warnings (Off, N); + begin null; end Analyze_Null_Statement; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index dcec5bae7e1..467c8916398 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -34,7 +34,6 @@ with Elists; use Elists; with Errout; use Errout; with Expander; use Expander; with Exp_Ch7; use Exp_Ch7; -with Fname; use Fname; with Freeze; use Freeze; with Lib.Xref; use Lib.Xref; with Namet; use Namet; @@ -96,6 +95,8 @@ package body Sem_Ch6 is type Conformance_Type is (Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant); + -- Conformance type used for following call, meaning matches the + -- RM definitions of the corresponding terms. procedure Check_Conformance (New_Id : Entity_Id; @@ -707,7 +708,9 @@ package body Sem_Ch6 is and then Object_Access_Level (Expr) > Subprogram_Access_Level (Scope_Id) then - Rewrite (N, Make_Raise_Program_Error (Loc)); + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)); Analyze (N); Error_Msg_N @@ -785,7 +788,7 @@ package body Sem_Ch6 is if Present (Formals) then Set_Scope (Designator, Current_Scope); New_Scope (Designator); - Process_Formals (Designator, Formals, N); + Process_Formals (Formals, N); End_Scope; end if; @@ -829,6 +832,7 @@ package body Sem_Ch6 is Conformant : Boolean; Missing_Ret : Boolean; Body_Deleted : Boolean := False; + P_Ent : Entity_Id; begin if Debug_Flag_C then @@ -916,14 +920,46 @@ package body Sem_Ch6 is end if; end if; + -- Do not inline any subprogram that contains nested subprograms, + -- since the backend inlining circuit seems to generate uninitialized + -- references in this case. We know this happens in the case of front + -- end ZCX support, but it also appears it can happen in other cases + -- as well. The backend often rejects attempts to inline in the case + -- of nested procedures anyway, so little if anything is lost by this. + + -- Do not do this test if errors have been detected, because in some + -- error cases, this code blows up, and we don't need it anyway if + -- there have been errors, since we won't get to the linker anyway. + + if Serious_Errors_Detected = 0 then + P_Ent := Body_Id; + loop + P_Ent := Scope (P_Ent); + exit when No (P_Ent) or else P_Ent = Standard_Standard; + + if Is_Subprogram (P_Ent) and then Is_Inlined (P_Ent) then + Set_Is_Inlined (P_Ent, False); + + if Comes_From_Source (P_Ent) + and then Ineffective_Inline_Warnings + and then Has_Pragma_Inline (P_Ent) + then + Error_Msg_NE + ("?pragma Inline for & ignored (has nested subprogram)", + Get_Rep_Pragma (P_Ent, Name_Inline), P_Ent); + end if; + end if; + end loop; + end if; + + -- Case of fully private operation in the body of the protected type. + -- We must create a declaration for the subprogram, in order to attach + -- the protected subprogram that will be used in internal calls. + if No (Spec_Id) and then Comes_From_Source (N) and then Is_Protected_Type (Current_Scope) then - -- Fully private operation in the body of the protected type. We - -- must create a declaration for the subprogram, in order to attach - -- the protected subprogram that will be used in internal calls. - declare Decl : Node_Id; Plist : List_Id; @@ -998,7 +1034,7 @@ package body Sem_Ch6 is -- is a spec, the visible entity remains that of the spec. if Present (Spec_Id) then - Generate_Reference (Spec_Id, Body_Id, 'b'); + Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False); Style.Check_Identifier (Body_Id, Spec_Id); Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); @@ -1050,7 +1086,9 @@ package body Sem_Ch6 is end if; -- Generate references from body formals to spec formals - -- and also set the Spec_Entity fields for all formals + -- and also set the Spec_Entity fields for all formals. We + -- do not set this reference count as a reference for the + -- purposes of identifying unreferenced formals however. if Spec_Id /= Body_Id then declare @@ -1064,6 +1102,7 @@ package body Sem_Ch6 is Generate_Reference (Fs, Fb, 'b'); Style.Check_Identifier (Fb, Fs); Set_Spec_Entity (Fb, Fs); + Set_Referenced (Fs, False); Next_Formal (Fs); Next_Formal (Fb); end loop; @@ -1150,49 +1189,16 @@ package body Sem_Ch6 is elsif Present (Spec_Id) and then Expander_Active - and then Has_Pragma_Inline (Spec_Id) - and then (Front_End_Inlining - or else - (No_Run_Time and then Is_Always_Inlined (Spec_Id))) + and then (Is_Always_Inlined (Spec_Id) + or else (Has_Pragma_Inline (Spec_Id) + and then + (Front_End_Inlining or else No_Run_Time))) then if Build_Body_To_Inline (N, Spec_Id, Copy_Separate_Tree (N)) then null; end if; end if; - -- Here we have a real body, not a stub. First step is to null out - -- the subprogram body if we have the special case of no run time - -- mode with a predefined unit, and the subprogram is not marked - -- as Inline_Always. The reason is that we should never call such - -- a routine in no run time mode, and it may in general have some - -- statements that we cannot handle in no run time mode. - - -- ASIS note: we do a replace here, because we are really NOT going - -- to analyze the original body and declarations at all, so it is - -- useless to keep them around, we really are obliterating the body, - -- basically creating a specialized no run time version on the fly - -- in which the bodies *are* null. - - if No_Run_Time - and then Present (Spec_Id) - and then Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Loc))) - and then not Is_Always_Inlined (Spec_Id) - then - Replace (N, - Make_Subprogram_Body (Loc, - Specification => Specification (N), - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Null_Statement (Loc)), - End_Label => - End_Label (Handled_Statement_Sequence (N))))); - Set_Corresponding_Spec (N, Spec_Id); - Body_Deleted := True; - end if; - -- Now we can go on to analyze the body HSS := Handled_Statement_Sequence (N); @@ -1200,7 +1206,7 @@ package body Sem_Ch6 is Analyze_Declarations (Declarations (N)); Check_Completion; Analyze (HSS); - Process_End_Label (HSS, 't'); + Process_End_Label (HSS, 't', Current_Scope); End_Scope; Check_Subprogram_Order (N); @@ -2707,7 +2713,8 @@ package body Sem_Ch6 is Type_2 : Entity_Id := T2; function Base_Types_Match (T1, T2 : Entity_Id) return Boolean; - -- If neither T1 nor T2 are generic actual types, then verify + -- If neither T1 nor T2 are generic actual types, or if they are + -- in different scopes (e.g. parent and child instances), then verify -- that the base types are equal. Otherwise T1 and T2 must be -- on the same subtype chain. The whole purpose of this procedure -- is to prevent spurious ambiguities in an instantiation that may @@ -2730,7 +2737,8 @@ package body Sem_Ch6 is -- other ???. return not Is_Generic_Actual_Type (T1) - or else not Is_Generic_Actual_Type (T2); + or else not Is_Generic_Actual_Type (T2) + or else Scope (T1) /= Scope (T2); else return False; @@ -3137,7 +3145,13 @@ package body Sem_Ch6 is and then not In_Instance then Error_Msg_Sloc := Sloc (E); - Error_Msg_NE ("duplicate body for & declared#", N, E); + if Is_Imported (E) then + Error_Msg_NE + ("body not allowed for imported subprogram & declared#", + N, E); + else + Error_Msg_NE ("duplicate body for & declared#", N, E); + end if; end if; elsif Is_Child_Unit (E) @@ -3958,6 +3972,7 @@ package body Sem_Ch6 is procedure Maybe_Primitive_Operation (Overriding : Boolean := False) is Formal : Entity_Id; F_Typ : Entity_Id; + B_Typ : Entity_Id; function Visible_Part_Type (T : Entity_Id) return Boolean; -- Returns true if T is declared in the visible part of @@ -4010,8 +4025,8 @@ package body Sem_Ch6 is ----------------------- function Visible_Part_Type (T : Entity_Id) return Boolean is - P : Node_Id := Unit_Declaration_Node (Scope (T)); - N : Node_Id := First (Visible_Declarations (Specification (P))); + P : constant Node_Id := Unit_Declaration_Node (Scope (T)); + N : Node_Id; begin -- If the entity is a private type, then it must be @@ -4027,6 +4042,7 @@ package body Sem_Ch6 is -- private type is the one in the full view, which does not -- indicate that it is the completion of something visible. + N := First (Visible_Declarations (Specification (P))); while Present (N) loop if Nkind (N) = N_Full_Type_Declaration and then Present (Defining_Identifier (N)) @@ -4059,16 +4075,20 @@ package body Sem_Ch6 is and then not In_Package_Body (Current_Scope)) or else Overriding then + -- For function, check return type - if Ekind (S) = E_Function - and then Scope (Base_Type (Etype (S))) = Current_Scope - then - Set_Has_Primitive_Operations (Base_Type (Etype (S))); - Check_Private_Overriding (Base_Type (Etype (S))); + if Ekind (S) = E_Function then + B_Typ := Base_Type (Etype (S)); + + if Scope (B_Typ) = Current_Scope then + Set_Has_Primitive_Operations (B_Typ); + Check_Private_Overriding (B_Typ); + end if; end if; - Formal := First_Formal (S); + -- For all subprograms, check formals + Formal := First_Formal (S); while Present (Formal) loop if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then F_Typ := Designated_Type (Etype (Formal)); @@ -4076,14 +4096,15 @@ package body Sem_Ch6 is F_Typ := Etype (Formal); end if; - if Scope (Base_Type (F_Typ)) = Current_Scope then - Set_Has_Primitive_Operations (Base_Type (F_Typ)); - Check_Private_Overriding (Base_Type (F_Typ)); + B_Typ := Base_Type (F_Typ); + + if Scope (B_Typ) = Current_Scope then + Set_Has_Primitive_Operations (B_Typ); + Check_Private_Overriding (B_Typ); end if; Next_Formal (Formal); end loop; - end if; end Maybe_Primitive_Operation; @@ -4446,8 +4467,7 @@ package body Sem_Ch6 is --------------------- procedure Process_Formals - (S : Entity_Id; - T : List_Id; + (T : List_Id; Related_Nod : Node_Id) is Param_Spec : Node_Id; @@ -4456,6 +4476,25 @@ package body Sem_Ch6 is Default : Node_Id; Ptype : Entity_Id; + function Is_Class_Wide_Default (D : Node_Id) return Boolean; + -- Check whether the default has a class-wide type. After analysis + -- the default has the type of the formal, so we must also check + -- explicitly for an access attribute. + + --------------------------- + -- Is_Class_Wide_Default -- + --------------------------- + + function Is_Class_Wide_Default (D : Node_Id) return Boolean is + begin + return Is_Class_Wide_Type (Designated_Type (Etype (D))) + or else (Nkind (D) = N_Attribute_Reference + and then Attribute_Name (D) = Name_Access + and then Is_Class_Wide_Type (Etype (Prefix (D)))); + end Is_Class_Wide_Default; + + -- Start of processing for Process_Formals + begin -- In order to prevent premature use of the formals in the same formal -- part, the Ekind is left undefined until all default expressions are @@ -4524,10 +4563,11 @@ package body Sem_Ch6 is -- designated type is also class-wide. if Ekind (Formal_Type) = E_Anonymous_Access_Type - and then Is_Class_Wide_Type (Designated_Type (Etype (Default))) + and then Is_Class_Wide_Default (Default) and then not Is_Class_Wide_Type (Designated_Type (Formal_Type)) then - Wrong_Type (Default, Formal_Type); + Error_Msg_N + ("access to class-wide expression not allowed here", Default); end if; end if; diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index beb47569a42..f1ae676b673 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.22 $ -- +-- $Revision$ -- -- --- Copyright (C) 1992,1993,1994,1995,1996 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- -- @@ -136,10 +136,7 @@ package Sem_Ch6 is -- If Derived_Type is not Empty, then it indicates that this -- is subprogram derived for that type. - procedure Process_Formals ( - S : Entity_Id; - T : List_Id; - Related_Nod : Node_Id); + procedure Process_Formals (T : List_Id; Related_Nod : Node_Id); -- Enter the formals in the scope of the subprogram or entry, and -- analyze default expressions if any. The implicit types created for -- access parameter are attached to the Related_Nod which comes from the diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 21507a8a5f5..7d8cad1ab5f 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.3 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -300,7 +300,7 @@ package body Sem_Ch7 is HSS := Handled_Statement_Sequence (N); if Present (HSS) then - Process_End_Label (HSS, 't'); + Process_End_Label (HSS, 't', Spec_Id); Analyze (HSS); -- Check that elaboration code in a preelaborable package body is @@ -316,7 +316,7 @@ package body Sem_Ch7 is -- because the call will use In_Extended_Main_Source_Unit as a check, -- and we want to make sure that Corresponding_Stub links are set - Generate_Reference (Spec_Id, Body_Id, 'b'); + Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False); -- For a generic package, collect global references and mark -- them on the original body so that they are not resolved @@ -816,7 +816,7 @@ package body Sem_Ch7 is end; end if; - Process_End_Label (N, 'e'); + Process_End_Label (N, 'e', Id); end Analyze_Package_Specification; -------------------------------------- @@ -851,6 +851,46 @@ package body Sem_Ch7 is procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is E : Entity_Id; + Op_List : Elist_Id; + Op_Elmt : Elmt_Id; + Op_Elmt_2 : Elmt_Id; + Prim_Op : Entity_Id; + New_Op : Entity_Id; + Parent_Subp : Entity_Id; + Found_Explicit : Boolean; + Decl_Privates : Boolean; + + function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean; + -- Check whether an inherited subprogram is an operation of an + -- untagged derived type. + + --------------------- + -- Is_Primitive_Of -- + --------------------- + + function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean is + Formal : Entity_Id; + + begin + if Etype (S) = T then + return True; + + else + Formal := First_Formal (S); + + while Present (Formal) loop + if Etype (Formal) = T then + return True; + end if; + + Next_Formal (Formal); + end loop; + + return False; + end if; + end Is_Primitive_Of; + + -- Start of processing for Declare_Inherited_Private_Subprograms begin E := First_Entity (Id); @@ -862,26 +902,19 @@ package body Sem_Ch7 is -- inherited operations that now need to be made visible. -- Ditto if the entity is a formal derived type in a child unit. - if Is_Tagged_Type (E) - and then - ((Is_Derived_Type (E) and then not Is_Private_Type (E)) + if ((Is_Derived_Type (E) and then not Is_Private_Type (E)) or else (Nkind (Parent (E)) = N_Private_Extension_Declaration and then Is_Generic_Type (E))) and then In_Open_Scopes (Scope (Etype (E))) and then E = Base_Type (E) then - declare - Op_List : constant Elist_Id := Primitive_Operations (E); - Op_Elmt : Elmt_Id := First_Elmt (Op_List); - Op_Elmt_2 : Elmt_Id; - Prim_Op : Entity_Id; - New_Op : Entity_Id := Empty; - Parent_Subp : Entity_Id; - Found_Explicit : Boolean; - Decl_Privates : Boolean := False; + if Is_Tagged_Type (E) then + Op_List := Primitive_Operations (E); + Op_Elmt := First_Elmt (Op_List); + New_Op := Empty; + Decl_Privates := False; - begin while Present (Op_Elmt) loop Prim_Op := Node (Op_Elmt); @@ -963,7 +996,27 @@ package body Sem_Ch7 is then Set_All_DT_Position (E); end if; - end; + + else + -- Non-tagged type, scan forward to locate + -- inherited hidden operations. + + Prim_Op := Next_Entity (E); + + while Present (Prim_Op) loop + if Is_Subprogram (Prim_Op) + and then Present (Alias (Prim_Op)) + and then not Comes_From_Source (Prim_Op) + and then Is_Internal_Name (Chars (Prim_Op)) + and then not Is_Internal_Name (Chars (Alias (Prim_Op))) + and then Is_Primitive_Of (E, Prim_Op) + then + Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E)); + end if; + + Next_Entity (Prim_Op); + end loop; + end if; end if; Next_Entity (E); @@ -1355,9 +1408,9 @@ package body Sem_Ch7 is if Priv_Is_Base_Type then Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full))); - Set_Has_Task (Priv, Has_Task (Base_Type (Full))); Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only (Base_Type (Full))); + Set_Has_Task (Priv, Has_Task (Base_Type (Full))); Set_Has_Controlled_Component (Priv, Has_Controlled_Component (Base_Type (Full))); end if; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 6d4e43044fc..92f1eb2f7e3 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.3 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- @@ -1032,6 +1032,60 @@ package body Sem_Ch8 is Inst_Node : Node_Id := Empty; Save_83 : Boolean := Ada_83; + function Original_Subprogram (Subp : Entity_Id) return Entity_Id; + -- Find renamed entity when the declaration is a renaming_as_body + -- and the renamed entity may itself be a renaming_as_body. Used to + -- enforce rule that a renaming_as_body is illegal if the declaration + -- occurs before the subprogram it completes is frozen, and renaming + -- indirectly renames the subprogram itself.(Defect Report 8652/0027). + + ------------------------- + -- Original_Subprogram -- + ------------------------- + + function Original_Subprogram (Subp : Entity_Id) return Entity_Id is + Orig_Decl : Node_Id; + Orig_Subp : Entity_Id; + + begin + -- First case: renamed entity is itself a renaming + + if Present (Alias (Subp)) then + return Alias (Subp); + + elsif + Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration + and then Present + (Corresponding_Body (Unit_Declaration_Node (Subp))) + then + -- Check if renamed entity is a renaming_as_body + + Orig_Decl := + Unit_Declaration_Node + (Corresponding_Body (Unit_Declaration_Node (Subp))); + + if Nkind (Orig_Decl) = N_Subprogram_Renaming_Declaration then + Orig_Subp := Entity (Name (Orig_Decl)); + + if Orig_Subp = Rename_Spec then + + -- Circularity detected. + + return Orig_Subp; + + else + return (Original_Subprogram (Orig_Subp)); + end if; + else + return Subp; + end if; + else + return Subp; + end if; + end Original_Subprogram; + + -- Start of procesing for Analyze_Subprogram_Renaming + begin -- We must test for the attribute renaming case before the Analyze -- call because otherwise Sem_Attr will complain that the attribute @@ -1225,14 +1279,23 @@ package body Sem_Ch8 is Generate_Reference (Rename_Spec, Defining_Entity (Spec), 'b'); Style.Check_Identifier (Defining_Entity (Spec), Rename_Spec); - if not Is_Frozen (Rename_Spec) - and then not Has_Convention_Pragma (Rename_Spec) - then - Set_Convention (New_S, Convention (Old_S)); + if not Is_Frozen (Rename_Spec) then + if not Has_Convention_Pragma (Rename_Spec) then + Set_Convention (New_S, Convention (Old_S)); + end if; + + if Ekind (Old_S) /= E_Operator then + Check_Mode_Conformant (New_S, Old_S, Spec); + end if; + + if Original_Subprogram (Old_S) = Rename_Spec then + Error_Msg_N ("unfrozen subprogram cannot rename itself ", N); + end if; + else + Check_Subtype_Conformant (New_S, Old_S, Spec); end if; Check_Frozen_Renaming (N, Rename_Spec); - Check_Subtype_Conformant (New_S, Old_S, Spec); elsif Ekind (Old_S) /= E_Operator then Check_Mode_Conformant (New_S, Old_S); @@ -1382,7 +1445,7 @@ package body Sem_Ch8 is Pack_Name : Node_Id; Pack : Entity_Id; - function In_Previous_With_Clause (P : Entity_Id) return Boolean; + function In_Previous_With_Clause return Boolean; -- For use clauses in a context clause, the indicated package may -- be visible and yet illegal, if it did not appear in a previous -- with clause. @@ -1391,7 +1454,7 @@ package body Sem_Ch8 is -- In_Previous_With_Clause -- ----------------------------- - function In_Previous_With_Clause (P : Entity_Id) return Boolean is + function In_Previous_With_Clause return Boolean is Item : Node_Id; begin @@ -1488,7 +1551,7 @@ package body Sem_Ch8 is elsif Nkind (Parent (N)) = N_Compilation_Unit and then Nkind (Pack_Name) /= N_Expanded_Name - and then not In_Previous_With_Clause (Pack) + and then not In_Previous_With_Clause then Error_Msg_N ("package is not directly visible", Pack_Name); @@ -1524,7 +1587,7 @@ package body Sem_Ch8 is Find_Type (Id); if Entity (Id) /= Any_Type then - Use_One_Type (Id, N); + Use_One_Type (Id); end if; Next (Id); @@ -2356,6 +2419,15 @@ package body Sem_Ch8 is else Error_Msg_N ("non-visible declaration#!", N); end if; + + -- Set entity and its containing package as referenced. We + -- can't be sure of this, but this seems a better choice + -- to avoid unused entity messages. + + if Comes_From_Source (Ent) then + Set_Referenced (Ent); + Set_Referenced (Cunit_Entity (Get_Source_Unit (Ent))); + end if; end if; <<Continue>> @@ -2883,8 +2955,8 @@ package body Sem_Ch8 is -- the scope of its declaration. procedure Find_Expanded_Name (N : Node_Id) is - Candidate : Entity_Id := Empty; - Selector : constant Node_Id := Selector_Name (N); + Selector : constant Node_Id := Selector_Name (N); + Candidate : Entity_Id := Empty; P_Name : Entity_Id; O_Name : Entity_Id; Id : Entity_Id; @@ -3158,8 +3230,17 @@ package body Sem_Ch8 is end if; Change_Selected_Component_To_Expanded_Name (N); - Set_Entity_With_Style_Check (N, Id); - Generate_Reference (Id, N); + + -- Do style check and generate reference, but skip both steps if this + -- entity has homonyms, since we may not have the right homonym set + -- yet. The proper homonym will be set during the resolve phase. + + if Has_Homonym (Id) then + Set_Entity (N, Id); + else + Set_Entity_With_Style_Check (N, Id); + Generate_Reference (Id, N); + end if; if Is_Type (Id) then Set_Etype (N, Id); @@ -3952,7 +4033,7 @@ package body Sem_Ch8 is end if; end if; - if Present (Etype (N)) then + if Present (Etype (N)) and then Comes_From_Source (N) then if Is_Fixed_Point_Type (Etype (N)) then Check_Restriction (No_Fixed_Point, N); elsif Is_Floating_Point_Type (Etype (N)) then @@ -4340,7 +4421,7 @@ package body Sem_Ch8 is while Present (P) loop if Entity (P) /= Any_Type then - Use_One_Type (P, U); + Use_One_Type (P); end if; Next (P); @@ -4962,7 +5043,7 @@ package body Sem_Ch8 is while Present (Id) loop if Entity (Id) /= Any_Type then - Use_One_Type (Id, Decl); + Use_One_Type (Id); end if; Next (Id); @@ -5137,7 +5218,7 @@ package body Sem_Ch8 is -- Use_One_Type -- ------------------ - procedure Use_One_Type (Id : Node_Id; N : Node_Id) is + procedure Use_One_Type (Id : Node_Id) is T : Entity_Id; Op_List : Elist_Id; Elmt : Elmt_Id; @@ -5173,7 +5254,6 @@ package body Sem_Ch8 is Next_Elmt (Elmt); end loop; end if; - end Use_One_Type; ---------------- diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads index 08285662604..beea61ded57 100644 --- a/gcc/ada/sem_ch8.ads +++ b/gcc/ada/sem_ch8.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.1 $ -- +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -177,10 +177,9 @@ package Sem_Ch8 is -- re-installing use clauses of parent units. N is the use_clause that -- names P (and possibly other packages). - procedure Use_One_Type (Id : Node_Id; N : Node_Id); + procedure Use_One_Type (Id : Node_Id); -- Id is the subtype mark from a use type clause. This procedure makes -- the primitive operators of the type potentially use-visible. - -- N is the Use_Type_Clause that names Id. procedure Set_Use (L : List_Id); -- Find use clauses that are declarative items in a package declaration diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 2075e5e5342..868c4295b11 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.235 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -245,7 +245,7 @@ package body Sem_Ch9 is if Present (Formals) then New_Scope (Ityp); - Process_Formals (Ityp, Formals, N); + Process_Formals (Formals, N); Create_Extra_Formals (Ityp); End_Scope; end if; @@ -275,7 +275,7 @@ package body Sem_Ch9 is return; else Set_Entity (Nam, Entry_Nam); - Generate_Reference (Entry_Nam, Nam, 'b'); + Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False); Style.Check_Identifier (Nam, Entry_Nam); end if; @@ -399,7 +399,7 @@ package body Sem_Ch9 is Set_Actual_Subtypes (N, Current_Scope); Analyze (Stats); - Process_End_Label (Handled_Statement_Sequence (N), 't'); + Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam); End_Scope; end if; @@ -408,7 +408,6 @@ package body Sem_Ch9 is Check_Potentially_Blocking_Operation (N); Check_References (Entry_Nam, N); Set_Entry_Accepted (Entry_Nam); - end Analyze_Accept_Statement; --------------------------------- @@ -577,7 +576,7 @@ package body Sem_Ch9 is else Set_Has_Completion (Entry_Name); - Generate_Reference (Entry_Name, Id, 'b'); + Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False); Style.Check_Identifier (Id, Entry_Name); end if; @@ -607,7 +606,7 @@ package body Sem_Ch9 is end if; Check_References (Entry_Name); - Process_End_Label (Handled_Statement_Sequence (N), 't'); + Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name); End_Scope; -- If this is an entry family, remove the loop created to provide @@ -640,7 +639,7 @@ package body Sem_Ch9 is if Present (Formals) then Set_Scope (Id, Current_Scope); New_Scope (Id); - Process_Formals (Id, Formals, Parent (N)); + Process_Formals (Formals, Parent (N)); End_Scope; end if; @@ -694,7 +693,7 @@ package body Sem_Ch9 is if Present (Formals) then Set_Scope (Id, Current_Scope); New_Scope (Id); - Process_Formals (Id, Formals, N); + Process_Formals (Formals, N); Create_Extra_Formals (Id); End_Scope; end if; @@ -744,9 +743,20 @@ package body Sem_Ch9 is procedure Analyze_Protected_Body (N : Node_Id) is Body_Id : constant Entity_Id := Defining_Identifier (N); - Spec_Id : Entity_Id; Last_E : Entity_Id; + Spec_Id : Entity_Id; + -- This is initially the entity of the protected object or protected + -- type involved, but is replaced by the protected type always in the + -- case of a single protected declaration, since this is the proper + -- scope to be used. + + Ref_Id : Entity_Id; + -- This is the entity of the protected object or protected type + -- involved, and is the entity used for cross-reference purposes + -- (it differs from Spec_Id in the case of a single protected + -- object, since Spec_Id is set to the protected type in this case). + begin Tasking_Used := True; Set_Ekind (Body_Id, E_Protected_Body); @@ -768,7 +778,8 @@ package body Sem_Ch9 is return; end if; - Generate_Reference (Spec_Id, Body_Id, 'b'); + Ref_Id := Spec_Id; + Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); Style.Check_Identifier (Body_Id, Spec_Id); -- The declarations are always attached to the type @@ -803,7 +814,7 @@ package body Sem_Ch9 is Check_Completion (Body_Id); Check_References (Spec_Id); - Process_End_Label (N, 't'); + Process_End_Label (N, 't', Ref_Id); End_Scope; end Analyze_Protected_Body; @@ -843,7 +854,9 @@ package body Sem_Ch9 is then Set_Convention (E, Convention_Protected); - elsif Is_Task_Type (Etype (E)) then + elsif Is_Task_Type (Etype (E)) + or else Has_Task (Etype (E)) + then Set_Has_Task (Current_Scope); end if; @@ -851,7 +864,7 @@ package body Sem_Ch9 is end loop; Check_Max_Entries (N, Max_Protected_Entries); - Process_End_Label (N, 'e'); + Process_End_Label (N, 'e', Current_Scope); end Analyze_Protected_Definition; ---------------------------- @@ -871,6 +884,7 @@ package body Sem_Ch9 is if Ekind (T) = E_Incomplete_Type then T := Full_View (T); + Set_Completion_Referenced (T); end if; Set_Ekind (T, E_Protected_Type); @@ -1361,9 +1375,18 @@ package body Sem_Ch9 is procedure Analyze_Task_Body (N : Node_Id) is Body_Id : constant Entity_Id := Defining_Identifier (N); - Spec_Id : Entity_Id; Last_E : Entity_Id; + Spec_Id : Entity_Id; + -- This is initially the entity of the task or task type involved, + -- but is replaced by the task type always in the case of a single + -- task declaration, since this is the proper scope to be used. + + Ref_Id : Entity_Id; + -- This is the entity of the task or task type, and is the entity + -- used for cross-reference purposes (it differs from Spec_Id in + -- the case of a single task, since Spec_Id is set to the task type) + begin Tasking_Used := True; Set_Ekind (Body_Id, E_Task_Body); @@ -1389,7 +1412,8 @@ package body Sem_Ch9 is return; end if; - Generate_Reference (Spec_Id, Body_Id, 'b'); + Ref_Id := Spec_Id; + Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); Style.Check_Identifier (Body_Id, Spec_Id); -- Deal with case of body of single task (anonymous type was created) @@ -1443,7 +1467,7 @@ package body Sem_Ch9 is end loop; end; - Process_End_Label (Handled_Statement_Sequence (N), 't'); + Process_End_Label (Handled_Statement_Sequence (N), 't', Ref_Id); End_Scope; end Analyze_Task_Body; @@ -1475,7 +1499,7 @@ package body Sem_Ch9 is end if; Check_Max_Entries (N, Max_Task_Entries); - Process_End_Label (N, 'e'); + Process_End_Label (N, 'e', Current_Scope); end Analyze_Task_Definition; ----------------------- @@ -1489,11 +1513,13 @@ package body Sem_Ch9 is begin Tasking_Used := True; Check_Restriction (Max_Tasks, N); + Check_Restriction (No_Tasking, N); T := Find_Type_Name (N); Generate_Definition (T); if Ekind (T) = E_Incomplete_Type then T := Full_View (T); + Set_Completion_Referenced (T); end if; Set_Ekind (T, E_Task_Type); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 31dae9026e9..53fc27b15a7 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.114 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -31,13 +31,18 @@ with Debug; use Debug; with Elists; use Elists; with Einfo; use Einfo; with Exp_Disp; use Exp_Disp; +with Exp_Ch7; use Exp_Ch7; +with Exp_Tss; use Exp_Tss; with Errout; use Errout; with Hostparm; use Hostparm; with Nlists; use Nlists; +with Opt; use Opt; with Output; use Output; +with Sem; use Sem; with Sem_Ch6; use Sem_Ch6; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; +with Snames; use Snames; with Sinfo; use Sinfo; with Uintp; use Uintp; @@ -267,29 +272,42 @@ package body Sem_Disp is if Is_Abstract (Func) and then No (Controlling_Argument (N)) then - Par := Parent (N); + if Present (Alias (Func)) + and then not Is_Abstract (Alias (Func)) + and then No (DTC_Entity (Func)) + then + -- private overriding of inherited abstract operation, + -- call is legal - while Present (Par) loop + Set_Entity (Name (N), Alias (Func)); + return; - if Nkind (Par) = N_Function_Call or else - Nkind (Par) = N_Procedure_Call_Statement or else - Nkind (Par) = N_Assignment_Statement or else - Nkind (Par) = N_Op_Eq or else - Nkind (Par) = N_Op_Ne - then - return; + else + Par := Parent (N); - elsif Nkind (Par) = N_Qualified_Expression - or else Nkind (Par) = N_Unchecked_Type_Conversion - then - Par := Parent (Par); + while Present (Par) loop - else - Error_Msg_N - ("call to abstract function must be dispatching", N); - return; - end if; - end loop; + if (Nkind (Par) = N_Function_Call or else + Nkind (Par) = N_Procedure_Call_Statement or else + Nkind (Par) = N_Assignment_Statement or else + Nkind (Par) = N_Op_Eq or else + Nkind (Par) = N_Op_Ne) + and then Is_Tagged_Type (Etype (Func)) + then + return; + + elsif Nkind (Par) = N_Qualified_Expression + or else Nkind (Par) = N_Unchecked_Type_Conversion + then + Par := Parent (Par); + + else + Error_Msg_N + ("call to abstract function must be dispatching", N); + return; + end if; + end loop; + end if; end if; end Check_Dispatching_Context; @@ -403,7 +421,7 @@ package body Sem_Disp is --------------------------------- procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is - Tagged_Seen : Entity_Id; + Tagged_Type : Entity_Id; Has_Dispatching_Parent : Boolean := False; Body_Is_Last_Primitive : Boolean := False; @@ -413,7 +431,7 @@ package body Sem_Disp is end if; Set_Is_Dispatching_Operation (Subp, False); - Tagged_Seen := Find_Dispatching_Type (Subp); + Tagged_Type := Find_Dispatching_Type (Subp); -- If Subp is derived from a dispatching operation then it should -- always be treated as dispatching. In this case various checks @@ -424,13 +442,13 @@ package body Sem_Disp is Has_Dispatching_Parent := Present (Alias (Subp)) and then Is_Dispatching_Operation (Alias (Subp)); - if No (Tagged_Seen) then + if No (Tagged_Type) then return; -- The subprograms build internally after the freezing point (such as -- the Init procedure) are not primitives - elsif Is_Frozen (Tagged_Seen) + elsif Is_Frozen (Tagged_Type) and then not Comes_From_Source (Subp) and then not Has_Dispatching_Parent then @@ -451,7 +469,7 @@ package body Sem_Disp is and then not Has_Dispatching_Parent then if not Comes_From_Source (Subp) - or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Seen)) + or else (Present (Old_Subp) and then not Is_Frozen (Tagged_Type)) then null; @@ -471,7 +489,7 @@ package body Sem_Disp is then declare Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); - Decl_Item : Node_Id := Next (Parent (Tagged_Seen)); + Decl_Item : Node_Id := Next (Parent (Tagged_Type)); begin -- ??? The checks here for whether the type has been @@ -548,7 +566,7 @@ package body Sem_Disp is -- case it looks suspiciously like an attempt to define a primitive -- operation. - elsif not Is_Frozen (Tagged_Seen) then + elsif not Is_Frozen (Tagged_Type) then Error_Msg_N ("?not dispatching (must be defined in a package spec)", Subp); return; @@ -563,33 +581,105 @@ package body Sem_Disp is -- Now, we are sure that the scope is a package spec. If the subprogram -- is declared after the freezing point ot the type that's an error - elsif Is_Frozen (Tagged_Seen) and then not Has_Dispatching_Parent then + elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then Error_Msg_N ("this primitive operation is declared too late", Subp); Error_Msg_NE ("?no primitive operations for& after this line", - Freeze_Node (Tagged_Seen), - Tagged_Seen); + Freeze_Node (Tagged_Type), + Tagged_Type); return; end if; - Check_Controlling_Formals (Tagged_Seen, Subp); + Check_Controlling_Formals (Tagged_Type, Subp); -- Now it should be a correct primitive operation, put it in the list if Present (Old_Subp) then Check_Subtype_Conformant (Subp, Old_Subp); - Override_Dispatching_Operation (Tagged_Seen, Old_Subp, Subp); + Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp); else - Add_Dispatching_Operation (Tagged_Seen, Subp); + Add_Dispatching_Operation (Tagged_Type, Subp); end if; Set_Is_Dispatching_Operation (Subp, True); if not Body_Is_Last_Primitive then Set_DT_Position (Subp, No_Uint); - end if; + elsif Has_Controlled_Component (Tagged_Type) + and then + (Chars (Subp) = Name_Initialize + or else Chars (Subp) = Name_Adjust + or else Chars (Subp) = Name_Finalize) + then + declare + F_Node : Node_Id := Freeze_Node (Tagged_Type); + Decl : Node_Id; + Old_P : Entity_Id; + Old_Bod : Node_Id; + Old_Spec : Entity_Id; + + C_Names : constant array (1 .. 3) of Name_Id := + (Name_Initialize, + Name_Adjust, + Name_Finalize); + + D_Names : constant array (1 .. 3) of Name_Id := + (Name_uDeep_Initialize, + Name_uDeep_Adjust, + Name_uDeep_Finalize); + + begin + -- Remove previous controlled function, which was constructed + -- and analyzed when the type was frozen. This requires + -- removing the body of the redefined primitive, as well as its + -- specification if needed (there is no spec created for + -- Deep_Initialize, see exp_ch3.adb). We must also dismantle + -- the exception information that may have been generated for it + -- when zero-cost is enabled. + + for J in D_Names'Range loop + Old_P := TSS (Tagged_Type, D_Names (J)); + + if Present (Old_P) + and then Chars (Subp) = C_Names (J) + then + Old_Bod := Unit_Declaration_Node (Old_P); + Remove (Old_Bod); + Set_Is_Eliminated (Old_P); + Set_Scope (Old_P, Scope (Current_Scope)); + + if Nkind (Old_Bod) = N_Subprogram_Body + and then Present (Corresponding_Spec (Old_Bod)) + then + Old_Spec := Corresponding_Spec (Old_Bod); + Set_Has_Completion (Old_Spec, False); + + if Exception_Mechanism = Front_End_ZCX then + Set_Has_Subprogram_Descriptor (Old_Spec, False); + Set_Handler_Records (Old_Spec, No_List); + Set_Is_Eliminated (Old_Spec); + end if; + end if; + + end if; + end loop; + + Build_Late_Proc (Tagged_Type, Chars (Subp)); + + -- The new operation is added to the actions of the freeze + -- node for the type, but this node has already been analyzed, + -- so we must retrieve and analyze explicitly the one new body, + + if Present (F_Node) + and then Present (Actions (F_Node)) + then + Decl := Last (Actions (F_Node)); + Analyze (Decl); + end if; + end; + end if; end Check_Dispatching_Operation; ------------------------------------------ @@ -777,6 +867,16 @@ package body Sem_Disp is if Nkind (N) = N_Attribute_Reference then Typ := Etype (Prefix (N)); + + -- An allocator is dispatching if the type of qualified + -- expression is class_wide, in which case this is the + -- controlling type. + + elsif Nkind (Orig_Node) = N_Allocator + and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression + then + Typ := Etype (Expression (Orig_Node)); + else Typ := Designated_Type (Typ); end if; diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index f2b5c6c6bfa..a8c42b0caa2 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.182 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- @@ -658,7 +658,6 @@ package body Sem_Dist is elsif Ekind (Typ) = E_Record_Type and then Present (Corresponding_Remote_Type (Typ)) then - -- This is a record type representing a RAS type, this must be -- expanded. diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 9efa7ca022c..34770d12530 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.3 $ +-- $Revision$ -- -- --- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2002 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -179,7 +179,7 @@ package body Sem_Elab is -- Outer_Scope is the outer level scope for the original call. -- Inter_Unit_Only is set if the call is only to be checked in the -- case where it is to another unit (and skipped if within a unit). - -- Generate_Warnings is set to True to suppress warning messages + -- Generate_Warnings is set to False to suppress warning messages -- about missing pragma Elaborate_All's. These messages are not -- wanted for inner calls in the dynamic model. @@ -279,6 +279,12 @@ package body Sem_Elab is -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or -- is one of its contained scopes, False otherwise. + function Within_Elaborate_All (E : Entity_Id) return Boolean; + -- Before emitting a warning on a scope E for a missing elaborate_all, + -- check whether E may be in the context of a directly visible unit + -- U to which the pragma applies. This prevents spurious warnings when + -- the called entity is renamed within U. + ------------------ -- Check_A_Call -- ------------------ @@ -521,7 +527,6 @@ package body Sem_Elab is if Unit_Caller /= No_Unit and then Unit_Callee /= Unit_Caller - and then Unit_Callee /= No_Unit and then not Dynamic_Elaboration_Checks then E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); @@ -539,7 +544,7 @@ package body Sem_Elab is E_Scope := Scope (E_Scope); end loop; - -- For the case of not in an instance, or call within instance + -- For the case N is not an instance, or a call within instance -- We recompute E_Scope for the error message, since we -- do NOT want to go to the unit which has the ultimate -- declaration in the case of renaming and derivation and @@ -573,6 +578,10 @@ package body Sem_Elab is end loop; end if; + if Within_Elaborate_All (E_Scope) then + return; + end if; + if not Suppress_Elaboration_Warnings (Ent) and then not Suppress_Elaboration_Warnings (E_Scope) and then Elab_Warnings @@ -586,6 +595,20 @@ package body Sem_Elab is else Error_Msg_NE ("call to & may raise Program_Error?", N, Ent); + + if Unit_Callee = No_Unit + and then E_Scope = Current_Scope + then + -- The missing pragma cannot be on the current unit, so + -- place it on the compilation unit that contains the + -- called entity, which is more likely to be right. + + E_Scope := Ent; + + while not Is_Compilation_Unit (E_Scope) loop + E_Scope := Scope (E_Scope); + end loop; + end if; end if; Error_Msg_Qual_Level := Nat'Last; @@ -663,9 +686,9 @@ package body Sem_Elab is if Nkind (N) not in N_Generic_Instantiation then return; - -- Nothing to do if errors already detected (avoid cascaded errors) + -- Nothing to do if serious errors detected (avoid cascaded errors) - elsif Errors_Detected /= 0 then + elsif Serious_Errors_Detected /= 0 then return; -- Nothing to do if not in full analysis mode @@ -693,7 +716,7 @@ package body Sem_Elab is end if; Nam := Name (N); - Ent := Entity (Nam); + Ent := Get_Generic_Entity (N); -- The case we are interested in is when the generic spec is in the -- current declarative part @@ -861,6 +884,7 @@ package body Sem_Elab is if Comes_From_Source (N) and then In_Preelaborated_Unit + and then not In_Inlined_Body then Error_Msg_N ("non-static call not allowed in preelaborated unit", N); @@ -1070,7 +1094,7 @@ package body Sem_Elab is -- Skip delayed calls if we had any errors - if Errors_Detected = 0 then + if Serious_Errors_Detected = 0 then Delaying_Elab_Checks := False; Expander_Mode_Save_And_Set (True); @@ -1129,7 +1153,7 @@ package body Sem_Elab is end if; Nam := Name (N); - Ent := Entity (Nam); + Ent := Get_Generic_Entity (N); From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; -- See if we need to analyze this instantiation. We analyze it if @@ -1214,7 +1238,7 @@ package body Sem_Elab is -- Nothing to do if errors already detected (avoid cascaded errors) - elsif Errors_Detected /= 0 then + elsif Serious_Errors_Detected /= 0 then return; -- Nothing to do if not in full analysis mode @@ -1584,6 +1608,13 @@ package body Sem_Elab is -- will have been elaborated already. We keep separate lists for -- each kind of task. + -- Skip this test if errors have occurred, since in this case + -- we can get false indications. + + if Total_Errors_Detected /= 0 then + return; + end if; + if Present (Proc) then if Outer_Unit (Scope (Proc)) = Enclosing then @@ -1768,7 +1799,7 @@ package body Sem_Elab is ---------------------- function Has_Generic_Body (N : Node_Id) return Boolean is - Ent : constant Entity_Id := Entity (Name (N)); + Ent : constant Entity_Id := Get_Generic_Entity (N); Decl : constant Node_Id := Unit_Declaration_Node (Ent); Scop : Entity_Id; @@ -2025,9 +2056,14 @@ package body Sem_Elab is begin if No (C) then - R := Make_Raise_Program_Error (Loc); + R := + Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration); else - R := Make_Raise_Program_Error (Loc, Make_Op_Not (Loc, C)); + R := + Make_Raise_Program_Error (Loc, + Condition => Make_Op_Not (Loc, C), + Reason => PE_Access_Before_Elaboration); end if; if No (Declarations (ADN)) then @@ -2056,9 +2092,12 @@ package body Sem_Elab is then declare Typ : constant Entity_Id := Etype (N); - R : constant Node_Id := Make_Raise_Program_Error (Loc); Chk : constant Boolean := Do_Range_Check (N); + R : constant Node_Id := + Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration); + begin Set_Etype (R, Typ); @@ -2086,13 +2125,15 @@ package body Sem_Elab is else if No (C) then Insert_Action (Nod, - Make_Raise_Program_Error (Loc)); + Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration)); else Insert_Action (Nod, Make_Raise_Program_Error (Loc, Condition => Make_Op_Not (Loc, - Right_Opnd => C))); + Right_Opnd => C), + Reason => PE_Access_Before_Elaboration)); end if; end if; end if; @@ -2284,4 +2325,44 @@ package body Sem_Elab is raise Program_Error; end Within; + -------------------------- + -- Within_Elaborate_All -- + -------------------------- + + function Within_Elaborate_All (E : Entity_Id) return Boolean is + Item : Node_Id; + Item2 : Node_Id; + Elab_Id : Entity_Id; + Par : Node_Id; + + begin + Item := First (Context_Items (Cunit (Current_Sem_Unit))); + + while Present (Item) loop + if Nkind (Item) = N_Pragma + and then Get_Pragma_Id (Chars (Item)) = Pragma_Elaborate_All + then + Elab_Id := + Entity ( + Expression (First (Pragma_Argument_Associations (Item)))); + Par := Parent (Unit_Declaration_Node (Elab_Id)); + Item2 := First (Context_Items (Par)); + + while Present (Item2) loop + if Nkind (Item2) = N_With_Clause + and then Entity (Name (Item2)) = E + then + return True; + end if; + + Next (Item2); + end loop; + end if; + + Next (Item); + end loop; + + return False; + end Within_Elaborate_All; + end Sem_Elab; diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb index e418657ec09..d02e253b38c 100644 --- a/gcc/ada/sem_elim.adb +++ b/gcc/ada/sem_elim.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.13 $ +-- $Revision$ -- -- -- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- -- -- @@ -35,6 +35,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; +with Uintp; use Uintp; with GNAT.HTable; use GNAT.HTable; package body Sem_Elim is @@ -83,6 +84,9 @@ package body Sem_Elim is Result_Type : Name_Id; -- Result type name if Result_Types parameter present, No_Name if not + Homonym_Number : Uint; + -- Homonyn number if Homonym_Number parameter present, No_Uint if not. + Hash_Link : Access_Elim_Data; -- Link for hash table use @@ -197,6 +201,8 @@ package body Sem_Elim is Elmt : Access_Elim_Data; Scop : Entity_Id; Form : Entity_Id; + Ctr : Nat; + Ent : Entity_Id; begin if No_Elimination then @@ -280,28 +286,42 @@ package body Sem_Elim is elsif Ekind (E) = E_Function or else Ekind (E) = E_Procedure then - -- Two parameter case always matches + -- If Homonym_Number present, then see if it matches - if Elmt.Result_Type = No_Name - and then Elmt.Parameter_Types = null - then - Set_Is_Eliminated (E); - return; + if Elmt.Homonym_Number /= No_Uint then + Ctr := 1; - -- Here we have a profile, so see if it matches + Ent := E; + while Present (Homonym (Ent)) + and then Scope (Ent) = Scope (Homonym (Ent)) + loop + Ctr := Ctr + 1; + Ent := Homonym (Ent); + end loop; - else - if Ekind (E) = E_Function then - if Chars (Etype (E)) /= Elmt.Result_Type then - goto Continue; - end if; + if Ctr /= Elmt.Homonym_Number then + goto Continue; + end if; + end if; + + -- If we have a Result_Type, then we must have a function + -- with the proper result type + + if Elmt.Result_Type /= No_Name then + if Ekind (E) /= E_Function + or else Chars (Etype (E)) /= Elmt.Result_Type + then + goto Continue; end if; + end if; + + -- If we have Parameter_Types, they must match + if Elmt.Parameter_Types /= null then Form := First_Formal (E); if No (Form) and then Elmt.Parameter_Types = null then - Set_Is_Eliminated (E); - return; + null; elsif Elmt.Parameter_Types = null then goto Continue; @@ -319,12 +339,14 @@ package body Sem_Elim is if Present (Form) then goto Continue; - else - Set_Is_Eliminated (E); - return; end if; end if; end if; + + -- If we fall through, this is match + + Set_Is_Eliminated (E); + return; end if; <<Continue>> Elmt := Elmt.Homonym; @@ -351,13 +373,9 @@ package body Sem_Elim is (Arg_Unit_Name : Node_Id; Arg_Entity : Node_Id; Arg_Parameter_Types : Node_Id; - Arg_Result_Type : Node_Id) + Arg_Result_Type : Node_Id; + Arg_Homonym_Number : Node_Id) is - Argx_Unit_Name : Node_Id; - Argx_Entity : Node_Id; - Argx_Parameter_Types : Node_Id; - Argx_Result_Type : Node_Id; - Data : constant Access_Elim_Data := new Elim_Data; -- Build result data here @@ -366,7 +384,9 @@ package body Sem_Elim is Num_Names : Nat := 0; -- Number of names in unit name - Lit : Node_Id; + Lit : Node_Id; + Arg_Ent : Entity_Id; + Arg_Uname : Node_Id; function OK_Selected_Component (N : Node_Id) return Boolean; -- Test if N is a selected component with all identifiers, or a @@ -402,64 +422,61 @@ package body Sem_Elim is -- Process Unit_Name argument - Argx_Unit_Name := Expression (Arg_Unit_Name); - - if Nkind (Argx_Unit_Name) = N_Identifier then - Data.Unit_Name := new Names'(1 => Chars (Argx_Unit_Name)); + if Nkind (Arg_Unit_Name) = N_Identifier then + Data.Unit_Name := new Names'(1 => Chars (Arg_Unit_Name)); Num_Names := 1; - elsif OK_Selected_Component (Argx_Unit_Name) then + elsif OK_Selected_Component (Arg_Unit_Name) then Data.Unit_Name := new Names (1 .. Num_Names); + Arg_Uname := Arg_Unit_Name; for J in reverse 2 .. Num_Names loop - Data.Unit_Name (J) := Chars (Selector_Name (Argx_Unit_Name)); - Argx_Unit_Name := Prefix (Argx_Unit_Name); + Data.Unit_Name (J) := Chars (Selector_Name (Arg_Uname)); + Arg_Uname := Prefix (Arg_Uname); end loop; - Data.Unit_Name (1) := Chars (Argx_Unit_Name); + Data.Unit_Name (1) := Chars (Arg_Uname); else Error_Msg_N - ("wrong form for Unit_Name parameter of pragma%", - Argx_Unit_Name); + ("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name); return; end if; -- Process Entity argument if Present (Arg_Entity) then - Argx_Entity := Expression (Arg_Entity); Num_Names := 0; - if Nkind (Argx_Entity) = N_Identifier - or else Nkind (Argx_Entity) = N_Operator_Symbol + if Nkind (Arg_Entity) = N_Identifier + or else Nkind (Arg_Entity) = N_Operator_Symbol then - Data.Entity_Name := Chars (Argx_Entity); - Data.Entity_Node := Argx_Entity; + Data.Entity_Name := Chars (Arg_Entity); + Data.Entity_Node := Arg_Entity; Data.Entity_Scope := null; - elsif OK_Selected_Component (Argx_Entity) then + elsif OK_Selected_Component (Arg_Entity) then Data.Entity_Scope := new Names (1 .. Num_Names - 1); - Data.Entity_Name := Chars (Selector_Name (Argx_Entity)); - Data.Entity_Node := Argx_Entity; + Data.Entity_Name := Chars (Selector_Name (Arg_Entity)); + Data.Entity_Node := Arg_Entity; - Argx_Entity := Prefix (Argx_Entity); + Arg_Ent := Prefix (Arg_Entity); for J in reverse 2 .. Num_Names - 1 loop - Data.Entity_Scope (J) := Chars (Selector_Name (Argx_Entity)); - Argx_Entity := Prefix (Argx_Entity); + Data.Entity_Scope (J) := Chars (Selector_Name (Arg_Ent)); + Arg_Ent := Prefix (Arg_Ent); end loop; - Data.Entity_Scope (1) := Chars (Argx_Entity); + Data.Entity_Scope (1) := Chars (Arg_Ent); - elsif Nkind (Argx_Entity) = N_String_Literal then - String_To_Name_Buffer (Strval (Argx_Entity)); + elsif Nkind (Arg_Entity) = N_String_Literal then + String_To_Name_Buffer (Strval (Arg_Entity)); Data.Entity_Name := Name_Find; - Data.Entity_Node := Argx_Entity; + Data.Entity_Node := Arg_Entity; else Error_Msg_N ("wrong form for Entity_Argument parameter of pragma%", - Argx_Unit_Name); + Arg_Unit_Name); return; end if; else @@ -470,26 +487,25 @@ package body Sem_Elim is -- Process Parameter_Types argument if Present (Arg_Parameter_Types) then - Argx_Parameter_Types := Expression (Arg_Parameter_Types); -- Case of one name, which looks like a parenthesized literal -- rather than an aggregate. - if Nkind (Argx_Parameter_Types) = N_String_Literal - and then Paren_Count (Argx_Parameter_Types) = 1 + if Nkind (Arg_Parameter_Types) = N_String_Literal + and then Paren_Count (Arg_Parameter_Types) = 1 then - String_To_Name_Buffer (Strval (Argx_Parameter_Types)); + String_To_Name_Buffer (Strval (Arg_Parameter_Types)); Data.Parameter_Types := new Names'(1 => Name_Find); -- Otherwise must be an aggregate - elsif Nkind (Argx_Parameter_Types) /= N_Aggregate - or else Present (Component_Associations (Argx_Parameter_Types)) - or else No (Expressions (Argx_Parameter_Types)) + elsif Nkind (Arg_Parameter_Types) /= N_Aggregate + or else Present (Component_Associations (Arg_Parameter_Types)) + or else No (Expressions (Arg_Parameter_Types)) then Error_Msg_N ("Parameter_Types for pragma% must be list of string literals", - Argx_Parameter_Types); + Arg_Parameter_Types); return; -- Here for aggregate case @@ -497,9 +513,9 @@ package body Sem_Elim is else Data.Parameter_Types := new Names - (1 .. List_Length (Expressions (Argx_Parameter_Types))); + (1 .. List_Length (Expressions (Arg_Parameter_Types))); - Lit := First (Expressions (Argx_Parameter_Types)); + Lit := First (Expressions (Arg_Parameter_Types)); for J in Data.Parameter_Types'Range loop if Nkind (Lit) /= N_String_Literal then Error_Msg_N @@ -518,22 +534,38 @@ package body Sem_Elim is -- Process Result_Types argument if Present (Arg_Result_Type) then - Argx_Result_Type := Expression (Arg_Result_Type); - if Nkind (Argx_Result_Type) /= N_String_Literal then + if Nkind (Arg_Result_Type) /= N_String_Literal then Error_Msg_N ("Result_Type argument for pragma% must be string literal", - Argx_Result_Type); + Arg_Result_Type); return; end if; - String_To_Name_Buffer (Strval (Argx_Result_Type)); + String_To_Name_Buffer (Strval (Arg_Result_Type)); Data.Result_Type := Name_Find; else Data.Result_Type := No_Name; end if; + -- Process Homonym_Number argument + + if Present (Arg_Homonym_Number) then + + if Nkind (Arg_Homonym_Number) /= N_Integer_Literal then + Error_Msg_N + ("Homonym_Number argument for pragma% must be integer literal", + Arg_Homonym_Number); + return; + end if; + + Data.Homonym_Number := Intval (Arg_Homonym_Number); + + else + Data.Homonym_Number := No_Uint; + end if; + -- Now link this new entry into the hash table Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data)); diff --git a/gcc/ada/sem_elim.ads b/gcc/ada/sem_elim.ads index 861ffc99686..09ba5ac6997 100644 --- a/gcc/ada/sem_elim.ads +++ b/gcc/ada/sem_elim.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.1 $ -- +-- $Revision$ -- -- --- Copyright (C) 1997 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-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- -- @@ -39,13 +39,15 @@ package Sem_Elim is (Arg_Unit_Name : Node_Id; Arg_Entity : Node_Id; Arg_Parameter_Types : Node_Id; - Arg_Result_Type : Node_Id); + Arg_Result_Type : Node_Id; + Arg_Homonym_Number : Node_Id); -- Process eliminate pragma. The number of arguments has been checked, -- as well as possible optional identifiers, but no other checks have -- been made. This subprogram completes the checking, and then if the -- pragma is well formed, makes appropriate entries in the internal - -- tables used to keep track of Eliminate pragmas. The four arguments - -- are the possible pragma arguments (set to Empty if not present). + -- tables used to keep track of Eliminate pragmas. The five arguments + -- are expressions (not pragma argument associations) for the possible + -- pragma arguments. A parameter that is not present is set to Empty. procedure Check_Eliminated (E : Entity_Id); -- Checks if entity E is eliminated, and if so sets the Is_Eliminated diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 97930a6c1b5..9decc499f62 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -1,4 +1,4 @@ ------------------------------------------------------------------------------- +--------------------- -- -- -- GNAT COMPILER COMPONENTS -- -- -- @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -47,6 +47,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; +with Tbuild; use Tbuild; package body Sem_Eval is @@ -96,17 +97,44 @@ package body Sem_Eval is type Bits is array (Nat range <>) of Boolean; -- Used to convert unsigned (modular) values for folding logical ops + -- The following definitions are used to maintain a cache of nodes that + -- have compile time known values. The cache is maintained only for + -- discrete types (the most common case), and is populated by calls to + -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value + -- since it is possible for the status to change (in particular it is + -- possible for a node to get replaced by a constraint error node). + + CV_Bits : constant := 5; + -- Number of low order bits of Node_Id value used to reference entries + -- in the cache table. + + CV_Cache_Size : constant Nat := 2 ** CV_Bits; + -- Size of cache for compile time values + + subtype CV_Range is Nat range 0 .. CV_Cache_Size; + + type CV_Entry is record + N : Node_Id; + V : Uint; + end record; + + type CV_Cache_Array is array (CV_Range) of CV_Entry; + + CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0)); + -- This is the actual cache, with entries consisting of node/value pairs, + -- and the impossible value Node_High_Bound used for unset entries. + ----------------------- -- Local Subprograms -- ----------------------- - function OK_Bits (N : Node_Id; Bits : Uint) return Boolean; - -- Bits represents the number of bits in an integer value to be computed - -- (but the value has not been computed yet). If this value in Bits is - -- reasonable, a result of True is returned, with the implication that - -- the caller should go ahead and complete the calculation. If the value - -- in Bits is unreasonably large, then an error is posted on node N, and - -- False is returned (and the caller skips the proposed calculation). + function Constant_Array_Ref (Op : Node_Id) return Node_Id; + -- The caller has checked that Op is an array reference (i.e. that its + -- node kind is N_Indexed_Component). If the array reference is constant + -- at compile time, and yields a constant value of a discrete type, then + -- the expression node for the constant value is returned. otherwise Empty + -- is returned. This is used by Compile_Time_Known_Value, as well as by + -- Expr_Value and Expr_Rep_Value. function From_Bits (B : Bits; T : Entity_Id) return Uint; -- Converts a bit string of length B'Length to a Uint value to be used @@ -121,6 +149,14 @@ package body Sem_Eval is -- two must be available, or the operand would not have been marked -- as foldable in the earlier analysis of the operation). + function OK_Bits (N : Node_Id; Bits : Uint) return Boolean; + -- Bits represents the number of bits in an integer value to be computed + -- (but the value has not been computed yet). If this value in Bits is + -- reasonable, a result of True is returned, with the implication that + -- the caller should go ahead and complete the calculation. If the value + -- in Bits is unreasonably large, then an error is posted on node N, and + -- False is returned (and the caller skips the proposed calculation). + procedure Out_Of_Range (N : Node_Id); -- This procedure is called if it is determined that node N, which -- appears in a non-static context, is a compile time known value @@ -218,11 +254,6 @@ package body Sem_Eval is and then not Is_Machine_Number (N) and then not Is_Generic_Type (Etype (N)) and then Etype (N) /= Universal_Real - and then not Debug_Flag_S - and then (not Debug_Flag_T - or else - (Nkind (Parent (N)) = N_Object_Declaration - and then Constant_Present (Parent (N)))) then -- Check that value is in bounds before converting to machine -- number, so as not to lose case where value overflows in the @@ -282,7 +313,8 @@ package body Sem_Eval is Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer))) then Apply_Compile_Time_Constraint_Error - (N, "non-static universal integer value out of range?"); + (N, "non-static universal integer value out of range?", + CE_Range_Check_Failed); -- Check out of range of base type @@ -302,7 +334,7 @@ package body Sem_Eval is elsif Is_Out_Of_Range (N, T) then Apply_Compile_Time_Constraint_Error - (N, "value not in range of}?"); + (N, "value not in range of}?", CE_Range_Check_Failed); elsif Checks_On then Enable_Range_Check (N); @@ -327,6 +359,7 @@ package body Sem_Eval is then Apply_Compile_Time_Constraint_Error (N, "string length wrong for}?", + CE_Length_Check_Failed, Ent => Ttype, Typ => Ttype); end if; @@ -541,6 +574,18 @@ package body Sem_Eval is -- Start of processing for Compile_Time_Compare begin + -- If either operand could raise constraint error, then we cannot + -- know the result at compile time (since CE may be raised!) + + if not (Cannot_Raise_Constraint_Error (L) + and then + Cannot_Raise_Constraint_Error (R)) + then + return Unknown; + end if; + + -- Identical operands are most certainly equal + if L = R then return EQ; @@ -684,7 +729,9 @@ package body Sem_Eval is ------------------------------ function Compile_Time_Known_Value (Op : Node_Id) return Boolean is - K : constant Node_Kind := Nkind (Op); + K : constant Node_Kind := Nkind (Op); + CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size); + Val : Node_Id; begin -- Never known at compile time if bad type or raises constraint error @@ -719,10 +766,7 @@ package body Sem_Eval is if Ekind (E) = E_Enumeration_Literal then return True; - elsif Ekind (E) /= E_Constant then - return False; - - else + elsif Ekind (E) = E_Constant then V := Constant_Value (E); return Present (V) and then Compile_Time_Known_Value (V); end if; @@ -731,10 +775,16 @@ package body Sem_Eval is -- We have a value, see if it is compile time known else - -- Literals and NULL are known at compile time + -- Integer literals are worth storing in the cache - if K = N_Integer_Literal - or else + if K = N_Integer_Literal then + CV_Ent.N := Op; + CV_Ent.V := Intval (Op); + return True; + + -- Other literals and NULL are known at compile time + + elsif K = N_Character_Literal or else K = N_Real_Literal @@ -752,13 +802,29 @@ package body Sem_Eval is elsif K = N_Attribute_Reference then return Attribute_Name (Op) = Name_Null_Parameter; - -- All other types of values are not known at compile time + -- A reference to an element of a constant array may be constant. - else - return False; - end if; + elsif K = N_Indexed_Component then + Val := Constant_Array_Ref (Op); + if Present (Val) then + CV_Ent.N := Op; + CV_Ent.V := Expr_Value (Val); + return True; + end if; + end if; end if; + + -- If we fall through, not known at compile time + + return False; + + -- If we get an exception while trying to do this test, then some error + -- has occurred, and we simply say that the value is not known after all + + exception + when others => + return False; end Compile_Time_Known_Value; -------------------------------------- @@ -843,6 +909,50 @@ package body Sem_Eval is end if; end Compile_Time_Known_Value_Or_Aggr; + ------------------------ + -- Constant_Array_Ref -- + ------------------------ + + function Constant_Array_Ref (Op : Node_Id) return Node_Id is + begin + if List_Length (Expressions (Op)) = 1 + and then Is_Entity_Name (Prefix (Op)) + and then Ekind (Entity (Prefix (Op))) = E_Constant + then + declare + Arr : constant Node_Id := Constant_Value (Entity (Prefix (Op))); + Sub : constant Node_Id := First (Expressions (Op)); + Ind : constant Node_Id := First_Index (Etype (Arr)); + Lbd : constant Node_Id := Type_Low_Bound (Etype (Ind)); + + Lin : Nat; + -- Linear one's origin subscript value for array reference + + Elm : Node_Id; + -- Value from constant array + + begin + if Compile_Time_Known_Value (Sub) + and then Nkind (Arr) = N_Aggregate + and then Compile_Time_Known_Value (Lbd) + and then Is_Discrete_Type (Component_Type (Etype (Arr))) + then + Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1; + + if List_Length (Expressions (Arr)) >= Lin then + Elm := Pick (Expressions (Arr), Lin); + + if Compile_Time_Known_Value (Elm) then + return Elm; + end if; + end if; + end if; + end; + end if; + + return Empty; + end Constant_Array_Ref; + ----------------- -- Eval_Actual -- ----------------- @@ -931,7 +1041,7 @@ package body Sem_Eval is if Right_Int = 0 then Apply_Compile_Time_Constraint_Error - (N, "division by zero"); + (N, "division by zero", CE_Divide_By_Zero); return; else Result := Left_Int / Right_Int; @@ -944,7 +1054,7 @@ package body Sem_Eval is if Right_Int = 0 then Apply_Compile_Time_Constraint_Error - (N, "mod with zero divisor"); + (N, "mod with zero divisor", CE_Divide_By_Zero); return; else Result := Left_Int mod Right_Int; @@ -957,7 +1067,7 @@ package body Sem_Eval is if Right_Int = 0 then Apply_Compile_Time_Constraint_Error - (N, "rem with zero divisor"); + (N, "rem with zero divisor", CE_Divide_By_Zero); return; else Result := Left_Int rem Right_Int; @@ -1011,7 +1121,7 @@ package body Sem_Eval is else pragma Assert (Nkind (N) = N_Op_Divide); if UR_Is_Zero (Right_Real) then Apply_Compile_Time_Constraint_Error - (N, "division by zero"); + (N, "division by zero", CE_Divide_By_Zero); return; end if; @@ -1033,6 +1143,8 @@ package body Sem_Eval is -- Nothing to be done! procedure Eval_Character_Literal (N : Node_Id) is + pragma Warnings (Off, N); + begin null; end Eval_Character_Literal; @@ -1552,7 +1664,7 @@ package body Sem_Eval is if Right_Int < 0 then Apply_Compile_Time_Constraint_Error - (N, "integer exponent negative"); + (N, "integer exponent negative", CE_Range_Check_Failed); return; else @@ -1583,7 +1695,7 @@ package body Sem_Eval is if Right_Int < 0 then Apply_Compile_Time_Constraint_Error - (N, "zero ** negative integer"); + (N, "zero ** negative integer", CE_Range_Check_Failed); return; else Fold_Ureal (N, Ureal_0); @@ -1655,8 +1767,9 @@ package body Sem_Eval is Operand : constant Node_Id := Expression (N); Target_Type : constant Entity_Id := Entity (Subtype_Mark (N)); - Stat : Boolean; - Fold : Boolean; + Stat : Boolean; + Fold : Boolean; + Hex : Boolean; begin -- Can only fold if target is string or scalar and subtype is static @@ -1687,12 +1800,23 @@ package body Sem_Eval is return; end if; + -- Here we will fold, save Print_In_Hex indication + + Hex := Nkind (Operand) = N_Integer_Literal + and then Print_In_Hex (Operand); + -- Fold the result of qualification if Is_Discrete_Type (Target_Type) then Fold_Uint (N, Expr_Value (Operand)); Set_Is_Static_Expression (N, Stat); + -- Preserve Print_In_Hex indication + + if Hex and then Nkind (N) = N_Integer_Literal then + Set_Print_In_Hex (N); + end if; + elsif Is_Real_Type (Target_Type) then Fold_Ureal (N, Expr_Value_R (Operand)); Set_Is_Static_Expression (N, Stat); @@ -2072,7 +2196,7 @@ package body Sem_Eval is if String_Literal_Length (T) > String_Type_Len (B) then Apply_Compile_Time_Constraint_Error - (N, "string literal too long for}", + (N, "string literal too long for}", CE_Length_Check_Failed, Ent => B, Typ => First_Subtype (B)); @@ -2083,6 +2207,7 @@ package body Sem_Eval is then Apply_Compile_Time_Constraint_Error (N, "null string literal not allowed for}", + CE_Length_Check_Failed, Ent => B, Typ => First_Subtype (B)); end if; @@ -2331,8 +2456,9 @@ package body Sem_Eval is -------------------- function Expr_Rep_Value (N : Node_Id) return Uint is - Kind : constant Node_Kind := Nkind (N); - Ent : Entity_Id; + Kind : constant Node_Kind := Nkind (N); + Ent : Entity_Id; + Vexp : Node_Id; begin if Is_Entity_Name (N) then @@ -2363,14 +2489,24 @@ package body Sem_Eval is -- obtain the desired value from Corresponding_Integer_Value. elsif Kind = N_Real_Literal then - - -- Apply the assertion to the Underlying_Type of the literal for - -- the benefit of calls to this function in the JGNAT back end, - -- where literal types can reflect private views. - pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N)))); return Corresponding_Integer_Value (N); + -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero + + elsif Kind = N_Attribute_Reference + and then Attribute_Name (N) = Name_Null_Parameter + then + return Uint_0; + + -- Array reference case + + elsif Kind = N_Indexed_Component then + Vexp := Constant_Array_Ref (N); + pragma Assert (Present (Vexp)); + return Expr_Rep_Value (Vexp); + + -- Otherwise must be character literal else pragma Assert (Kind = N_Character_Literal); Ent := Entity (N); @@ -2394,10 +2530,23 @@ package body Sem_Eval is ---------------- function Expr_Value (N : Node_Id) return Uint is - Kind : constant Node_Kind := Nkind (N); - Ent : Entity_Id; + Kind : constant Node_Kind := Nkind (N); + CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size); + Ent : Entity_Id; + Val : Uint; + Vexp : Node_Id; begin + -- If already in cache, then we know it's compile time known and + -- we can return the value that was previously stored in the cache + -- since compile time known values cannot change :-) + + if CV_Ent.N = N then + return CV_Ent.V; + end if; + + -- Otherwise proceed to test value + if Is_Entity_Name (N) then Ent := Entity (N); @@ -2405,20 +2554,20 @@ package body Sem_Eval is -- created as a result of static evaluation. if Ekind (Ent) = E_Enumeration_Literal then - return Enumeration_Pos (Ent); + Val := Enumeration_Pos (Ent); -- A user defined static constant else pragma Assert (Ekind (Ent) = E_Constant); - return Expr_Value (Constant_Value (Ent)); + Val := Expr_Value (Constant_Value (Ent)); end if; -- An integer literal that was either in the source or created -- as a result of static evaluation. elsif Kind = N_Integer_Literal then - return Intval (N); + Val := Intval (N); -- A real literal for a fixed-point type. This must be the fixed-point -- case, either the literal is of a fixed-point type, or it is a bound @@ -2427,19 +2576,22 @@ package body Sem_Eval is elsif Kind = N_Real_Literal then - -- Apply the assertion to the Underlying_Type of the literal for - -- the benefit of calls to this function in the JGNAT back end, - -- where literal types can reflect private views. - pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N)))); - return Corresponding_Integer_Value (N); + Val := Corresponding_Integer_Value (N); -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero elsif Kind = N_Attribute_Reference and then Attribute_Name (N) = Name_Null_Parameter then - return Uint_0; + Val := Uint_0; + + -- Array reference case + + elsif Kind = N_Indexed_Component then + Vexp := Constant_Array_Ref (N); + pragma Assert (Present (Vexp)); + Val := Expr_Value (Vexp); -- Otherwise must be character literal @@ -2454,12 +2606,17 @@ package body Sem_Eval is -- their Pos value as usual. if No (Ent) then - return UI_From_Int (Int (Char_Literal_Value (N))); + Val := UI_From_Int (Int (Char_Literal_Value (N))); else - return Enumeration_Pos (Ent); + Val := Enumeration_Pos (Ent); end if; end if; + -- Come here with Val set to value to be returned, set cache + + CV_Ent.N := N; + CV_Ent.V := Val; + return Val; end Expr_Value; ------------------ @@ -3161,7 +3318,7 @@ package body Sem_Eval is else Apply_Compile_Time_Constraint_Error - (N, "value not in range of}"); + (N, "value not in range of}", CE_Range_Check_Failed); end if; -- Here we generate a warning for the Ada 83 case, or when we are @@ -3170,7 +3327,7 @@ package body Sem_Eval is else Warn_On_Instance := True; Apply_Compile_Time_Constraint_Error - (N, "value not in range of}?"); + (N, "value not in range of}?", CE_Range_Check_Failed); Warn_On_Instance := False; end if; end Out_Of_Range; @@ -3201,7 +3358,9 @@ package body Sem_Eval is -- We have to build an explicit raise_ce node else - Rewrite (N, Make_Raise_Constraint_Error (Sloc (Exp))); + Rewrite (N, + Make_Raise_Constraint_Error (Sloc (Exp), + Reason => CE_Range_Check_Failed)); Set_Raises_Constraint_Error (N); Set_Etype (N, Typ); end if; diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb index 20b1918d60a..51cd5d214c7 100644 --- a/gcc/ada/sem_intr.adb +++ b/gcc/ada/sem_intr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.25 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -145,23 +145,45 @@ package body Sem_Intr is ------------------------------ procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is - Nam : Name_Id := Chars (E); + Ret : constant Entity_Id := Etype (E); + Nam : constant Name_Id := Chars (E); T1 : Entity_Id; T2 : Entity_Id; - Ret : constant Entity_Id := Etype (E); begin + -- Aritnmetic operators + if Nam = Name_Op_Add - or else Nam = Name_Op_Subtract - or else Nam = Name_Op_Multiply - or else Nam = Name_Op_Divide + or else + Nam = Name_Op_Subtract + or else + Nam = Name_Op_Multiply + or else + Nam = Name_Op_Divide + or else + Nam = Name_Op_Rem + or else + Nam = Name_Op_Mod + or else + Nam = Name_Op_Abs then T1 := Etype (First_Formal (E)); if No (Next_Formal (First_Formal (E))) then - -- previous error in declaration. - return; + if Nam = Name_Op_Add + or else + Nam = Name_Op_Subtract + or else + Nam = Name_Op_Abs + then + T2 := T1; + + else + -- Previous error in declaration + + return; + end if; else T2 := Etype (Next_Formal (First_Formal (E))); @@ -170,17 +192,81 @@ package body Sem_Intr is if Root_Type (T1) /= Root_Type (T2) or else Root_Type (T1) /= Root_Type (Ret) then - Errint ( - "types of intrinsic operator must have the same size", E, N); + Errint + ("types of intrinsic operator must have the same size", E, N); + end if; + + -- Comparison operators + + elsif Nam = Name_Op_Eq + or else + Nam = Name_Op_Ge + or else + Nam = Name_Op_Gt + or else + Nam = Name_Op_Le + or else + Nam = Name_Op_Lt + or else + Nam = Name_Op_Ne + then + T1 := Etype (First_Formal (E)); + + if No (Next_Formal (First_Formal (E))) then + + -- Previous error in declaration + + return; + + else + T2 := Etype (Next_Formal (First_Formal (E))); + end if; + + if Root_Type (T1) /= Root_Type (T2) then + Errint + ("types of intrinsic operator must have the same size", E, N); + end if; + + if Root_Type (Ret) /= Standard_Boolean then + Errint + ("result type of intrinsic comparison must be boolean", E, N); + end if; + + -- Exponentiation + + elsif Nam = Name_Op_Expon then + T1 := Etype (First_Formal (E)); + + if No (Next_Formal (First_Formal (E))) then + + -- Previous error in declaration + + return; + + else + T2 := Etype (Next_Formal (First_Formal (E))); + end if; - elsif not Is_Numeric_Type (T1) then - Errint ( - " intrinsic operator can only apply to numeric types", E, N); + if not (Is_Integer_Type (T1) + or else + Is_Floating_Point_Type (T1)) + or else Root_Type (T1) /= Root_Type (Ret) + or else Root_Type (T2) /= Root_Type (Standard_Integer) + then + Errint ("incorrect operands for intrinsic operator", N, E); end if; + -- All other operators (are there any?) are not handled + else Errint ("incorrect context for ""Intrinsic"" convention", E, N); + return; end if; + + if not Is_Numeric_Type (T1) then + Errint ("intrinsic operator can only apply to numeric types", E, N); + end if; + end Check_Intrinsic_Operator; -------------------------------- diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb index 800a5e82dc4..060b35535c3 100644 --- a/gcc/ada/sem_mech.adb +++ b/gcc/ada/sem_mech.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.16 $ +-- $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- -- @@ -384,8 +384,7 @@ package body Sem_Mech is when Convention_Fortran => -- In OpenVMS, pass a character of array of character - -- value using Descriptor(S). Should this also test - -- Debug_Flag_M ??? + -- value using Descriptor(S). if OpenVMS_On_Target and then (Root_Type (Typ) = Standard_Character @@ -407,7 +406,6 @@ package body Sem_Mech is -- It is not clear that this is right in the long run, -- but it seems to correspond to what gnu f77 wants. - else Set_Mechanism (Formal, By_Reference); end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 4615f0e81da..23ebb0cc618 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -77,6 +77,8 @@ with Uintp; use Uintp; with Urealp; use Urealp; with Validsw; use Validsw; +with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; + package body Sem_Prag is ---------------------------------------------- @@ -337,10 +339,6 @@ package body Sem_Prag is -- If any argument has an identifier, then an error message is issued, -- and Pragma_Exit is raised. - procedure Check_Non_Overloaded_Function (Arg : Node_Id); - -- Check that the given argument is the name of a local function of - -- one argument that is not overloaded in the current local scope. - procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); -- Checks if the given argument has an identifier, and if so, requires -- it to match the given identifier name. If there is a non-matching @@ -576,8 +574,6 @@ package body Sem_Prag is procedure Check_Ada_83_Warning is begin - GNAT_Pragma; - if Ada_83 and then Comes_From_Source (N) then Error_Msg_N ("(Ada 83) pragma& is non-standard?", N); end if; @@ -1049,33 +1045,6 @@ package body Sem_Prag is end if; end Check_No_Identifiers; - ----------------------------------- - -- Check_Non_Overloaded_Function -- - ----------------------------------- - - procedure Check_Non_Overloaded_Function (Arg : Node_Id) is - Ent : Entity_Id; - - begin - Check_Arg_Is_Local_Name (Arg); - Ent := Entity (Expression (Arg)); - - if Present (Homonym (Ent)) - and then Scope (Homonym (Ent)) = Current_Scope - then - Error_Pragma_Arg - ("argument for pragma% may not be overloaded", Arg); - end if; - - if Ekind (Ent) /= E_Function - or else No (First_Formal (Ent)) - or else Present (Next_Formal (First_Formal (Ent))) - then - Error_Pragma_Arg - ("argument for pragma% must be function of one argument", Arg); - end if; - end Check_Non_Overloaded_Function; - ------------------------------- -- Check_Optional_Identifier -- ------------------------------- @@ -1481,8 +1450,23 @@ package body Sem_Prag is end if; if Index = Names'Last then - Error_Pragma_Arg_Ident - ("pragma% does not allow & argument", Arg); + Error_Msg_Name_1 := Chars (N); + Error_Msg_N ("pragma% does not allow & argument", Arg); + + -- Check for possible misspelling + + for Index1 in Names'Range loop + if Is_Bad_Spelling_Of + (Get_Name_String (Chars (Arg)), + Get_Name_String (Names (Index1))) + then + Error_Msg_Name_1 := Names (Index1); + Error_Msg_N ("\possible misspelling of%", Arg); + exit; + end if; + end loop; + + raise Pragma_Exit; end if; end loop; end if; @@ -1603,9 +1587,9 @@ package body Sem_Prag is E : Entity_Id; D : Node_Id; K : Node_Kind; + Utyp : Entity_Id; begin - GNAT_Pragma; Check_Ada_83_Warning; Check_No_Identifiers; Check_Arg_Count (1); @@ -1648,6 +1632,25 @@ package body Sem_Prag is if Prag_Id /= Pragma_Volatile then Set_Is_Atomic (E); + + -- An interesting improvement here. If an object of type X + -- is declared atomic, and the type X is not atomic, that's + -- a pity, since it may not have appropraite alignment etc. + -- We can rescue this in the special case where the object + -- and type are in the same unit by just setting the type + -- as atomic, so that the back end will process it as atomic. + + Utyp := Underlying_Type (Etype (E)); + + if Present (Utyp) + and then Sloc (E) > No_Location + and then Sloc (Utyp) > No_Location + and then + Get_Source_File_Index (Sloc (E)) = + Get_Source_File_Index (Sloc (Underlying_Type (Etype (E)))) + then + Set_Is_Atomic (Underlying_Type (Etype (E))); + end if; end if; Set_Is_Volatile (E); @@ -1923,6 +1926,7 @@ package body Sem_Prag is Code_Val : Uint; begin + GNAT_Pragma; Process_Extended_Import_Export_Internal_Arg (Arg_Internal); Def_Id := Entity (Arg_Internal); @@ -2506,7 +2510,6 @@ package body Sem_Prag is Next_Formal (Formal); end loop; end if; - end Process_Extended_Import_Export_Subprogram_Pragma; -------------------------- @@ -3941,7 +3944,6 @@ package body Sem_Prag is K : Node_Kind; begin - GNAT_Pragma; Check_Ada_83_Warning; Check_No_Identifiers; Check_Arg_Count (1); @@ -4212,7 +4214,6 @@ package body Sem_Prag is Set_Component_Alignment (Base_Type (Typ), Atype); end if; end if; - end Component_AlignmentP; ---------------- @@ -4256,6 +4257,36 @@ package body Sem_Prag is Process_Convention (C, E); end Convention; + --------------------------- + -- Convention_Identifier -- + --------------------------- + + -- pragma Convention_Identifier ([Name =>] IDENTIFIER, + -- [Convention =>] convention_IDENTIFIER); + + when Pragma_Convention_Identifier => Convention_Identifier : declare + Idnam : Name_Id; + Cname : Name_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (2); + Check_Optional_Identifier (Arg1, Name_Name); + Check_Optional_Identifier (Arg2, Name_Convention); + Check_Arg_Is_Identifier (Arg1); + Check_Arg_Is_Identifier (Arg1); + Idnam := Chars (Expression (Arg1)); + Cname := Chars (Expression (Arg2)); + + if Is_Convention_Name (Cname) then + Record_Convention_Identifier + (Idnam, Get_Convention_Id (Cname)); + else + Error_Pragma_Arg + ("second arg for % pragma must be convention", Arg2); + end if; + end Convention_Identifier; + --------------- -- CPP_Class -- --------------- @@ -4683,7 +4714,6 @@ package body Sem_Prag is E : Entity_Id; begin - GNAT_Pragma; Check_Ada_83_Warning; -- Deal with configuration pragma case @@ -4973,33 +5003,52 @@ package body Sem_Prag is -- SELECTED_COMPONENT | -- STRING_LITERAL] -- [,[Parameter_Types =>] PARAMETER_TYPES] - -- [,[Result_Type =>] result_SUBTYPE_MARK]); + -- [,[Result_Type =>] result_SUBTYPE_NAME] + -- [,[Homonym_Number =>] INTEGER_LITERAL]); - -- PARAMETER_TYPES ::= - -- null - -- (SUBTYPE_MARK, SUBTYPE_MARK, ...) + -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME}) + -- SUBTYPE_NAME ::= STRING_LITERAL - when Pragma_Eliminate => Eliminate : begin + when Pragma_Eliminate => Eliminate : declare + Args : Args_List (1 .. 5); + Names : Name_List (1 .. 5) := ( + Name_Unit_Name, + Name_Entity, + Name_Parameter_Types, + Name_Result_Type, + Name_Homonym_Number); + + Unit_Name : Node_Id renames Args (1); + Entity : Node_Id renames Args (2); + Parameter_Types : Node_Id renames Args (3); + Result_Type : Node_Id renames Args (4); + Homonym_Number : Node_Id renames Args (5); + + begin GNAT_Pragma; - Check_Ada_83_Warning; Check_Valid_Configuration_Pragma; - Check_At_Least_N_Arguments (1); - Check_At_Most_N_Arguments (4); + Gather_Associations (Names, Args); - if Arg_Count = 3 - and then Chars (Arg3) = Name_Result_Type - then - Arg4 := Arg3; - Arg3 := Empty; + if No (Unit_Name) then + Error_Pragma ("missing Unit_Name argument for pragma%"); + end if; - else - Check_Optional_Identifier (Arg1, "unit_name"); - Check_Optional_Identifier (Arg2, Name_Entity); - Check_Optional_Identifier (Arg3, Name_Parameter_Types); - Check_Optional_Identifier (Arg4, Name_Result_Type); + if No (Entity) + and then (Present (Parameter_Types) + or else + Present (Result_Type) + or else + Present (Homonym_Number)) + then + Error_Pragma ("missing Entity argument for pragma%"); end if; - Process_Eliminate_Pragma (Arg1, Arg2, Arg3, Arg4); + Process_Eliminate_Pragma + (Unit_Name, + Entity, + Parameter_Types, + Result_Type, + Homonym_Number); end Eliminate; ------------ @@ -5054,8 +5103,6 @@ package body Sem_Prag is Code : Node_Id renames Args (4); begin - GNAT_Pragma; - if Inside_A_Generic then Error_Pragma ("pragma% cannot be used for generic entities"); end if; @@ -5333,7 +5380,6 @@ package body Sem_Prag is when others => null; end case; - end External_Name_Casing; --------------------------- @@ -5373,7 +5419,7 @@ package body Sem_Prag is Error_Pragma ("duplicate pragma%, only one allowed"); elsif not Rep_Item_Too_Late (Typ, N) then - Set_Finalize_Storage_Only (Typ, True); + Set_Finalize_Storage_Only (Base_Type (Typ), True); end if; end Finalize_Storage; @@ -5476,7 +5522,6 @@ package body Sem_Prag is end case; end if; end if; - end Float_Representation; ----------- @@ -5637,7 +5682,6 @@ package body Sem_Prag is Code : Node_Id renames Args (4); begin - GNAT_Pragma; Gather_Associations (Names, Args); if Present (External) and then Present (Code) then @@ -5654,7 +5698,6 @@ package body Sem_Prag is if not Is_VMS_Exception (Entity (Internal)) then Set_Imported (Entity (Internal)); end if; - end Import_Exception; --------------------- @@ -6237,9 +6280,10 @@ package body Sem_Prag is while Present (Arg) loop Check_Arg_Is_Static_Expression (Arg, Standard_String); - -- Store argument, converting sequences of spaces to - -- a single null character (this is the difference in - -- processing between Link_With, and Linker_Options). + -- Store argument, converting sequences of spaces + -- to a single null character (this is one of the + -- differences in processing between Link_With + -- and Linker_Options). declare C : constant Char_Code := Get_Char_Code (' '); @@ -6323,19 +6367,18 @@ package body Sem_Prag is -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION}); - -- Note: the use of multiple arguments is a GNAT extension - when Pragma_Linker_Options => Linker_Options : declare Arg : Node_Id; begin + Check_Ada_83_Warning; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Is_In_Decl_Part_Or_Package_Spec; + if Operating_Mode = Generate_Code and then In_Extended_Main_Source_Unit (N) then - Check_Ada_83_Warning; - Check_At_Least_N_Arguments (1); - Check_No_Identifiers; - Check_Is_In_Decl_Part_Or_Package_Spec; Check_Arg_Is_Static_Expression (Arg1, Standard_String); Start_String (Strval (Expr_Value_S (Expression (Arg1)))); @@ -6598,7 +6641,6 @@ package body Sem_Prag is Next (Nod); end loop; - end Main_Storage; ----------------- @@ -6946,7 +6988,6 @@ package body Sem_Prag is -- exp_ch9 should use this ??? end if; end if; - end Priority; -------------------------- @@ -6997,6 +7038,10 @@ package body Sem_Prag is -- than 31 characters, or a string literal with more than -- 31 characters, and we are operating under VMS + -------------------- + -- Check_Too_Long -- + -------------------- + procedure Check_Too_Long (Arg : Node_Id) is X : Node_Id := Original_Node (Arg); @@ -7207,7 +7252,6 @@ package body Sem_Prag is (Sloc => Sloc (R_External), Strval => Str)))); Analyze (MA); - end Psect_Object; ---------- @@ -7438,6 +7482,11 @@ package body Sem_Prag is -- Restriction is active else + if Implementation_Restriction (R_Id) then + Check_Restriction + (No_Implementation_Restrictions, Arg); + end if; + Restrictions (R_Id) := True; Restrictions_Loc (R_Id) := Sloc (N); @@ -7530,6 +7579,7 @@ package body Sem_Prag is -- pragma Shared (LOCAL_NAME); when Pragma_Shared => + GNAT_Pragma; Process_Atomic_Shared_Volatile; -------------------- @@ -7666,15 +7716,51 @@ package body Sem_Prag is -- [Read =>] function_NAME, -- [Write =>] function NAME); - when Pragma_Stream_Convert => Stream_Convert : begin + when Pragma_Stream_Convert => Stream_Convert : declare + + procedure Check_OK_Stream_Convert_Function (Arg : Node_Id); + -- Check that the given argument is the name of a local + -- function of one argument that is not overloaded earlier + -- in the current local scope. A check is also made that the + -- argument is a function with one parameter. + + -------------------------------------- + -- Check_OK_Stream_Convert_Function -- + -------------------------------------- + + procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is + Ent : Entity_Id; + + begin + Check_Arg_Is_Local_Name (Arg); + Ent := Entity (Expression (Arg)); + + if Has_Homonym (Ent) then + Error_Pragma_Arg + ("argument for pragma% may not be overloaded", Arg); + end if; + + if Ekind (Ent) /= E_Function + or else No (First_Formal (Ent)) + or else Present (Next_Formal (First_Formal (Ent))) + then + Error_Pragma_Arg + ("argument for pragma% must be" & + " function of one argument", Arg); + end if; + end Check_OK_Stream_Convert_Function; + + -- Start of procecessing for Stream_Convert + + begin GNAT_Pragma; Check_Arg_Count (3); Check_Optional_Identifier (Arg1, Name_Entity); Check_Optional_Identifier (Arg2, Name_Read); Check_Optional_Identifier (Arg3, Name_Write); Check_Arg_Is_Local_Name (Arg1); - Check_Non_Overloaded_Function (Arg2); - Check_Non_Overloaded_Function (Arg3); + Check_OK_Stream_Convert_Function (Arg2); + Check_OK_Stream_Convert_Function (Arg3); declare Typ : constant Entity_Id := @@ -7993,7 +8079,6 @@ package body Sem_Prag is else Set_Has_Task_Info_Pragma (P, True); end if; - end Task_Info; --------------- @@ -8025,7 +8110,6 @@ package body Sem_Prag is Set_Has_Task_Name_Pragma (P, True); Record_Rep_Item (Defining_Identifier (Parent (P)), N); end if; - end Task_Name; ------------------ @@ -8071,7 +8155,6 @@ package body Sem_Prag is if Rep_Item_Too_Late (Ent, N) then raise Pragma_Exit; end if; - end Task_Storage; ---------------- @@ -8339,6 +8422,59 @@ package body Sem_Prag is end if; end Unimplemented_Unit; + -------------------- + -- Universal_Data -- + -------------------- + + -- pragma Universal_Data; + + when Pragma_Universal_Data => + GNAT_Pragma; + Check_Arg_Count (0); + Check_Valid_Library_Unit_Pragma; + + if not AAMP_On_Target then + Error_Pragma ("?pragma% ignored (applies only to AAMP)"); + end if; + + ------------------ + -- Unreferenced -- + ------------------ + + -- pragma Unreferenced (local_Name {, local_Name}); + + when Pragma_Unreferenced => Unreferenced : declare + Arg_Node : Node_Id; + Arg_Expr : Node_Id; + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + + Arg_Node := Arg1; + + while Present (Arg_Node) loop + Check_No_Identifier (Arg_Node); + + -- Note that the analyze call done by Check_Arg_Is_Local_Name + -- will in fact generate a reference, so that the entity will + -- have a reference, which will inhibit any warnings about it + -- not being referenced, and also properly show up in the ali + -- file as a reference. But this reference is recorded before + -- the Has_Pragma_Unreferenced flag is set, so that no warning + -- is generated for this reference. + + Check_Arg_Is_Local_Name (Arg_Node); + Arg_Expr := Get_Pragma_Arg (Arg_Node); + + if Is_Entity_Name (Arg_Expr) then + Set_Has_Pragma_Unreferenced (Entity (Arg_Expr)); + end if; + + Next (Arg_Node); + end loop; + end Unreferenced; + ------------------------------ -- Unreserve_All_Interrupts -- ------------------------------ @@ -8648,7 +8784,6 @@ package body Sem_Prag is else return False; end if; - end Is_Pragma_String_Literal; -------------------------------------- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 09b55850ac7..43a9d969891 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -195,15 +195,15 @@ package body Sem_Res is procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id); -- The String_Literal_Subtype is built for all strings that are not - -- operands of a static concatenation operation. If the argument is not - -- a String the function is a no-op. + -- operands of a static concatenation operation. If the argument is + -- not a N_String_Literal node, then the call has no effect. procedure Set_Slice_Subtype (N : Node_Id); -- Build subtype of array type, with the range specified by the slice. function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id; - -- A universal_fixed expression in an universal context is unambiguous if - -- there is only one applicable fixed point type. Determining whether + -- A universal_fixed expression in an universal context is unambiguous + -- if there is only one applicable fixed point type. Determining whether -- there is only one requires a search over all visible entities, and -- happens only in very pathological cases (see 6115-006). @@ -589,6 +589,45 @@ package body Sem_Res is P : Node_Id; C : Node_Id; + function Same_Argument_List return Boolean; + -- Check whether list of actuals is identical to list of formals + -- of called function (which is also the enclosing scope). + + ------------------------ + -- Same_Argument_List -- + ------------------------ + + function Same_Argument_List return Boolean is + A : Node_Id; + F : Entity_Id; + Subp : Entity_Id; + + begin + if not Is_Entity_Name (Name (N)) then + return False; + else + Subp := Entity (Name (N)); + end if; + + F := First_Formal (Subp); + A := First_Actual (N); + + while Present (F) and then Present (A) loop + if not Is_Entity_Name (A) + or else Entity (A) /= F + then + return False; + end if; + + Next_Actual (A); + Next_Formal (F); + end loop; + + return True; + end Same_Argument_List; + + -- Start of processing for Check_Infinite_Recursion + begin -- Loop moving up tree, quitting if something tells us we are -- definitely not in an infinite recursion situation. @@ -608,6 +647,32 @@ package body Sem_Res is elsif Nkind (P) = N_Handled_Sequence_Of_Statements and then C /= First (Statements (P)) then + -- If the call is the expression of a return statement and + -- the actuals are identical to the formals, it's worth a + -- warning. However, we skip this if there is an immediately + -- preceding raise statement, since the call is never executed. + + -- Furthermore, this corresponds to a common idiom: + + -- function F (L : Thing) return Boolean is + -- begin + -- raise Program_Error; + -- return F (L); + -- end F; + + -- for generating a stub function + + if Nkind (Parent (N)) = N_Return_Statement + and then Same_Argument_List + then + exit when not Is_List_Member (Parent (N)) + or else (Nkind (Prev (Parent (N))) /= N_Raise_Statement + and then + (Nkind (Prev (Parent (N))) not in N_Raise_xxx_Error + or else + Present (Condition (Prev (Parent (N)))))); + end if; + return False; else @@ -631,16 +696,22 @@ package body Sem_Res is Typ : Entity_Id := Etype (First_Formal (Nam)); function Uses_SS (T : Entity_Id) return Boolean; + -- Check whether the creation of an object of the type will involve + -- use of the secondary stack. If T is a record type, this is true + -- if the expression for some component uses the secondary stack, eg. + -- through a call to a function that returns an unconstrained value. + -- False if T is controlled, because cleanups occur elsewhere. + + ------------- + -- Uses_SS -- + ------------- function Uses_SS (T : Entity_Id) return Boolean is Comp : Entity_Id; Expr : Node_Id; begin - if Is_Controlled (T) - or else Has_Controlled_Component (T) - or else Functions_Return_By_DSP_On_Target - then + if Is_Controlled (T) then return False; elsif Is_Array_Type (T) then @@ -676,8 +747,18 @@ package body Sem_Res is end if; end Uses_SS; + -- Start of processing for Check_Initialization_Call + begin - if Uses_SS (Typ) then + -- Nothing to do if functions do not use the secondary stack for + -- returns (i.e. they use a depressed stack pointer instead). + + if Functions_Return_By_DSP_On_Target then + return; + + -- Otherwise establish a transient scope if the type needs it + + elsif Uses_SS (Typ) then Establish_Transient_Scope (First_Actual (N), Sec_Stack => True); end if; end Check_Initialization_Call; @@ -690,8 +771,16 @@ package body Sem_Res is Nam : Node_Id; begin - if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then - return; + -- Defend against junk stuff if errors already detected + + if Total_Errors_Detected /= 0 then + if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then + return; + elsif Nkind (N) in N_Has_Chars + and then Chars (N) in Error_Name_Or_No_Name + then + return; + end if; end if; -- Rewrite as call if overloadable entity that is (or could be, in @@ -1425,14 +1514,16 @@ package body Sem_Res is Debug_A_Entry ("resolving ", N); - if Is_Fixed_Point_Type (Typ) then - Check_Restriction (No_Fixed_Point, N); + if Comes_From_Source (N) then + if Is_Fixed_Point_Type (Typ) then + Check_Restriction (No_Fixed_Point, N); - elsif Is_Floating_Point_Type (Typ) - and then Typ /= Universal_Real - and then Typ /= Any_Real - then - Check_Restriction (No_Floating_Point, N); + elsif Is_Floating_Point_Type (Typ) + and then Typ /= Universal_Real + and then Typ /= Any_Real + then + Check_Restriction (No_Floating_Point, N); + end if; end if; -- Return if already analyzed @@ -2142,7 +2233,8 @@ package body Sem_Res is if Raises_Constraint_Error (Actval) then Rewrite (Actval, - Make_Raise_Constraint_Error (Loc)); + Make_Raise_Constraint_Error (Loc, + Reason => CE_Range_Check_Failed)); Set_Raises_Constraint_Error (Actval); Set_Etype (Actval, Etype (F)); end if; @@ -2194,6 +2286,17 @@ package body Sem_Res is while Present (F) loop + -- If we have an error in any actual or formal, indicated by + -- a type of Any_Type, then abandon resolution attempt, and + -- set result type to Any_Type. + + if (No (A) or else Etype (A) = Any_Type or else Etype (F) = Any_Type) + and then Total_Errors_Detected /= 0 + then + Set_Etype (N, Any_Type); + return; + end if; + if Present (A) and then (Nkind (Parent (A)) /= N_Parameter_Association or else @@ -2213,6 +2316,16 @@ package body Sem_Res is and then Nkind (A) = N_Type_Conversion and then not Is_Class_Wide_Type (Etype (Expression (A))) then + if Ekind (F) = E_In_Out_Parameter + and then Is_Array_Type (Etype (F)) + and then Has_Aliased_Components (Etype (Expression (A))) + /= Has_Aliased_Components (Etype (F)) + then + Error_Msg_N + ("both component types in a view conversion must be" + & " aliased, or neither", A); + end if; + if Conversion_OK (A) or else Valid_Conversion (A, Etype (A), Expression (A)) then @@ -2246,6 +2359,11 @@ package body Sem_Res is end if; end if; + if Etype (A) = Any_Type then + Set_Etype (N, Any_Type); + return; + end if; + if Ekind (F) /= E_Out_Parameter then Check_Unset_Reference (A); @@ -2376,7 +2494,10 @@ package body Sem_Res is and then not Is_Controlling_Formal (F) then Error_Msg_N ("class-wide argument not allowed here!", A); - if Is_Subprogram (Nam) then + + if Is_Subprogram (Nam) + and then Comes_From_Source (Nam) + then Error_Msg_Node_2 := F_Typ; Error_Msg_NE ("& is not a primitive operation of &!", A, Nam); @@ -2386,14 +2507,18 @@ package body Sem_Res is and then Is_Access_Type (F_Typ) and then Ekind (F_Typ) /= E_Access_Subprogram_Type and then (Is_Class_Wide_Type (Designated_Type (A_Typ)) - or else (Nkind (A) = N_Attribute_Reference - and then Is_Class_Wide_Type (Etype (Prefix (A))))) + or else (Nkind (A) = N_Attribute_Reference + and then + Is_Class_Wide_Type (Etype (Prefix (A))))) and then not Is_Class_Wide_Type (Designated_Type (F_Typ)) and then not Is_Controlling_Formal (F) then Error_Msg_N ("access to class-wide argument not allowed here!", A); - if Is_Subprogram (Nam) then + + if Is_Subprogram (Nam) + and then Comes_From_Source (Nam) + then Error_Msg_Node_2 := Designated_Type (F_Typ); Error_Msg_NE ("& is not a primitive operation of &!", A, Nam); @@ -2435,6 +2560,27 @@ package body Sem_Res is Constr : Node_Id; Disc_Exp : Node_Id; + function In_Dispatching_Context return Boolean; + -- If the allocator is an actual in a call, it is allowed to be + -- class-wide when the context is not because it is a controlling + -- actual. + + ---------------------------- + -- In_Dispatching_Context -- + ---------------------------- + + function In_Dispatching_Context return Boolean is + Par : constant Node_Id := Parent (N); + + begin + return (Nkind (Par) = N_Function_Call + or else Nkind (Par) = N_Procedure_Call_Statement) + and then Is_Entity_Name (Name (Par)) + and then Is_Dispatching_Operation (Entity (Name (Par))); + end In_Dispatching_Context; + + -- Start of processing for Resolve_Allocator + begin -- Replace general access with specific type @@ -2452,6 +2598,7 @@ package body Sem_Res is if Nkind (E) = N_Qualified_Expression then if Is_Class_Wide_Type (Etype (E)) and then not Is_Class_Wide_Type (Designated_Type (Typ)) + and then not In_Dispatching_Context then Error_Msg_N ("class-wide allocator not allowed for this access type", N); @@ -2545,7 +2692,8 @@ package body Sem_Res is Error_Msg_N ("?allocation from empty storage pool!", N); Error_Msg_N ("?Storage_Error will be raised at run time!", N); Insert_Action (N, - Make_Raise_Storage_Error (Loc)); + Make_Raise_Storage_Error (Loc, + Reason => SE_Empty_Storage_Pool)); end; end if; end Resolve_Allocator; @@ -3312,18 +3460,6 @@ package body Sem_Res is then Check_Dispatching_Call (N); - -- If the subprogram is abstract, check that the call has a - -- controlling argument (i.e. is dispatching) or is disptaching on - -- result - - if Is_Abstract (Nam) - and then No (Controlling_Argument (N)) - and then not Is_Class_Wide_Type (Typ) - and then not Is_Tag_Indeterminate (N) - then - Error_Msg_N ("call to abstract subprogram must be dispatching", N); - end if; - elsif Is_Abstract (Nam) and then not In_Instance then @@ -3592,6 +3728,13 @@ package body Sem_Res is E : constant Entity_Id := Entity (N); begin + -- If garbage from errors, set to Any_Type and return + + if No (E) and then Total_Errors_Detected /= 0 then + Set_Etype (N, Any_Type); + return; + end if; + -- Replace named numbers by corresponding literals. Note that this is -- the one case where Resolve_Entity_Name must reset the Etype, since -- it is currently marked as universal. @@ -4465,6 +4608,11 @@ package body Sem_Res is ("no modular type available in this context", N); Set_Etype (N, Any_Type); return; + elsif Is_Modular_Integer_Type (Typ) + and then Etype (Left_Opnd (N)) = Universal_Integer + and then Etype (Right_Opnd (N)) = Universal_Integer + then + Check_For_Visible_Operator (N, B_Typ); end if; Resolve (Left_Opnd (N), B_Typ); @@ -4487,6 +4635,8 @@ package body Sem_Res is -- rule for universal types applies. procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is + pragma Warnings (Off, Typ); + L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); T : Entity_Id; @@ -4860,6 +5010,9 @@ package body Sem_Res is -- Nothing to be done, all resolved already procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is + pragma Warnings (Off, N); + pragma Warnings (Off, Typ); + begin null; end Resolve_Operator_Symbol; @@ -4869,6 +5022,8 @@ package body Sem_Res is ---------------------------------- procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is + pragma Warnings (Off, Typ); + Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N)); Expr : constant Node_Id := Expression (N); @@ -5486,7 +5641,7 @@ package body Sem_Res is or else Char_Val > Expr_Value (Comp_Typ_Hi) then Apply_Compile_Time_Constraint_Error - (N, "character out of range?", + (N, "character out of range?", CE_Range_Check_Failed, Loc => Source_Ptr (Int (Loc) + J)); end if; end loop; @@ -5716,6 +5871,8 @@ package body Sem_Res is (N : Node_Id; Typ : Entity_Id) is + pragma Warnings (Off, Typ); + Operand : constant Node_Id := Expression (N); Opnd_Type : constant Entity_Id := Etype (Operand); @@ -5837,7 +5994,6 @@ package body Sem_Res is Set_Etype (Index, Index_Subtype); Append (Index, Index_List); - Set_Component_Type (Slice_Subtype, Component_Type (Etype (N))); Set_First_Index (Slice_Subtype, Index); Set_Etype (Slice_Subtype, Base_Type (Etype (N))); Set_Is_Constrained (Slice_Subtype, True); @@ -5872,12 +6028,10 @@ package body Sem_Res is begin if Nkind (N) /= N_String_Literal then return; - else Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); end if; - Set_Component_Type (Subtype_Id, Component_Type (Typ)); Set_String_Literal_Length (Subtype_Id, UI_From_Int (String_Length (Strval (N)))); Set_Etype (Subtype_Id, Base_Type (Typ)); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index ef0626010f9..7608e8738e2 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -525,7 +525,17 @@ package body Sem_Type is function Covers (T1, T2 : Entity_Id) return Boolean is begin - pragma Assert (Present (T1) and Present (T2)); + -- If either operand missing, then this is an error, but ignore + -- it (and pretend we have a cover) if errors already detected, + -- since this may simply mean we have malformed trees. + + if No (T1) or else No (T2) then + if Total_Errors_Detected /= 0 then + return True; + else + raise Program_Error; + end if; + end if; -- Simplest case: same types are compatible, and types that have the -- same base type and are not generic actuals are compatible. Generic @@ -869,7 +879,7 @@ package body Sem_Type is Get_Next_Interp (I, It); end loop; - if Errors_Detected > 0 then + if Serious_Errors_Detected > 0 then -- After some error, a formal may have Any_Type and yield -- a spurious match. To avoid cascaded errors if possible, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 53b9ce68d2a..cfb8b0820f9 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1,4 +1,4 @@ ------------------------------------------------------------------------------ +------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -106,12 +106,13 @@ package body Sem_Util is ----------------------------------------- procedure Apply_Compile_Time_Constraint_Error - (N : Node_Id; - Msg : String; - Ent : Entity_Id := Empty; - Typ : Entity_Id := Empty; - Loc : Source_Ptr := No_Location; - Rep : Boolean := True) + (N : Node_Id; + Msg : String; + Reason : RT_Exception_Code; + Ent : Entity_Id := Empty; + Typ : Entity_Id := Empty; + Loc : Source_Ptr := No_Location; + Rep : Boolean := True) is Stat : constant Boolean := Is_Static_Expression (N); Rtyp : Entity_Id; @@ -132,7 +133,9 @@ package body Sem_Util is -- Now we replace the node by an N_Raise_Constraint_Error node -- This does not need reanalyzing, so set it as analyzed now. - Rewrite (N, Make_Raise_Constraint_Error (Sloc (N))); + Rewrite (N, + Make_Raise_Constraint_Error (Sloc (N), + Reason => Reason)); Set_Analyzed (N, True); Set_Etype (N, Rtyp); Set_Raises_Constraint_Error (N); @@ -677,6 +680,130 @@ package body Sem_Util is Set_Has_Fully_Qualified_Name (Elab_Ent); end Build_Elaboration_Entity; + ----------------------------------- + -- Cannot_Raise_Constraint_Error -- + ----------------------------------- + + function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is + begin + if Compile_Time_Known_Value (Expr) then + return True; + + elsif Do_Range_Check (Expr) then + return False; + + elsif Raises_Constraint_Error (Expr) then + return False; + + else + case Nkind (Expr) is + when N_Identifier => + return True; + + when N_Expanded_Name => + return True; + + when N_Selected_Component => + return not Do_Discriminant_Check (Expr); + + when N_Attribute_Reference => + if Do_Overflow_Check (Expr) + or else Do_Access_Check (Expr) + then + return False; + + elsif No (Expressions (Expr)) then + return True; + + else + declare + N : Node_Id := First (Expressions (Expr)); + + begin + while Present (N) loop + if Cannot_Raise_Constraint_Error (N) then + Next (N); + else + return False; + end if; + end loop; + + return True; + end; + end if; + + when N_Type_Conversion => + if Do_Overflow_Check (Expr) + or else Do_Length_Check (Expr) + or else Do_Tag_Check (Expr) + then + return False; + else + return + Cannot_Raise_Constraint_Error (Expression (Expr)); + end if; + + when N_Unchecked_Type_Conversion => + return Cannot_Raise_Constraint_Error (Expression (Expr)); + + when N_Unary_Op => + if Do_Overflow_Check (Expr) then + return False; + else + return + Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); + end if; + + when N_Op_Divide | + N_Op_Mod | + N_Op_Rem + => + if Do_Division_Check (Expr) + or else Do_Overflow_Check (Expr) + then + return False; + else + return + Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) + and then + Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); + end if; + + when N_Op_Add | + N_Op_And | + N_Op_Concat | + N_Op_Eq | + N_Op_Expon | + N_Op_Ge | + N_Op_Gt | + N_Op_Le | + N_Op_Lt | + N_Op_Multiply | + N_Op_Ne | + N_Op_Or | + N_Op_Rotate_Left | + N_Op_Rotate_Right | + N_Op_Shift_Left | + N_Op_Shift_Right | + N_Op_Shift_Right_Arithmetic | + N_Op_Subtract | + N_Op_Xor + => + if Do_Overflow_Check (Expr) then + return False; + else + return + Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) + and then + Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); + end if; + + when others => + return False; + end case; + end if; + end Cannot_Raise_Constraint_Error; + -------------------------- -- Check_Fully_Declared -- -------------------------- @@ -720,7 +847,8 @@ package body Sem_Util is if Is_Protected_Type (S) then if Restricted_Profile then Insert_Before (N, - Make_Raise_Program_Error (Loc)); + Make_Raise_Program_Error (Loc, + Reason => PE_Potentially_Blocking_Operation)); Error_Msg_N ("potentially blocking operation, " & " Program Error will be raised at run time?", N); @@ -901,6 +1029,7 @@ package body Sem_Util is Warn : Boolean; P : Node_Id; Msgs : Boolean; + Eloc : Source_Ptr; begin -- A static constraint error in an instance body is not a fatal error. @@ -911,6 +1040,11 @@ package body Sem_Util is -- No messages are generated if we already posted an error on this node if not Error_Posted (N) then + if Loc /= No_Location then + Eloc := Loc; + else + Eloc := Sloc (N); + end if; -- Make all such messages unconditional @@ -978,25 +1112,25 @@ package body Sem_Util is if Msgs then if Present (Ent) then - Error_Msg_NE (Msgc (1 .. Msgl), N, Ent); + Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc); else - Error_Msg_NE (Msgc (1 .. Msgl), N, Etype (N)); + Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc); end if; if Warn then if Inside_Init_Proc then - Error_Msg_NE + Error_Msg_NEL ("\& will be raised for objects of this type!?", - N, Standard_Constraint_Error); + N, Standard_Constraint_Error, Eloc); else - Error_Msg_NE + Error_Msg_NEL ("\& will be raised at run time!?", - N, Standard_Constraint_Error); + N, Standard_Constraint_Error, Eloc); end if; else - Error_Msg_NE + Error_Msg_NEL ("\static expression raises&!", - N, Standard_Constraint_Error); + N, Standard_Constraint_Error, Eloc); end if; end if; end if; @@ -2188,6 +2322,21 @@ package body Sem_Util is end if; end Get_Enum_Lit_From_Pos; + ------------------------ + -- Get_Generic_Entity -- + ------------------------ + + function Get_Generic_Entity (N : Node_Id) return Entity_Id is + Ent : constant Entity_Id := Entity (Name (N)); + + begin + if Present (Renamed_Object (Ent)) then + return Renamed_Object (Ent); + else + return Ent; + end if; + end Get_Generic_Entity; + ---------------------- -- Get_Index_Bounds -- ---------------------- @@ -2827,8 +2976,16 @@ package body Sem_Util is Comp := Original_Record_Component (Entity (Selector_Name (Object))); + -- As per AI-0017, the renaming is illegal in a generic body, + -- even if the subtype is indefinite. + if not Is_Constrained (Prefix_Type) - and then not Is_Indefinite_Subtype (Prefix_Type) + and then (not Is_Indefinite_Subtype (Prefix_Type) + or else + (Is_Generic_Type (Prefix_Type) + and then Ekind (Current_Scope) = E_Generic_Package + and then In_Package_Body (Current_Scope))) + and then (Is_Declared_Within_Variant (Comp) or else Has_Dependent_Constraint (Comp)) and then not P_Aliased @@ -2944,6 +3101,8 @@ package body Sem_Util is end; end if; + -- If no null indexes, then type is not fully initialized + return False; elsif Is_Record_Type (Typ) then @@ -2966,6 +3125,9 @@ package body Sem_Util is end loop; end; + -- No uninitialized components, so type is fully initialized. + -- Note that this catches the case of no components as well. + return True; elsif Is_Concurrent_Type (Typ) then @@ -3060,6 +3222,11 @@ package body Sem_Util is when N_Function_Call => return True; + -- A reference to the stream attribute Input is a function call. + + when N_Attribute_Reference => + return Attribute_Name (N) = Name_Input; + when N_Selected_Component => return Is_Object_Reference (Selector_Name (N)); @@ -3159,6 +3326,126 @@ package body Sem_Util is end if; end Is_OK_Variable_For_Out_Formal; + ----------------------------------- + -- Is_Partially_Initialized_Type -- + ----------------------------------- + + function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean is + begin + if Is_Scalar_Type (Typ) then + return False; + + elsif Is_Access_Type (Typ) then + return True; + + elsif Is_Array_Type (Typ) then + + -- If component type is partially initialized, so is array type + + if Is_Partially_Initialized_Type (Component_Type (Typ)) then + return True; + + -- Otherwise we are only partially initialized if we are fully + -- initialized (this is the empty array case, no point in us + -- duplicating that code here). + + else + return Is_Fully_Initialized_Type (Typ); + end if; + + elsif Is_Record_Type (Typ) then + + -- A discriminated type is always partially initialized + + if Has_Discriminants (Typ) then + return True; + + -- A tagged type is always partially initialized + + elsif Is_Tagged_Type (Typ) then + return True; + + -- Case of non-discriminated record + + else + declare + Ent : Entity_Id; + + Component_Present : Boolean := False; + -- Set True if at least one component is present. If no + -- components are present, then record type is fully + -- initialized (another odd case, like the null array). + + begin + -- Loop through components + + Ent := First_Entity (Typ); + while Present (Ent) loop + if Ekind (Ent) = E_Component then + Component_Present := True; + + -- If a component has an initialization expression then + -- the enclosing record type is partially initialized + + if Present (Parent (Ent)) + and then Present (Expression (Parent (Ent))) + then + return True; + + -- If a component is of a type which is itself partially + -- initialized, then the enclosing record type is also. + + elsif Is_Partially_Initialized_Type (Etype (Ent)) then + return True; + end if; + end if; + + Next_Entity (Ent); + end loop; + + -- No initialized components found. If we found any components + -- they were all uninitialized so the result is false. + + if Component_Present then + return False; + + -- But if we found no components, then all the components are + -- initialized so we consider the type to be initialized. + + else + return True; + end if; + end; + end if; + + -- Concurrent types are always fully initialized + + elsif Is_Concurrent_Type (Typ) then + return True; + + -- For a private type, go to underlying type. If there is no underlying + -- type then just assume this partially initialized. Not clear if this + -- can happen in a non-error case, but no harm in testing for this. + + elsif Is_Private_Type (Typ) then + declare + U : constant Entity_Id := Underlying_Type (Typ); + + begin + if No (U) then + return True; + else + return Is_Partially_Initialized_Type (U); + end if; + end; + + -- For any other type (are there any?) assume partially initialized + + else + return True; + end if; + end Is_Partially_Initialized_Type; + ----------------------------- -- Is_RCI_Pkg_Spec_Or_Body -- ----------------------------- @@ -4225,10 +4512,13 @@ package body Sem_Util is -- Process_End_Label -- ----------------------- - procedure Process_End_Label (N : Node_Id; Typ : Character) is + procedure Process_End_Label + (N : Node_Id; + Typ : Character; + Ent : Entity_Id) + is Loc : Source_Ptr; Nam : Node_Id; - Ctyp : Entity_Id; Label_Ref : Boolean; -- Set True if reference to end label itself is required @@ -4238,14 +4528,15 @@ package body Sem_Util is -- the entity Ent. For the child unit case, this is the identifier -- from the designator. For other cases, this is simply Endl. - Ent : Entity_Id; - -- This is the entity for the construct to which the End_Label applies - procedure Generate_Parent_Ref (N : Node_Id); -- N is an identifier node that appears as a parent unit reference -- in the case where Ent is a child unit. This procedure generates -- an appropriate cross-reference entry. + ------------------------- + -- Generate_Parent_Ref -- + ------------------------- + procedure Generate_Parent_Ref (N : Node_Id) is Parent_Ent : Entity_Id; @@ -4353,41 +4644,13 @@ package body Sem_Util is end if; end if; - -- Locate the entity to which the end label applies. Most of the - -- time this is simply the current scope containing the construct. - - Ent := Current_Scope; + -- If the end label is not for the given entity, then either we have + -- some previous error, or this is a generic instantiation for which + -- we do not need to make a cross-reference in this case anyway. In + -- either case we simply ignore the call. - if Chars (Ent) = Chars (Endl) then - null; - - -- But in the case of single tasks and single protected objects, - -- the current scope is the anonymous task or protected type and - -- what we want is the object. There is no direct link so what we - -- do is search ahead in the entity chain for the object with the - -- matching type and name. In practice it is almost certain to be - -- the very next entity on the chain, so this is not inefficient. - - else - Ctyp := Etype (Ent); - loop - Next_Entity (Ent); - - -- If we don't find the entry we are looking for, that's - -- odd, perhaps results from some error condition? Anyway - -- the appropriate thing is just to abandon the attempt. - - if No (Ent) then - return; - - -- Exit if we find the entity we are looking for - - elsif Etype (Ent) = Ctyp - and then Chars (Ent) = Chars (Endl) - then - exit; - end if; - end loop; + if Chars (Ent) /= Chars (Endl) then + return; end if; -- If label was really there, then generate a normal reference @@ -4399,11 +4662,11 @@ package body Sem_Util is if Comes_From_Source (Endl) then -- If a label reference is required, then do the style check - -- and generate a normal cross-reference entry for the label + -- and generate an l-type cross-reference entry for the label if Label_Ref then Style.Check_Identifier (Endl, Ent); - Generate_Reference (Ent, Endl, 'r', Set_Ref => False); + Generate_Reference (Ent, Endl, 'l', Set_Ref => False); end if; -- Set the location to point past the label (normally this will diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 303086b379f..1af10aec9a4 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -46,26 +46,27 @@ package Sem_Util is -- entity is not yet known to the compiler. procedure Apply_Compile_Time_Constraint_Error - (N : Node_Id; - Msg : String; - Ent : Entity_Id := Empty; - Typ : Entity_Id := Empty; - Loc : Source_Ptr := No_Location; - Rep : Boolean := True); + (N : Node_Id; + Msg : String; + Reason : RT_Exception_Code; + Ent : Entity_Id := Empty; + Typ : Entity_Id := Empty; + Loc : Source_Ptr := No_Location; + Rep : Boolean := True); -- N is a subexpression which will raise constraint error when evaluated -- at runtime. Msg is a message that explains the reason for raising the - -- exception. The last character is ? if the message is always a - -- warning, even in Ada 95, and is not a ? if the message represents an - -- illegality (because of violation of static expression rules) in Ada 95 - -- (but not in Ada 83). Typically this routine posts all messages at - -- the Sloc of node N. However, if Loc /= No_Location, Loc is the Sloc - -- used to output the message. After posting the appropriate message, - -- and if the flag Rep is set, this routine replaces the expression - -- with an N_Raise_Constraint_Error node. This node is then marked as - -- being static if the original node is static, but sets the flag - -- Raises_Constraint_Error, preventing further evaluation. - -- The error message may contain a } or & insertion character. - -- This normally references Etype (N), unless the Ent argument is given + -- exception. The last character is ? if the message is always a warning, + -- even in Ada 95, and is not a ? if the message represents an illegality + -- (because of violation of static expression rules) in Ada 95 (but not + -- in Ada 83). Typically this routine posts all messages at the Sloc of + -- node N. However, if Loc /= No_Location, Loc is the Sloc used to output + -- the message. After posting the appropriate message, and if the flag + -- Rep is set, this routine replaces the expression with an appropriate + -- N_Raise_Constraint_Error node using the given Reason code. This node + -- is then marked as being static if the original node is static, but + -- sets the flag Raises_Constraint_Error, preventing further evaluation. + -- The error message may contain a } or & insertion character. This + -- normally references Etype (N), unless the Ent argument is given -- explicitly, in which case it is used instead. The type of the raise -- node that is built is normally Etype (N), but if the Typ parameter -- is present, this is used instead. @@ -97,6 +98,12 @@ package Sem_Util is -- the compilation unit, and install it in the Elaboration_Entity field -- of Spec_Id, the entity for the compilation unit. + function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean; + -- Returns True if the expression cannot possibly raise Constraint_Error. + -- The response is conservative in the sense that a result of False does + -- not necessarily mean that CE could be raised, but a response of True + -- means that for sure CE cannot be raised. + procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id); -- Verify that the full declaration of type T has been seen. If not, -- place error message on node N. Used in object declarations, type @@ -293,6 +300,11 @@ package Sem_Util is -- an identifier provided as the external name. Letters in the name are -- according to the setting of Opt.External_Name_Default_Casing. + function Get_Generic_Entity (N : Node_Id) return Entity_Id; + -- Returns the true generic entity in an instantiation. If the name in + -- the instantiation is a renaming, the function returns the renamed + -- generic. + procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id); -- This procedure assigns to L and H respectively the values of the -- low and high bounds of node N, which must be a range, subtype @@ -439,6 +451,13 @@ package Sem_Util is -- is a variable (in the Is_Variable sense) with a non-tagged type -- target are considered view conversions and hence variables. + function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean; + -- Typ is a type entity. This function returns true if this type is + -- partly initialized, meaning that an object of the type is at least + -- partly initialized (in particular in the record case, that at least + -- one field has an initialization expression). Note that initialization + -- resulting from the use of pragma Normalized_Scalars does not count. + function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean; -- Return True if a compilation unit is the specification or the -- body of a remote call interface package. @@ -563,12 +582,17 @@ package Sem_Util is -- record type there may be several such components, we just return -- the first one. - procedure Process_End_Label (N : Node_Id; Typ : Character); + procedure Process_End_Label + (N : Node_Id; + Typ : Character; + Ent : Entity_Id); -- N is a node whose End_Label is to be processed, generating all -- appropriate cross-reference entries, and performing style checks -- for any identifier references in the end label. Typ is either -- 'e' or 't indicating the type of the cross-reference entity - -- (e for spec, t for body, see Lib.Xref spec for details). + -- (e for spec, t for body, see Lib.Xref spec for details). The + -- parameter Ent gives the entity to which the End_Label refers, + -- and to which cross-references are to be generated. function Real_Convert (S : String) return Node_Id; -- S is a possibly signed syntactically valid real literal. The result diff --git a/gcc/ada/sem_vfpt.adb b/gcc/ada/sem_vfpt.adb index d4b76d4eeef..709edfb0c36 100644 --- a/gcc/ada/sem_vfpt.adb +++ b/gcc/ada/sem_vfpt.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.10 $ +-- $Revision$ -- -- --- Copyright (C) 1997-2000, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2002, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,15 +32,9 @@ with Opt; use Opt; with Stand; use Stand; with Targparm; use Targparm; with Ttypef; use Ttypef; -with Uintp; use Uintp; - -pragma Elaborate_All (Uintp); package body Sem_VFpt is - T_Digits : constant Uint := UI_From_Int (IEEEL_Digits); - -- Digits for IEEE formats - ----------------- -- Set_D_Float -- ----------------- diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index c6107e49e9b..eb7af5d4634 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1999-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- -- @@ -120,11 +120,11 @@ package body Sem_Warn is Table_Increment => Alloc.Conditional_Stack_Increment, Table_Name => "Conditional_Stack"); - Current_Entity_List : Elist_Id := No_Elist; - -- This is a copy of the Defs list of the current branch of the current - -- conditional. It could be accessed by taking the top element of the - -- Conditional_Stack, and going to te Current_Branch entry of this - -- conditional, but we keep it precomputed for rapid access. + function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean; + -- This function traverses the expression tree represented by the node + -- N and determines if any sub-operand is a reference to an entity for + -- which the Warnings_Off flag is set. True is returned if such an + -- entity is encountered, and False otherwise. ---------------------- -- Check_References -- @@ -142,8 +142,7 @@ package body Sem_Warn is function Publicly_Referenceable (Ent : Entity_Id) return Boolean; -- This is true if the entity in question is potentially referenceable -- from another unit. This is true for entities in packages that are - -- at the library level, or for entities in tasks or protected objects - -- that are themselves publicly visible. + -- at the library level. ---------------------------- -- Output_Reference_Error -- @@ -192,32 +191,47 @@ package body Sem_Warn is ---------------------------- function Publicly_Referenceable (Ent : Entity_Id) return Boolean is - S : Entity_Id; + P : Node_Id; begin - -- Any entity in a generic package is considered to be publicly - -- referenceable, since it could be referenced in an instantiation + -- Examine parents to look for a library level package spec + -- But if we find a body or block or other similar construct + -- along the way, we cannot be referenced. - if Ekind (E) = E_Generic_Package then - return True; - end if; + P := Parent (Ent); + loop + case Nkind (P) is - -- Otherwise look up the scope stack + -- If we get to top of tree, then publicly referencable - S := Scope (Ent); - loop - if Is_Package (S) then - return Is_Library_Level_Entity (S); + when N_Empty => + return True; - elsif Ekind (S) = E_Task_Type - or else Ekind (S) = E_Protected_Type - or else Ekind (S) = E_Entry - then - S := Scope (S); + -- If we reach a generic package declaration, then always + -- consider this referenceable, since any instantiation will + -- have access to the entities in the generic package. Note + -- that the package itself may not be instantiated, but then + -- we will get a warning for the package entity - else - return False; - end if; + when N_Generic_Package_Declaration => + return True; + + -- If we reach any body, then definitely not referenceable + + when N_Package_Body | + N_Subprogram_Body | + N_Task_Body | + N_Entry_Body | + N_Protected_Body | + N_Block_Statement | + N_Subunit => + return False; + + -- For all other cases, keep looking up tree + + when others => + P := Parent (P); + end case; end loop; end Publicly_Referenceable; @@ -233,7 +247,7 @@ package body Sem_Warn is -- necessary to suppress the warnings in this case). if Warning_Mode = Suppress - or else Errors_Detected /= 0 + or else Serious_Errors_Detected /= 0 or else Unloaded_Subunits then return; @@ -340,13 +354,13 @@ package body Sem_Warn is -- Then check for unreferenced variables - if Check_Unreferenced + if not Referenced (E1) - -- Check entity is flagged as not referenced and that - -- warnings are not suppressed for this entity + -- Check that warnings on unreferenced entities are enabled - and then not Referenced (E1) - and then not Warnings_Off (E1) + and then ((Check_Unreferenced and then not Is_Formal (E1)) + or else + (Check_Unreferenced_Formals and then Is_Formal (E1))) -- Warnings are placed on objects, types, subprograms, -- labels, and enumeration literals. @@ -363,7 +377,7 @@ package body Sem_Warn is or else Is_Overloadable (E1)) - -- We only place warnings for the main unit + -- We only place warnings for the extended main unit and then In_Extended_Main_Source_Unit (E1) @@ -372,16 +386,19 @@ package body Sem_Warn is and then Instantiation_Location (Sloc (E1)) = No_Location - -- Exclude formal parameters from bodies (in the case - -- where there is a separate spec, it is the spec formals - -- that are of interest). + -- Exclude formal parameters from bodies if the corresponding + -- spec entity has been referenced in the case where there is + -- a separate spec. - and then (not Is_Formal (E1) - or else - Ekind (Scope (E1)) /= E_Subprogram_Body) + and then not (Is_Formal (E1) + and then + Ekind (Scope (E1)) = E_Subprogram_Body + and then + Present (Spec_Entity (E1)) + and then + Referenced (Spec_Entity (E1))) - -- Consider private type referenced if full view is - -- referenced. + -- Consider private type referenced if full view is referenced and then not (Is_Private_Type (E1) and then @@ -417,6 +434,13 @@ package body Sem_Warn is and then Ekind (E1) /= E_Constant and then Ekind (E1) /= E_Component) or else not Is_Task_Type (Etype (E1))) + + -- For subunits, only place warnings on the main unit + -- itself, since parent units are not completely compiled + + and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit + or else + Get_Source_Unit (E1) = Main_Unit) then -- Suppress warnings in internal units if not in -gnatg -- mode (these would be junk warnings for an applications @@ -891,6 +915,53 @@ package body Sem_Warn is end if; end Check_Unused_Withs; + ------------------------------------- + -- Operand_Has_Warnings_Suppressed -- + ------------------------------------- + + function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean is + + function Check_For_Warnings (N : Node_Id) return Traverse_Result; + -- Function used to check one node to see if it is or was originally + -- a reference to an entity for which Warnings are off. If so, Abandon + -- is returned, otherwise OK_Orig is returned to continue the traversal + -- of the original expression. + + function Traverse is new Traverse_Func (Check_For_Warnings); + -- Function used to traverse tree looking for warnings + + ------------------------ + -- Check_For_Warnings -- + ------------------------ + + function Check_For_Warnings (N : Node_Id) return Traverse_Result is + R : constant Node_Id := Original_Node (N); + + begin + if Nkind (R) in N_Has_Entity + and then Present (Entity (R)) + and then Warnings_Off (Entity (R)) + then + return Abandon; + else + return OK_Orig; + end if; + end Check_For_Warnings; + + -- Start of processing for Operand_Has_Warnings_Suppressed + + begin + return Traverse (N) = Abandon; + + -- If any exception occurs, then something has gone wrong, and this is + -- only a minor aesthetic issue anyway, so just say we did not find what + -- we are looking for, rather than blow up. + + exception + when others => + return False; + end Operand_Has_Warnings_Suppressed; + ---------------------------------- -- Output_Unreferenced_Messages -- ---------------------------------- @@ -1017,10 +1088,15 @@ package body Sem_Warn is P := Parent (P); end loop; - if Entity (C) = Standard_True then - Error_Msg_N ("condition is always True?", C); - else - Error_Msg_N ("condition is always False?", C); + -- Here we issue the warning unless some sub-operand has warnings + -- set off, in which case we suppress the warning for the node. + + if not Operand_Has_Warnings_Suppressed (C) then + if Entity (C) = Standard_True then + Error_Msg_N ("condition is always True?", C); + else + Error_Msg_N ("condition is always False?", C); + end if; end if; end if; end Warn_On_Known_Condition; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index e3bda4bd4ea..6edfefede5a 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -898,6 +898,7 @@ package body Sinfo is (N : Node_Id) return Node_Id is begin pragma Assert (False + or else NT (N).Nkind = N_Enumeration_Type_Definition or else NT (N).Nkind = N_Handled_Sequence_Of_Statements or else NT (N).Nkind = N_Loop_Statement or else NT (N).Nkind = N_Package_Specification @@ -1619,6 +1620,14 @@ package body Sinfo is return Flag5 (N); end More_Ids; + function Must_Be_Byte_Aligned + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Reference); + return Flag14 (N); + end Must_Be_Byte_Aligned; + function Must_Not_Freeze (N : Node_Id) return Boolean is begin @@ -2032,6 +2041,16 @@ package body Sinfo is return Ureal3 (N); end Realval; + function Reason + (N : Node_Id) return Uint is + begin + pragma Assert (False + or else NT (N).Nkind = N_Raise_Constraint_Error + or else NT (N).Nkind = N_Raise_Program_Error + or else NT (N).Nkind = N_Raise_Storage_Error); + return Uint3 (N); + end Reason; + function Record_Extension_Part (N : Node_Id) return Node_Id is begin @@ -3253,6 +3272,7 @@ package body Sinfo is (N : Node_Id; Val : Node_Id) is begin pragma Assert (False + or else NT (N).Nkind = N_Enumeration_Type_Definition or else NT (N).Nkind = N_Handled_Sequence_Of_Statements or else NT (N).Nkind = N_Loop_Statement or else NT (N).Nkind = N_Package_Specification @@ -3974,6 +3994,14 @@ package body Sinfo is Set_Flag5 (N, Val); end Set_More_Ids; + procedure Set_Must_Be_Byte_Aligned + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Reference); + Set_Flag14 (N, Val); + end Set_Must_Be_Byte_Aligned; + procedure Set_Must_Not_Freeze (N : Node_Id; Val : Boolean := True) is begin @@ -4387,6 +4415,16 @@ package body Sinfo is Set_Ureal3 (N, Val); end Set_Realval; + procedure Set_Reason + (N : Node_Id; Val : Uint) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Raise_Constraint_Error + or else NT (N).Nkind = N_Raise_Program_Error + or else NT (N).Nkind = N_Raise_Storage_Error); + Set_Uint3 (N, Val); + end Set_Reason; + procedure Set_Record_Extension_Part (N : Node_Id; Val : Node_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index ba58c82f45f..d2fac335c45 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.5 $ +-- $Revision: 1.439 $ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -386,7 +386,7 @@ package Sinfo is -- In the following node definitions, all fields, both syntactic and -- semantic, are documented. The one exception is in the case of entities - -- (defining identifiers, character literals and operator symbols), + -- (defining indentifiers, character literals and operator symbols), -- where the usage of the fields depends on the entity kind. Entity -- fields are fully documented in the separate package Einfo. @@ -551,9 +551,9 @@ package Sinfo is -- All_Others (Flag11-Sem) -- Present in an N_Others_Choice node. This flag is set in the case - -- of an others exception where all exceptions, even those that are - -- not normally handled (in particular the tasking abort signal) by - -- others. This is used for translation of the at end handler into + -- of an others exception where all exceptions are to be caught, even + -- those that are not normally handled (in particular the tasking abort + -- signal). This is used for translation of the at end handler into -- a normal exception handler. -- Assignment_OK (Flag15-Sem) @@ -1180,6 +1180,16 @@ package Sinfo is -- Used to collect actions that must be executed within the loop because -- they may need to be evaluated anew each time through. + -- Must_Be_Byte_Aligned (Flag14-Sem) + -- This flag is present in N_Attribute_Reference nodes. It can be set + -- only for the Address and Unrestricted_Access attributes. If set it + -- means that the object for which the address/access is given must be + -- on a byte (more accurately a storage unit) boundary. If necessary, + -- a copy of the object is to be made before taking the address (this + -- copy is in the current scope on the stack frame). This is used for + -- certainly cases of code generated by the expander that passes + -- parameters by address. + -- Must_Not_Freeze (Flag8-Sem) -- A flag present in all expression nodes. Normally expressions cause -- freezing as described in the RM. If this flag is set, then this @@ -1475,6 +1485,7 @@ package Sinfo is -- Case Statement end case; -- Record Definition end record; + -- Enumeration Definition ); -- The End_Label and End_Span fields are used to mark the locations -- of these lines, and also keep track of the label in the case where @@ -1506,6 +1517,9 @@ package Sinfo is -- entry for the end of a record, since it represents a scope for -- name declaration purposes. + -- The enumeration definition case is handled in an exactly similar + -- manner, building a dummy identifier to get a cross-reference. + -- Note: the reason we store the difference as a Uint, instead of -- storing the Source_Ptr value directly, is that Source_Ptr values -- cannot be distinguished from other types of values, and we count @@ -2007,6 +2021,7 @@ package Sinfo is -- N_Enumeration_Type_Definition -- Sloc points to left parenthesis -- Literals (List1) (Empty for CHARACTER or WIDE_CHARACTER) + -- End_Label (Node4) (set to Empty if internally generated record) ---------------------------------------------- -- 3.5.1 Enumeration Literal Specification -- @@ -2802,6 +2817,15 @@ package Sinfo is -- a non-standard enumeration type or a nonzero/zero semantics -- boolean type, so the value is simply the stored representation. + -- Note: In generated code, the Address and Unrestricted_Access + -- attributes can be applied to any expression, and the meaning is + -- to create an object containing the value (the object is in the + -- current stack frame), and pass the address of this value. If the + -- Must_Be_Byte_Aligned flag is set, then the object whose address + -- is taken must be on a byte (storage unit) boundary, and if it is + -- not (or may not be), then the generated code must create a copy + -- that is byte aligned, and pass the address of this copy. + -- N_Attribute_Reference -- Sloc points to apostrophe -- Prefix (Node3) @@ -2813,6 +2837,7 @@ package Sinfo is -- Do_Overflow_Check (Flag17-Sem) -- Redundant_Use (Flag13-Sem) -- OK_For_Stream (Flag4-Sem) + -- Must_Be_Byte_Aligned (Flag14) -- plus fields for expression --------------------------------- @@ -3456,7 +3481,7 @@ package Sinfo is -- 5.1 Statement Identifier -- ------------------------------- - -- STATEMENT_IDENTIFIER ::= DIRECT_NAME + -- STATEMENT_INDENTIFIER ::= DIRECT_NAME -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier -- (not an OPERATOR_SYMBOL) @@ -6063,33 +6088,42 @@ package Sinfo is -- circuit form whose left argument is static and decisively -- eliminates elaboration of the raise operation. + -- The exception is generated with a message that contains the + -- file name and line number, and then appended text. The Reason + -- code shows the text to be added. The Reason code is an element + -- of the type Types.RT_Exception_Code, and indicates both the + -- message to be added, and the exception to be raised (which must + -- match the node type). The value is stored by storing a Uint which + -- is the Pos value of the enumeration element in this type. + -- Gigi restriction: This expander ensures that the type of the -- Condition field is always Standard.Boolean, even if the type -- in the source is some non-standard boolean type. - -- Sprint syntax: [xxx_error] - -- or: [xxx_error when condition] + -- Sprint syntax: [xxx_error "msg"] + -- or: [xxx_error when condition "msg"] -- N_Raise_Constraint_Error -- Sloc references related construct -- Condition (Node1) (set to Empty if no condition) - -- Sloc is copied from the expression generating the exception + -- Reason (Uint3) -- plus fields for expression -- N_Raise_Program_Error -- Sloc references related construct -- Condition (Node1) (set to Empty if no condition) - -- Sloc is copied from the construct generating the exception + -- Reason (Uint3) -- plus fields for expression -- N_Raise_Storage_Error -- Sloc references related construct -- Condition (Node1) (set to Empty if no condition) - -- Sloc is copied from the construct generating the exception + -- Reason (Uint3) -- plus fields for expression - -- Note: in the case where a debug source file is generated, the Sloc - -- for this node points to the left bracket in the Sprint file output. + -- Note: Sloc is copied from the expression generating the exception. + -- In the case where a debug source file is generated, the Sloc for + -- this node points to the left bracket in the Sprint file output. --------------- -- Reference -- @@ -7205,6 +7239,9 @@ package Sinfo is function More_Ids (N : Node_Id) return Boolean; -- Flag5 + function Must_Be_Byte_Aligned + (N : Node_Id) return Boolean; -- Flag14 + function Must_Not_Freeze (N : Node_Id) return Boolean; -- Flag8 @@ -7328,6 +7365,9 @@ package Sinfo is function Realval (N : Node_Id) return Ureal; -- Ureal3 + function Reason + (N : Node_Id) return Uint; -- Uint3 + function Record_Extension_Part (N : Node_Id) return Node_Id; -- Node3 @@ -7955,6 +7995,9 @@ package Sinfo is procedure Set_More_Ids (N : Node_Id; Val : Boolean := True); -- Flag5 + procedure Set_Must_Be_Byte_Aligned + (N : Node_Id; Val : Boolean := True); -- Flag14 + procedure Set_Must_Not_Freeze (N : Node_Id; Val : Boolean := True); -- Flag8 @@ -8078,6 +8121,9 @@ package Sinfo is procedure Set_Realval (N : Node_Id; Val : Ureal); -- Ureal3 + procedure Set_Reason + (N : Node_Id; Val : Uint); -- Uint3 + procedure Set_Record_Extension_Part (N : Node_Id; Val : Node_Id); -- Node3 @@ -8391,6 +8437,7 @@ package Sinfo is pragma Inline (Low_Bound); pragma Inline (Mod_Clause); pragma Inline (More_Ids); + pragma Inline (Must_Be_Byte_Aligned); pragma Inline (Must_Not_Freeze); pragma Inline (Name); pragma Inline (Names); @@ -8430,8 +8477,9 @@ package Sinfo is pragma Inline (Raises_Constraint_Error); pragma Inline (Range_Constraint); pragma Inline (Range_Expression); - pragma Inline (Realval); pragma Inline (Real_Range_Specification); + pragma Inline (Realval); + pragma Inline (Reason); pragma Inline (Record_Extension_Part); pragma Inline (Redundant_Use); pragma Inline (Return_Type); @@ -8638,6 +8686,7 @@ package Sinfo is pragma Inline (Set_Low_Bound); pragma Inline (Set_Mod_Clause); pragma Inline (Set_More_Ids); + pragma Inline (Set_Must_Be_Byte_Aligned); pragma Inline (Set_Must_Not_Freeze); pragma Inline (Set_Name); pragma Inline (Set_Names); @@ -8676,8 +8725,9 @@ package Sinfo is pragma Inline (Set_Raises_Constraint_Error); pragma Inline (Set_Range_Constraint); pragma Inline (Set_Range_Expression); - pragma Inline (Set_Realval); pragma Inline (Set_Real_Range_Specification); + pragma Inline (Set_Realval); + pragma Inline (Set_Reason); pragma Inline (Set_Record_Extension_Part); pragma Inline (Set_Redundant_Use); pragma Inline (Set_Return_Type); diff --git a/gcc/ada/sinfo.h b/gcc/ada/sinfo.h index 424af525f27..aab0964204c 100644 --- a/gcc/ada/sinfo.h +++ b/gcc/ada/sinfo.h @@ -6,10 +6,10 @@ /* */ /* C Header File */ /* */ -/* Generated by xsinfo revision 1.1 using */ -/* sinfo.ads revision 1.6 */ +/* Generated by xsinfo revision using */ +/* sinfo.ads revision 1.439 */ /* */ -/* Copyright (C) 1992-2001, 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- */ @@ -661,6 +661,8 @@ { return Node2 (N); } INLINE Boolean More_Ids (Node_Id N) { return Flag5 (N); } + INLINE Boolean Must_Be_Byte_Aligned (Node_Id N) + { return Flag14 (N); } INLINE Boolean Must_Not_Freeze (Node_Id N) { return Flag8 (N); } INLINE Node_Id Name (Node_Id N) @@ -743,6 +745,8 @@ { return Node4 (N); } INLINE Ureal Realval (Node_Id N) { return Ureal3 (N); } + INLINE Uint Reason (Node_Id N) + { return Uint3 (N); } INLINE Node_Id Record_Extension_Part (Node_Id N) { return Node3 (N); } INLINE Boolean Redundant_Use (Node_Id N) diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb index f00cbbd26dc..8b0791c1047 100644 --- a/gcc/ada/sinput-l.adb +++ b/gcc/ada/sinput-l.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.40 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -27,34 +27,29 @@ ------------------------------------------------------------------------------ with Alloc; -with Atree; use Atree; -with Debug; use Debug; -with Einfo; use Einfo; -with Namet; use Namet; +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Namet; use Namet; with Opt; -with Osint; use Osint; -with Output; use Output; -with Scans; use Scans; -with Scn; use Scn; -with Sinfo; use Sinfo; -with System; use System; +with Osint; use Osint; +with Output; use Output; +with Scans; use Scans; +with Scn; use Scn; +with Sinfo; use Sinfo; +with System; use System; with Unchecked_Conversion; package body Sinput.L is - Dfile : Source_File_Index; - -- Index of currently active debug source file + -- Routines to support conversion between types Lines_Table_Ptr + -- and System.Address. ----------------- -- Subprograms -- ----------------- - procedure Trim_Lines_Table (S : Source_File_Index); - -- Set lines table size for entry S in the source file table to - -- correspond to the current value of Num_Source_Lines, releasing - -- any unused storage. - function Load_File (N : File_Name_Type; T : File_Type) @@ -79,26 +74,6 @@ package body Sinput.L is end if; end Adjust_Instantiation_Sloc; - ------------------------ - -- Close_Debug_Source -- - ------------------------ - - procedure Close_Debug_Source is - S : Source_File_Record renames Source_File.Table (Dfile); - Src : Source_Buffer_Ptr; - - begin - Trim_Lines_Table (Dfile); - Close_Debug_File; - - -- Now we need to read the file that we wrote and store it - -- in memory for subsequent access. - - Read_Source_File - (S.Debug_Source_Name, S.Source_First, S.Source_Last, Src); - S.Source_Text := Src; - end Close_Debug_Source; - -------------------------------- -- Complete_Source_File_Entry -- -------------------------------- @@ -111,49 +86,6 @@ package body Sinput.L is Source_File.Table (CSF).Source_Checksum := Checksum; end Complete_Source_File_Entry; - ------------------------- - -- Create_Debug_Source -- - ------------------------- - - procedure Create_Debug_Source - (Source : Source_File_Index; - Loc : out Source_Ptr) - is - begin - Loc := Source_File.Table (Source_File.Last).Source_Last + 1; - Source_File.Increment_Last; - Dfile := Source_File.Last; - - declare - S : Source_File_Record renames Source_File.Table (Dfile); - - begin - S := Source_File.Table (Source); - S.Debug_Source_Name := Create_Debug_File (S.File_Name); - S.Source_First := Loc; - S.Source_Last := Loc; - S.Lines_Table := null; - S.Last_Source_Line := 1; - - -- Allocate lines table, guess that it needs to be three times - -- bigger than the original source (in number of lines). - - Alloc_Line_Tables - (S, Int (Source_File.Table (Source).Last_Source_Line * 3)); - S.Lines_Table (1) := Loc; - end; - - if Debug_Flag_GG then - Write_Str ("---> Create_Debug_Source (Source => "); - Write_Int (Int (Source)); - Write_Str (", Loc => "); - Write_Int (Int (Loc)); - Write_Str (");"); - Write_Eol; - end if; - - end Create_Debug_Source; - --------------------------------- -- Create_Instantiation_Source -- --------------------------------- @@ -468,66 +400,4 @@ package body Sinput.L is return Token = Tok_Separate; end Source_File_Is_Subunit; - ---------------------- - -- Trim_Lines_Table -- - ---------------------- - - procedure Trim_Lines_Table (S : Source_File_Index) is - - function realloc - (P : Lines_Table_Ptr; - New_Size : Int) - return Lines_Table_Ptr; - pragma Import (C, realloc); - - Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line); - - begin - -- Release allocated storage that is no longer needed - - Source_File.Table (S).Lines_Table := - realloc - (Source_File.Table (S).Lines_Table, - Max * (Lines_Table_Type'Component_Size / System.Storage_Unit)); - Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max); - end Trim_Lines_Table; - - ---------------------- - -- Write_Debug_Line -- - ---------------------- - - procedure Write_Debug_Line (Str : String; Loc : in out Source_Ptr) is - S : Source_File_Record renames Source_File.Table (Dfile); - - begin - -- Ignore write request if null line at start of file - - if Str'Length = 0 and then Loc = S.Source_First then - return; - - -- Here we write the line, and update the source record entry - - else - Write_Debug_Info (Str); - Add_Line_Tables_Entry (S, Loc); - Loc := Loc + Source_Ptr (Str'Length + Debug_File_Eol_Length); - S.Source_Last := Loc; - - if Debug_Flag_GG then - declare - Lin : constant String := Str; - - begin - Column := 1; - Write_Str ("---> Write_Debug_Line (Str => """); - Write_Str (Lin); - Write_Str (""", Loc => "); - Write_Int (Int (Loc)); - Write_Str (");"); - Write_Eol; - end; - end if; - end if; - end Write_Debug_Line; - end Sinput.L; diff --git a/gcc/ada/sinput-l.ads b/gcc/ada/sinput-l.ads index bba983fd00b..eaa27462fe0 100644 --- a/gcc/ada/sinput-l.ads +++ b/gcc/ada/sinput-l.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.14 $ -- +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- @@ -90,34 +90,6 @@ package Sinput.L is -- Adjust_Instantiation_Sloc to each copied node to adjust the Sloc -- to reference the source entry for the instantiation. - ------------------------------------------------ - -- Subprograms for Writing Debug Source Files -- - ------------------------------------------------ - - procedure Create_Debug_Source - (Source : Source_File_Index; - Loc : out Source_Ptr); - -- Given a source file, creates a new source file table entry to be used - -- for the debug source file output (Debug_Generated_Code switch set). - -- Loc is set to the initial Sloc value for the first line. This call - -- also creates the debug source output file (using Create_Debug_File). - - procedure Write_Debug_Line (Str : String; Loc : in out Source_Ptr); - -- This procedure is called to write a line to the debug source file - -- previously created by Create_Debug_Source using Write_Debug_Info. - -- Str is the source line to be written to the file (it does not include - -- an end of line character). On entry Loc is the Sloc value previously - -- returned by Create_Debug_Source or Write_Debug_Line, and on exit, - -- Sloc is updated to point to the start of the next line to be written, - -- taking into account the length of the ternminator that was written by - -- Write_Debug_Info. - - procedure Close_Debug_Source; - -- This procedure completes the source table entry for the debug file - -- previously created by Create_Debug_Source, and written using the - -- Write_Debug_Line procedure. It then calls Close_Debug_File to - -- complete the writing of the file itself. - private type Sloc_Adjustment is record diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index b8612882550..b2b36a4cea8 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.99 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -43,6 +43,8 @@ with Output; use Output; with Tree_IO; use Tree_IO; with System; use System; +with System.Memory; + with Unchecked_Conversion; with Unchecked_Deallocation; @@ -53,6 +55,21 @@ package body Sinput is First_Time_Around : Boolean := True; + -- Routines to support conversion between types Lines_Table_Ptr, + -- Logical_Lines_Table_Ptr and System.Address. + + function To_Address is + new Unchecked_Conversion (Lines_Table_Ptr, Address); + + function To_Address is + new Unchecked_Conversion (Logical_Lines_Table_Ptr, Address); + + function To_Pointer is + new Unchecked_Conversion (Address, Lines_Table_Ptr); + + function To_Pointer is + new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr); + --------------------------- -- Add_Line_Tables_Entry -- --------------------------- @@ -111,27 +128,7 @@ package body Sinput is (S : in out Source_File_Record; New_Max : Nat) is - function realloc - (memblock : Lines_Table_Ptr; - size : size_t) - return Lines_Table_Ptr; - pragma Import (C, realloc, "realloc"); - - function reallocl - (memblock : Logical_Lines_Table_Ptr; - size : size_t) - return Logical_Lines_Table_Ptr; - pragma Import (C, reallocl, "realloc"); - - function malloc - (size : size_t) - return Lines_Table_Ptr; - pragma Import (C, malloc, "malloc"); - - function mallocl - (size : size_t) - return Logical_Lines_Table_Ptr; - pragma Import (C, mallocl, "malloc"); + subtype size_t is Memory.size_t; New_Table : Lines_Table_Ptr; @@ -143,11 +140,11 @@ package body Sinput is begin if S.Lines_Table = null then - New_Table := malloc (New_Size); + New_Table := To_Pointer (Memory.Alloc (New_Size)); else New_Table := - realloc (memblock => S.Lines_Table, size => New_Size); + To_Pointer (Memory.Realloc (To_Address (S.Lines_Table), New_Size)); end if; if New_Table = null then @@ -159,10 +156,10 @@ package body Sinput is if S.Num_SRef_Pragmas /= 0 then if S.Logical_Lines_Table = null then - New_Logical_Table := mallocl (New_Size); + New_Logical_Table := To_Pointer (Memory.Alloc (New_Size)); else - New_Logical_Table := - reallocl (memblock => S.Logical_Lines_Table, size => New_Size); + New_Logical_Table := To_Pointer + (Memory.Realloc (To_Address (S.Logical_Lines_Table), New_Size)); end if; if New_Logical_Table = null then @@ -570,12 +567,9 @@ package body Sinput is Mapped_Line : Nat; Line_After_Pragma : Physical_Line_Number) is - SFR : Source_File_Record renames Source_File.Table (Current_Source_File); + subtype size_t is Memory.size_t; - function malloc - (size : size_t) - return Logical_Lines_Table_Ptr; - pragma Import (C, malloc); + SFR : Source_File_Record renames Source_File.Table (Current_Source_File); ML : Logical_Line_Number; @@ -596,11 +590,11 @@ package body Sinput is end if; if SFR.Logical_Lines_Table = null then - SFR.Logical_Lines_Table := - malloc + SFR.Logical_Lines_Table := To_Pointer + (Memory.Alloc (size_t (SFR.Lines_Table_Max * Logical_Lines_Table_Type'Component_Size / - Storage_Unit)); + Storage_Unit))); end if; SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number; @@ -738,16 +732,6 @@ package body Sinput is procedure Free_Ptr is new Unchecked_Deallocation (Big_Source_Buffer, Source_Buffer_Ptr); - -- Note: we are using free here, because we used malloc - -- or realloc directly to allocate the tables. That is - -- because we were playing the big array trick. - - procedure free (X : Lines_Table_Ptr); - pragma Import (C, free, "free"); - - procedure freel (X : Logical_Lines_Table_Ptr); - pragma Import (C, freel, "free"); - function To_Source_Buffer_Ptr is new Unchecked_Conversion (Address, Source_Buffer_Ptr); @@ -766,13 +750,17 @@ package body Sinput is (S.Source_Text (S.Source_First)'Address); Free_Ptr (Tmp1); + -- Note: we are using free here, because we used malloc + -- or realloc directly to allocate the tables. That is + -- because we were playing the big array trick. + if S.Lines_Table /= null then - free (S.Lines_Table); + Memory.Free (To_Address (S.Lines_Table)); S.Lines_Table := null; end if; if S.Logical_Lines_Table /= null then - freel (S.Logical_Lines_Table); + Memory.Free (To_Address (S.Logical_Lines_Table)); S.Logical_Lines_Table := null; end if; end if; @@ -1119,6 +1107,24 @@ package body Sinput is Source_File.Table (S).License := L; end Set_License; + ---------------------- + -- Trim_Lines_Table -- + ---------------------- + + procedure Trim_Lines_Table (S : Source_File_Index) is + Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line); + + begin + -- Release allocated storage that is no longer needed + + Source_File.Table (S).Lines_Table := To_Pointer + (Memory.Realloc + (To_Address (Source_File.Table (S).Lines_Table), + Memory.size_t + (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit)))); + Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max); + end Trim_Lines_Table; + -------- -- wl -- -------- diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index 13e0c322018..307b8d296c6 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -489,6 +489,7 @@ package Sinput is -- is why the somewhat cryptic use of brackets is acceptable). procedure wl (P : Source_Ptr); + pragma Export (Ada, wl); -- Equivalent to Write_Location (P); Write_Eol; for calls from GDB procedure Write_Time_Stamp (S : Source_File_Index); @@ -631,4 +632,9 @@ private -- present, also increments logical lines table size by one, and -- sets new entry. + procedure Trim_Lines_Table (S : Source_File_Index); + -- Set lines table size for entry S in the source file table to + -- correspond to the current value of Num_Source_Lines, releasing + -- any unused storage. This is used by Sinput.L and Sinput.D. + end Sinput; diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index 5ffb23d9922..b8d24dbf3de 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- -- --- Copyright (C) 1992-2001, 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- -- @@ -34,9 +34,25 @@ ------------------------------------------------------------------------------ with Namet; use Namet; +with Table; package body Snames is + -- Table used to record convention identifiers + + type Convention_Id_Entry is record + Name : Name_Id; + Convention : Convention_Id; + end record; + + package Convention_Identifiers is new Table.Table ( + Table_Component_Type => Convention_Id_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 200, + Table_Name => "Name_Convention_Identifiers"); + -- Table of names to be set by Initialize. Each name is terminated by a -- single #, and the end of the list is marked by a null entry, i.e. by -- two # marks in succession. Note that the table does not include the @@ -149,6 +165,7 @@ package body Snames is "ada_95#" & "c_pass_by_copy#" & "component_alignment#" & + "convention_identifier#" & "discard_names#" & "elaboration_checks#" & "eliminate#" & @@ -261,21 +278,25 @@ package body Snames is "title#" & "unchecked_union#" & "unimplemented_unit#" & + "universal_data#" & + "unreferenced#" & "unreserve_all_interrupts#" & "volatile#" & "volatile_components#" & "weak_external#" & "ada#" & - "asm#" & "assembler#" & "cobol#" & "cpp#" & - "dll#" & "fortran#" & "intrinsic#" & "java#" & "stdcall#" & "stubbed#" & + "asm#" & + "assembly#" & + "default#" & + "dll#" & "win32#" & "as_is#" & "body_file_name#" & @@ -286,7 +307,6 @@ package body Snames is "copy#" & "d_float#" & "descriptor#" & - "default#" & "dot_replacement#" & "dynamic#" & "entity#" & @@ -298,6 +318,7 @@ package body Snames is "gnat#" & "gpl#" & "ieee_float#" & + "homonym_number#" & "internal#" & "link_name#" & "lowercase#" & @@ -387,8 +408,6 @@ package body Snames is "machine_rounds#" & "machine_size#" & "mantissa#" & - "max_interrupt_priority#" & - "max_priority#" & "max_size_in_storage_elements#" & "maximum_alignment#" & "mechanism_code#" & @@ -420,7 +439,6 @@ package body Snames is "storage_unit#" & "tag#" & "terminated#" & - "tick#" & "to_address#" & "type_class#" & "uet_address#" & @@ -641,7 +659,7 @@ package body Snames is -- TxxxT type of literal table for enumeration type xxx (Sem_Ch3) - -- (list not yet complete ???) + -- (Note: this list is not complete or accurate ???) ---------------------- -- Get_Attribute_Id -- @@ -669,19 +687,23 @@ package body Snames is begin case N is when Name_Ada => return Convention_Ada; - when Name_Asm => return Convention_Assembler; when Name_Assembler => return Convention_Assembler; when Name_C => return Convention_C; when Name_COBOL => return Convention_COBOL; when Name_CPP => return Convention_CPP; - when Name_DLL => return Convention_Stdcall; when Name_Fortran => return Convention_Fortran; when Name_Intrinsic => return Convention_Intrinsic; when Name_Java => return Convention_Java; when Name_Stdcall => return Convention_Stdcall; when Name_Stubbed => return Convention_Stubbed; - when Name_Win32 => return Convention_Stdcall; + when others => + for J in 1 .. Convention_Identifiers.Last loop + if N = Convention_Identifiers.Table (J).Name then + return Convention_Identifiers.Table (J).Convention; + end if; + end loop; + raise Program_Error; end case; end Get_Convention_Id; @@ -767,6 +789,20 @@ package body Snames is -- properly matching version of the body. pragma Assert (Discard_Name = Last_Predefined_Name); + + -- Initialize the convention identifiers table with the standard + -- set of synonyms that we recognize for conventions. + + Convention_Identifiers.Init; + + Convention_Identifiers.Append ((Name_Asm, Convention_Assembler)); + Convention_Identifiers.Append ((Name_Assembly, Convention_Assembler)); + + Convention_Identifiers.Append ((Name_Default, Convention_C)); + Convention_Identifiers.Append ((Name_External, Convention_C)); + + Convention_Identifiers.Append ((Name_DLL, Convention_Stdcall)); + Convention_Identifiers.Append ((Name_Win32, Convention_Stdcall)); end Initialize; ----------------------- @@ -793,8 +829,20 @@ package body Snames is function Is_Convention_Name (N : Name_Id) return Boolean is begin - return N in First_Convention_Name .. Last_Convention_Name - or else N = Name_C; + if N in First_Convention_Name .. Last_Convention_Name + or else N = Name_C + then + return True; + + else + for J in 1 .. Convention_Identifiers.Last loop + if N = Convention_Identifiers.Table (J).Name then + return True; + end if; + end loop; + + return False; + end if; end Is_Convention_Name; ------------------------------ @@ -884,4 +932,16 @@ package body Snames is return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name; end Is_Type_Attribute_Name; + ---------------------------------- + -- Record_Convention_Identifier -- + ---------------------------------- + + procedure Record_Convention_Identifier + (Id : Name_Id; + Convention : Convention_Id) + is + begin + Convention_Identifiers.Append ((Id, Convention)); + end Record_Convention_Identifier; + end Snames; diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index f1e29eab175..86f6b3cf035 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -42,7 +42,7 @@ package Snames is -- the definitions of some enumeration types whose definitions are tied to -- the order of these preset names. --- WARNING: There is a C file, a-snames-h which duplicates some of the +-- WARNING: There is a C file, a-snames.h which duplicates some of the -- definitions in this file and must be kept properly synchronized. ------------------ @@ -62,9 +62,9 @@ package Snames is -- everything is simpler if no such duplications occur! -- First we have the one character names used to optimize the lookup - -- process for one character identifiers (avoid the hashing in this case) - -- There are a full 256 of these, but only the entries for lower case - -- and upper case letters have identifiers + -- process for one character identifiers (to avoid the hashing in this + -- case) There are a full 256 of these, but only the entries for lower + -- case and upper case letters have identifiers -- The lower case letter entries are used for one character identifiers -- appearing in the source, for example in pragma Interface (C). @@ -300,6 +300,10 @@ package Snames is -- only in OpenVMS versions of GNAT. They are ignored in other versions -- with an appropriate warning. + -- The entries marked AAMP are AAMP specific pragmas that are recognized + -- only in GNAT for the AAMP. They are ignored in other versions with + -- appropriate warnings. + First_Pragma_Name : constant Name_Id := N + 102; -- Configuration pragmas are grouped at start @@ -308,41 +312,42 @@ package Snames is Name_Ada_95 : constant Name_Id := N + 103; -- GNAT Name_C_Pass_By_Copy : constant Name_Id := N + 104; -- GNAT Name_Component_Alignment : constant Name_Id := N + 105; -- GNAT - Name_Discard_Names : constant Name_Id := N + 106; - Name_Elaboration_Checks : constant Name_Id := N + 107; -- GNAT - Name_Eliminate : constant Name_Id := N + 108; -- GNAT - Name_Extend_System : constant Name_Id := N + 109; -- GNAT - Name_Extensions_Allowed : constant Name_Id := N + 110; -- GNAT - Name_External_Name_Casing : constant Name_Id := N + 111; -- GNAT - Name_Float_Representation : constant Name_Id := N + 112; -- GNAT - Name_Initialize_Scalars : constant Name_Id := N + 113; -- GNAT - Name_License : constant Name_Id := N + 114; -- GNAT - Name_Locking_Policy : constant Name_Id := N + 115; - Name_Long_Float : constant Name_Id := N + 116; -- VMS - Name_No_Run_Time : constant Name_Id := N + 117; -- GNAT - Name_Normalize_Scalars : constant Name_Id := N + 118; - Name_Polling : constant Name_Id := N + 119; -- GNAT - Name_Propagate_Exceptions : constant Name_Id := N + 120; -- GNAT - Name_Queuing_Policy : constant Name_Id := N + 121; - Name_Ravenscar : constant Name_Id := N + 122; - Name_Restricted_Run_Time : constant Name_Id := N + 123; - Name_Restrictions : constant Name_Id := N + 124; - Name_Reviewable : constant Name_Id := N + 125; - Name_Source_File_Name : constant Name_Id := N + 126; -- GNAT - Name_Style_Checks : constant Name_Id := N + 127; -- GNAT - Name_Suppress : constant Name_Id := N + 128; - Name_Task_Dispatching_Policy : constant Name_Id := N + 129; - Name_Unsuppress : constant Name_Id := N + 130; -- GNAT - Name_Use_VADS_Size : constant Name_Id := N + 131; -- GNAT - Name_Warnings : constant Name_Id := N + 132; -- GNAT - Name_Validity_Checks : constant Name_Id := N + 133; -- GNAT - Last_Configuration_Pragma_Name : constant Name_Id := N + 133; + Name_Convention_Identifier : constant Name_Id := N + 106; -- GNAT + Name_Discard_Names : constant Name_Id := N + 107; + Name_Elaboration_Checks : constant Name_Id := N + 108; -- GNAT + Name_Eliminate : constant Name_Id := N + 109; -- GNAT + Name_Extend_System : constant Name_Id := N + 110; -- GNAT + Name_Extensions_Allowed : constant Name_Id := N + 111; -- GNAT + Name_External_Name_Casing : constant Name_Id := N + 112; -- GNAT + Name_Float_Representation : constant Name_Id := N + 113; -- GNAT + Name_Initialize_Scalars : constant Name_Id := N + 114; -- GNAT + Name_License : constant Name_Id := N + 115; -- GNAT + Name_Locking_Policy : constant Name_Id := N + 116; + Name_Long_Float : constant Name_Id := N + 117; -- VMS + Name_No_Run_Time : constant Name_Id := N + 118; -- GNAT + Name_Normalize_Scalars : constant Name_Id := N + 119; + Name_Polling : constant Name_Id := N + 120; -- GNAT + Name_Propagate_Exceptions : constant Name_Id := N + 121; -- GNAT + Name_Queuing_Policy : constant Name_Id := N + 122; + Name_Ravenscar : constant Name_Id := N + 123; + Name_Restricted_Run_Time : constant Name_Id := N + 124; + Name_Restrictions : constant Name_Id := N + 125; + Name_Reviewable : constant Name_Id := N + 126; + Name_Source_File_Name : constant Name_Id := N + 127; -- GNAT + Name_Style_Checks : constant Name_Id := N + 128; -- GNAT + Name_Suppress : constant Name_Id := N + 129; + Name_Task_Dispatching_Policy : constant Name_Id := N + 130; + Name_Unsuppress : constant Name_Id := N + 131; -- GNAT + Name_Use_VADS_Size : constant Name_Id := N + 132; -- GNAT + Name_Warnings : constant Name_Id := N + 133; -- GNAT + Name_Validity_Checks : constant Name_Id := N + 134; -- GNAT + Last_Configuration_Pragma_Name : constant Name_Id := N + 134; -- Remaining pragma names - Name_Abort_Defer : constant Name_Id := N + 134; -- GNAT - Name_All_Calls_Remote : constant Name_Id := N + 135; - Name_Annotate : constant Name_Id := N + 136; -- GNAT + Name_Abort_Defer : constant Name_Id := N + 135; -- GNAT + Name_All_Calls_Remote : constant Name_Id := N + 136; + Name_Annotate : constant Name_Id := N + 137; -- GNAT -- Note: AST_Entry is not in this list because its name matches the -- name of the corresponding attribute. However, it is included in the @@ -350,73 +355,73 @@ package Snames is -- and Check_Pragma_Id correctly recognize and process Name_AST_Entry. -- AST_Entry is a VMS specific pragma. - Name_Assert : constant Name_Id := N + 137; -- GNAT - Name_Asynchronous : constant Name_Id := N + 138; - Name_Atomic : constant Name_Id := N + 139; - Name_Atomic_Components : constant Name_Id := N + 140; - Name_Attach_Handler : constant Name_Id := N + 141; - Name_Comment : constant Name_Id := N + 142; -- GNAT - Name_Common_Object : constant Name_Id := N + 143; -- GNAT - Name_Complex_Representation : constant Name_Id := N + 144; -- GNAT - Name_Controlled : constant Name_Id := N + 145; - Name_Convention : constant Name_Id := N + 146; - Name_CPP_Class : constant Name_Id := N + 147; -- GNAT - Name_CPP_Constructor : constant Name_Id := N + 148; -- GNAT - Name_CPP_Virtual : constant Name_Id := N + 149; -- GNAT - Name_CPP_Vtable : constant Name_Id := N + 150; -- GNAT - Name_Debug : constant Name_Id := N + 151; -- GNAT - Name_Elaborate : constant Name_Id := N + 152; -- Ada 83 - Name_Elaborate_All : constant Name_Id := N + 153; - Name_Elaborate_Body : constant Name_Id := N + 154; - Name_Export : constant Name_Id := N + 155; - Name_Export_Exception : constant Name_Id := N + 156; -- VMS - Name_Export_Function : constant Name_Id := N + 157; -- GNAT - Name_Export_Object : constant Name_Id := N + 158; -- GNAT - Name_Export_Procedure : constant Name_Id := N + 159; -- GNAT - Name_Export_Valued_Procedure : constant Name_Id := N + 160; -- GNAT - Name_External : constant Name_Id := N + 161; -- GNAT - Name_Finalize_Storage_Only : constant Name_Id := N + 162; -- GNAT - Name_Ident : constant Name_Id := N + 163; -- VMS - Name_Import : constant Name_Id := N + 164; - Name_Import_Exception : constant Name_Id := N + 165; -- VMS - Name_Import_Function : constant Name_Id := N + 166; -- GNAT - Name_Import_Object : constant Name_Id := N + 167; -- GNAT - Name_Import_Procedure : constant Name_Id := N + 168; -- GNAT - Name_Import_Valued_Procedure : constant Name_Id := N + 169; -- GNAT - Name_Inline : constant Name_Id := N + 170; - Name_Inline_Always : constant Name_Id := N + 171; -- GNAT - Name_Inline_Generic : constant Name_Id := N + 172; -- GNAT - Name_Inspection_Point : constant Name_Id := N + 173; - Name_Interface : constant Name_Id := N + 174; -- Ada 83 - Name_Interface_Name : constant Name_Id := N + 175; -- GNAT - Name_Interrupt_Handler : constant Name_Id := N + 176; - Name_Interrupt_Priority : constant Name_Id := N + 177; - Name_Java_Constructor : constant Name_Id := N + 178; -- GNAT - Name_Java_Interface : constant Name_Id := N + 179; -- GNAT - Name_Link_With : constant Name_Id := N + 180; -- GNAT - Name_Linker_Alias : constant Name_Id := N + 181; -- GNAT - Name_Linker_Options : constant Name_Id := N + 182; - Name_Linker_Section : constant Name_Id := N + 183; -- GNAT - Name_List : constant Name_Id := N + 184; - Name_Machine_Attribute : constant Name_Id := N + 185; -- GNAT - Name_Main : constant Name_Id := N + 186; -- GNAT - Name_Main_Storage : constant Name_Id := N + 187; -- GNAT - Name_Memory_Size : constant Name_Id := N + 188; -- Ada 83 - Name_No_Return : constant Name_Id := N + 189; -- GNAT - Name_Optimize : constant Name_Id := N + 190; - Name_Pack : constant Name_Id := N + 191; - Name_Page : constant Name_Id := N + 192; - Name_Passive : constant Name_Id := N + 193; -- GNAT - Name_Preelaborate : constant Name_Id := N + 194; - Name_Priority : constant Name_Id := N + 195; - Name_Psect_Object : constant Name_Id := N + 196; -- VMS - Name_Pure : constant Name_Id := N + 197; - Name_Pure_Function : constant Name_Id := N + 198; -- GNAT - Name_Remote_Call_Interface : constant Name_Id := N + 199; - Name_Remote_Types : constant Name_Id := N + 200; - Name_Share_Generic : constant Name_Id := N + 201; -- GNAT - Name_Shared : constant Name_Id := N + 202; -- Ada 83 - Name_Shared_Passive : constant Name_Id := N + 203; + Name_Assert : constant Name_Id := N + 138; -- GNAT + Name_Asynchronous : constant Name_Id := N + 139; + Name_Atomic : constant Name_Id := N + 140; + Name_Atomic_Components : constant Name_Id := N + 141; + Name_Attach_Handler : constant Name_Id := N + 142; + Name_Comment : constant Name_Id := N + 143; -- GNAT + Name_Common_Object : constant Name_Id := N + 144; -- GNAT + Name_Complex_Representation : constant Name_Id := N + 145; -- GNAT + Name_Controlled : constant Name_Id := N + 146; + Name_Convention : constant Name_Id := N + 147; + Name_CPP_Class : constant Name_Id := N + 148; -- GNAT + Name_CPP_Constructor : constant Name_Id := N + 149; -- GNAT + Name_CPP_Virtual : constant Name_Id := N + 150; -- GNAT + Name_CPP_Vtable : constant Name_Id := N + 151; -- GNAT + Name_Debug : constant Name_Id := N + 152; -- GNAT + Name_Elaborate : constant Name_Id := N + 153; -- Ada 83 + Name_Elaborate_All : constant Name_Id := N + 154; + Name_Elaborate_Body : constant Name_Id := N + 155; + Name_Export : constant Name_Id := N + 156; + Name_Export_Exception : constant Name_Id := N + 157; -- VMS + Name_Export_Function : constant Name_Id := N + 158; -- GNAT + Name_Export_Object : constant Name_Id := N + 159; -- GNAT + Name_Export_Procedure : constant Name_Id := N + 160; -- GNAT + Name_Export_Valued_Procedure : constant Name_Id := N + 161; -- GNAT + Name_External : constant Name_Id := N + 162; -- GNAT + Name_Finalize_Storage_Only : constant Name_Id := N + 163; -- GNAT + Name_Ident : constant Name_Id := N + 164; -- VMS + Name_Import : constant Name_Id := N + 165; + Name_Import_Exception : constant Name_Id := N + 166; -- VMS + Name_Import_Function : constant Name_Id := N + 167; -- GNAT + Name_Import_Object : constant Name_Id := N + 168; -- GNAT + Name_Import_Procedure : constant Name_Id := N + 169; -- GNAT + Name_Import_Valued_Procedure : constant Name_Id := N + 170; -- GNAT + Name_Inline : constant Name_Id := N + 171; + Name_Inline_Always : constant Name_Id := N + 172; -- GNAT + Name_Inline_Generic : constant Name_Id := N + 173; -- GNAT + Name_Inspection_Point : constant Name_Id := N + 174; + Name_Interface : constant Name_Id := N + 175; -- Ada 83 + Name_Interface_Name : constant Name_Id := N + 176; -- GNAT + Name_Interrupt_Handler : constant Name_Id := N + 177; + Name_Interrupt_Priority : constant Name_Id := N + 178; + Name_Java_Constructor : constant Name_Id := N + 179; -- GNAT + Name_Java_Interface : constant Name_Id := N + 180; -- GNAT + Name_Link_With : constant Name_Id := N + 181; -- GNAT + Name_Linker_Alias : constant Name_Id := N + 182; -- GNAT + Name_Linker_Options : constant Name_Id := N + 183; + Name_Linker_Section : constant Name_Id := N + 184; -- GNAT + Name_List : constant Name_Id := N + 185; + Name_Machine_Attribute : constant Name_Id := N + 186; -- GNAT + Name_Main : constant Name_Id := N + 187; -- GNAT + Name_Main_Storage : constant Name_Id := N + 188; -- GNAT + Name_Memory_Size : constant Name_Id := N + 189; -- Ada 83 + Name_No_Return : constant Name_Id := N + 190; -- GNAT + Name_Optimize : constant Name_Id := N + 191; + Name_Pack : constant Name_Id := N + 192; + Name_Page : constant Name_Id := N + 193; + Name_Passive : constant Name_Id := N + 194; -- GNAT + Name_Preelaborate : constant Name_Id := N + 195; + Name_Priority : constant Name_Id := N + 196; + Name_Psect_Object : constant Name_Id := N + 197; -- VMS + Name_Pure : constant Name_Id := N + 198; + Name_Pure_Function : constant Name_Id := N + 199; -- GNAT + Name_Remote_Call_Interface : constant Name_Id := N + 200; + Name_Remote_Types : constant Name_Id := N + 201; + Name_Share_Generic : constant Name_Id := N + 202; -- GNAT + Name_Shared : constant Name_Id := N + 203; -- Ada 83 + Name_Shared_Passive : constant Name_Id := N + 204; -- Note: Storage_Size is not in this list because its name matches the -- name of the corresponding attribute. However, it is included in the @@ -426,25 +431,27 @@ package Snames is -- Note: Storage_Unit is also omitted from the list because of a clash -- with an attribute name, and is treated similarly. - Name_Source_Reference : constant Name_Id := N + 204; -- GNAT - Name_Stream_Convert : constant Name_Id := N + 205; -- GNAT - Name_Subtitle : constant Name_Id := N + 206; -- GNAT - Name_Suppress_All : constant Name_Id := N + 207; -- GNAT - Name_Suppress_Debug_Info : constant Name_Id := N + 208; -- GNAT - Name_Suppress_Initialization : constant Name_Id := N + 209; -- GNAT - Name_System_Name : constant Name_Id := N + 210; -- Ada 83 - Name_Task_Info : constant Name_Id := N + 211; -- GNAT - Name_Task_Name : constant Name_Id := N + 212; -- GNAT - Name_Task_Storage : constant Name_Id := N + 213; -- VMS - Name_Time_Slice : constant Name_Id := N + 214; -- GNAT - Name_Title : constant Name_Id := N + 215; -- GNAT - Name_Unchecked_Union : constant Name_Id := N + 216; -- GNAT - Name_Unimplemented_Unit : constant Name_Id := N + 217; -- GNAT - Name_Unreserve_All_Interrupts : constant Name_Id := N + 218; -- GNAT - Name_Volatile : constant Name_Id := N + 219; - Name_Volatile_Components : constant Name_Id := N + 220; - Name_Weak_External : constant Name_Id := N + 221; -- GNAT - Last_Pragma_Name : constant Name_Id := N + 221; + Name_Source_Reference : constant Name_Id := N + 205; -- GNAT + Name_Stream_Convert : constant Name_Id := N + 206; -- GNAT + Name_Subtitle : constant Name_Id := N + 207; -- GNAT + Name_Suppress_All : constant Name_Id := N + 208; -- GNAT + Name_Suppress_Debug_Info : constant Name_Id := N + 209; -- GNAT + Name_Suppress_Initialization : constant Name_Id := N + 210; -- GNAT + Name_System_Name : constant Name_Id := N + 211; -- Ada 83 + Name_Task_Info : constant Name_Id := N + 212; -- GNAT + Name_Task_Name : constant Name_Id := N + 213; -- GNAT + Name_Task_Storage : constant Name_Id := N + 214; -- VMS + Name_Time_Slice : constant Name_Id := N + 215; -- GNAT + Name_Title : constant Name_Id := N + 216; -- GNAT + Name_Unchecked_Union : constant Name_Id := N + 217; -- GNAT + Name_Unimplemented_Unit : constant Name_Id := N + 218; -- GNAT + Name_Universal_Data : constant Name_Id := N + 219; -- AAMP + Name_Unreferenced : constant Name_Id := N + 220; -- GNAT + Name_Unreserve_All_Interrupts : constant Name_Id := N + 221; -- GNAT + Name_Volatile : constant Name_Id := N + 222; + Name_Volatile_Components : constant Name_Id := N + 223; + Name_Weak_External : constant Name_Id := N + 224; -- GNAT + Last_Pragma_Name : constant Name_Id := N + 224; -- Language convention names for pragma Convention/Export/Import/Interface -- Note that Name_C is not included in this list, since it was already @@ -455,86 +462,93 @@ package Snames is -- Entry and Protected, this is because these conventions cannot be -- specified by a pragma. - -- Note: The convention name C_Pass_By_Copy is treated as entirely - -- equivalent to C except when it is specified on a record type. In - -- this case the convention of the record type is set to C, but in - -- addition the flag C_Pass_By_Copy is set on the record type. - - First_Convention_Name : constant Name_Id := N + 222; - Name_Ada : constant Name_Id := N + 222; - Name_Asm : constant Name_Id := N + 223; - Name_Assembler : constant Name_Id := N + 224; - Name_COBOL : constant Name_Id := N + 225; - Name_CPP : constant Name_Id := N + 226; - Name_DLL : constant Name_Id := N + 227; - Name_Fortran : constant Name_Id := N + 228; - Name_Intrinsic : constant Name_Id := N + 229; - Name_Java : constant Name_Id := N + 230; - Name_Stdcall : constant Name_Id := N + 231; - Name_Stubbed : constant Name_Id := N + 232; - Name_Win32 : constant Name_Id := N + 233; + First_Convention_Name : constant Name_Id := N + 225; + Name_Ada : constant Name_Id := N + 225; + Name_Assembler : constant Name_Id := N + 226; + Name_COBOL : constant Name_Id := N + 227; + Name_CPP : constant Name_Id := N + 228; + Name_Fortran : constant Name_Id := N + 229; + Name_Intrinsic : constant Name_Id := N + 230; + Name_Java : constant Name_Id := N + 231; + Name_Stdcall : constant Name_Id := N + 232; + Name_Stubbed : constant Name_Id := N + 233; Last_Convention_Name : constant Name_Id := N + 233; + -- The following names are preset as synonyms for Assembler + + Name_Asm : constant Name_Id := N + 234; + Name_Assembly : constant Name_Id := N + 235; + + -- The following names are preset as synonyms for C + + Name_Default : constant Name_Id := N + 236; + -- Name_Exernal (previously defined as pragma) + + -- The following names are present as synonyms for Stdcall + + Name_DLL : constant Name_Id := N + 237; + Name_Win32 : constant Name_Id := N + 238; + -- Other special names used in processing pragma arguments - Name_As_Is : constant Name_Id := N + 234; - Name_Body_File_Name : constant Name_Id := N + 235; - Name_Casing : constant Name_Id := N + 236; - Name_Code : constant Name_Id := N + 237; - Name_Component : constant Name_Id := N + 238; - Name_Component_Size_4 : constant Name_Id := N + 239; - Name_Copy : constant Name_Id := N + 240; - Name_D_Float : constant Name_Id := N + 241; - Name_Descriptor : constant Name_Id := N + 242; - Name_Default : constant Name_Id := N + 243; - Name_Dot_Replacement : constant Name_Id := N + 244; - Name_Dynamic : constant Name_Id := N + 245; - Name_Entity : constant Name_Id := N + 246; - Name_External_Name : constant Name_Id := N + 247; - Name_First_Optional_Parameter : constant Name_Id := N + 248; - Name_Form : constant Name_Id := N + 249; - Name_G_Float : constant Name_Id := N + 250; - Name_Gcc : constant Name_Id := N + 251; - Name_Gnat : constant Name_Id := N + 252; - Name_GPL : constant Name_Id := N + 253; - Name_IEEE_Float : constant Name_Id := N + 254; - Name_Internal : constant Name_Id := N + 255; - Name_Link_Name : constant Name_Id := N + 256; - Name_Lowercase : constant Name_Id := N + 257; - Name_Max_Size : constant Name_Id := N + 258; - Name_Mechanism : constant Name_Id := N + 259; - Name_Mixedcase : constant Name_Id := N + 260; - Name_Modified_GPL : constant Name_Id := N + 261; - Name_Name : constant Name_Id := N + 262; - Name_NCA : constant Name_Id := N + 263; - Name_No : constant Name_Id := N + 264; - Name_On : constant Name_Id := N + 265; - Name_Parameter_Types : constant Name_Id := N + 266; - Name_Reference : constant Name_Id := N + 267; - Name_Restricted : constant Name_Id := N + 268; - Name_Result_Mechanism : constant Name_Id := N + 269; - Name_Result_Type : constant Name_Id := N + 270; - Name_SB : constant Name_Id := N + 271; - Name_Section : constant Name_Id := N + 272; - Name_Semaphore : constant Name_Id := N + 273; - Name_Spec_File_Name : constant Name_Id := N + 274; - Name_Static : constant Name_Id := N + 275; - Name_Stack_Size : constant Name_Id := N + 276; - Name_Subunit_File_Name : constant Name_Id := N + 277; - Name_Task_Stack_Size_Default : constant Name_Id := N + 278; - Name_Task_Type : constant Name_Id := N + 279; - Name_Time_Slicing_Enabled : constant Name_Id := N + 280; - Name_Top_Guard : constant Name_Id := N + 281; - Name_UBA : constant Name_Id := N + 282; - Name_UBS : constant Name_Id := N + 283; - Name_UBSB : constant Name_Id := N + 284; - Name_Unit_Name : constant Name_Id := N + 285; - Name_Unknown : constant Name_Id := N + 286; - Name_Unrestricted : constant Name_Id := N + 287; - Name_Uppercase : constant Name_Id := N + 288; - Name_VAX_Float : constant Name_Id := N + 289; - Name_VMS : constant Name_Id := N + 290; - Name_Working_Storage : constant Name_Id := N + 291; + Name_As_Is : constant Name_Id := N + 239; + Name_Body_File_Name : constant Name_Id := N + 240; + Name_Casing : constant Name_Id := N + 241; + Name_Code : constant Name_Id := N + 242; + Name_Component : constant Name_Id := N + 243; + Name_Component_Size_4 : constant Name_Id := N + 244; + Name_Copy : constant Name_Id := N + 245; + Name_D_Float : constant Name_Id := N + 246; + Name_Descriptor : constant Name_Id := N + 247; + Name_Dot_Replacement : constant Name_Id := N + 248; + Name_Dynamic : constant Name_Id := N + 249; + Name_Entity : constant Name_Id := N + 250; + Name_External_Name : constant Name_Id := N + 251; + Name_First_Optional_Parameter : constant Name_Id := N + 252; + Name_Form : constant Name_Id := N + 253; + Name_G_Float : constant Name_Id := N + 254; + Name_Gcc : constant Name_Id := N + 255; + Name_Gnat : constant Name_Id := N + 256; + Name_GPL : constant Name_Id := N + 257; + Name_IEEE_Float : constant Name_Id := N + 258; + Name_Homonym_Number : constant Name_Id := N + 259; + Name_Internal : constant Name_Id := N + 260; + Name_Link_Name : constant Name_Id := N + 261; + Name_Lowercase : constant Name_Id := N + 262; + Name_Max_Size : constant Name_Id := N + 263; + Name_Mechanism : constant Name_Id := N + 264; + Name_Mixedcase : constant Name_Id := N + 265; + Name_Modified_GPL : constant Name_Id := N + 266; + Name_Name : constant Name_Id := N + 267; + Name_NCA : constant Name_Id := N + 268; + Name_No : constant Name_Id := N + 269; + Name_On : constant Name_Id := N + 270; + Name_Parameter_Types : constant Name_Id := N + 271; + Name_Reference : constant Name_Id := N + 272; + Name_Restricted : constant Name_Id := N + 273; + Name_Result_Mechanism : constant Name_Id := N + 274; + Name_Result_Type : constant Name_Id := N + 275; + Name_SB : constant Name_Id := N + 276; + Name_Section : constant Name_Id := N + 277; + Name_Semaphore : constant Name_Id := N + 278; + Name_Spec_File_Name : constant Name_Id := N + 279; + Name_Static : constant Name_Id := N + 280; + Name_Stack_Size : constant Name_Id := N + 281; + Name_Subunit_File_Name : constant Name_Id := N + 282; + Name_Task_Stack_Size_Default : constant Name_Id := N + 283; + Name_Task_Type : constant Name_Id := N + 284; + Name_Time_Slicing_Enabled : constant Name_Id := N + 285; + Name_Top_Guard : constant Name_Id := N + 286; + Name_UBA : constant Name_Id := N + 287; + Name_UBS : constant Name_Id := N + 288; + Name_UBSB : constant Name_Id := N + 289; + Name_Unit_Name : constant Name_Id := N + 290; + Name_Unknown : constant Name_Id := N + 291; + Name_Unrestricted : constant Name_Id := N + 292; + Name_Uppercase : constant Name_Id := N + 293; + Name_VAX_Float : constant Name_Id := N + 294; + Name_VMS : constant Name_Id := N + 295; + Name_Working_Storage : constant Name_Id := N + 296; -- Names of recognized attributes. The entries with the comment "Ada 83" -- are attributes that are defined in Ada 83, but not in Ada 95. These @@ -548,158 +562,155 @@ package Snames is -- The entries marked VMS are recognized only in OpenVMS implementations -- of GNAT, and are treated as illegal in all other contexts. - First_Attribute_Name : constant Name_Id := N + 292; - Name_Abort_Signal : constant Name_Id := N + 292; -- GNAT - Name_Access : constant Name_Id := N + 293; - Name_Address : constant Name_Id := N + 294; - Name_Address_Size : constant Name_Id := N + 295; -- GNAT - Name_Aft : constant Name_Id := N + 296; - Name_Alignment : constant Name_Id := N + 297; - Name_Asm_Input : constant Name_Id := N + 298; -- GNAT - Name_Asm_Output : constant Name_Id := N + 299; -- GNAT - Name_AST_Entry : constant Name_Id := N + 300; -- VMS - Name_Bit : constant Name_Id := N + 301; -- GNAT - Name_Bit_Order : constant Name_Id := N + 302; - Name_Bit_Position : constant Name_Id := N + 303; -- GNAT - Name_Body_Version : constant Name_Id := N + 304; - Name_Callable : constant Name_Id := N + 305; - Name_Caller : constant Name_Id := N + 306; - Name_Code_Address : constant Name_Id := N + 307; -- GNAT - Name_Component_Size : constant Name_Id := N + 308; - Name_Compose : constant Name_Id := N + 309; - Name_Constrained : constant Name_Id := N + 310; - Name_Count : constant Name_Id := N + 311; - Name_Default_Bit_Order : constant Name_Id := N + 312; -- GNAT - Name_Definite : constant Name_Id := N + 313; - Name_Delta : constant Name_Id := N + 314; - Name_Denorm : constant Name_Id := N + 315; - Name_Digits : constant Name_Id := N + 316; - Name_Elaborated : constant Name_Id := N + 317; -- GNAT - Name_Emax : constant Name_Id := N + 318; -- Ada 83 - Name_Enum_Rep : constant Name_Id := N + 319; -- GNAT - Name_Epsilon : constant Name_Id := N + 320; -- Ada 83 - Name_Exponent : constant Name_Id := N + 321; - Name_External_Tag : constant Name_Id := N + 322; - Name_First : constant Name_Id := N + 323; - Name_First_Bit : constant Name_Id := N + 324; - Name_Fixed_Value : constant Name_Id := N + 325; -- GNAT - Name_Fore : constant Name_Id := N + 326; - Name_Has_Discriminants : constant Name_Id := N + 327; -- GNAT - Name_Identity : constant Name_Id := N + 328; - Name_Img : constant Name_Id := N + 329; -- GNAT - Name_Integer_Value : constant Name_Id := N + 330; -- GNAT - Name_Large : constant Name_Id := N + 331; -- Ada 83 - Name_Last : constant Name_Id := N + 332; - Name_Last_Bit : constant Name_Id := N + 333; - Name_Leading_Part : constant Name_Id := N + 334; - Name_Length : constant Name_Id := N + 335; - Name_Machine_Emax : constant Name_Id := N + 336; - Name_Machine_Emin : constant Name_Id := N + 337; - Name_Machine_Mantissa : constant Name_Id := N + 338; - Name_Machine_Overflows : constant Name_Id := N + 339; - Name_Machine_Radix : constant Name_Id := N + 340; - Name_Machine_Rounds : constant Name_Id := N + 341; - Name_Machine_Size : constant Name_Id := N + 342; -- GNAT - Name_Mantissa : constant Name_Id := N + 343; -- Ada 83 - Name_Max_Interrupt_Priority : constant Name_Id := N + 344; -- GNAT - Name_Max_Priority : constant Name_Id := N + 345; -- GNAT - Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 346; - Name_Maximum_Alignment : constant Name_Id := N + 347; -- GNAT - Name_Mechanism_Code : constant Name_Id := N + 348; -- GNAT - Name_Model_Emin : constant Name_Id := N + 349; - Name_Model_Epsilon : constant Name_Id := N + 350; - Name_Model_Mantissa : constant Name_Id := N + 351; - Name_Model_Small : constant Name_Id := N + 352; - Name_Modulus : constant Name_Id := N + 353; - Name_Null_Parameter : constant Name_Id := N + 354; -- GNAT - Name_Object_Size : constant Name_Id := N + 355; -- GNAT - Name_Partition_ID : constant Name_Id := N + 356; - Name_Passed_By_Reference : constant Name_Id := N + 357; -- GNAT - Name_Pos : constant Name_Id := N + 358; - Name_Position : constant Name_Id := N + 359; - Name_Range : constant Name_Id := N + 360; - Name_Range_Length : constant Name_Id := N + 361; -- GNAT - Name_Round : constant Name_Id := N + 362; - Name_Safe_Emax : constant Name_Id := N + 363; -- Ada 83 - Name_Safe_First : constant Name_Id := N + 364; - Name_Safe_Large : constant Name_Id := N + 365; -- Ada 83 - Name_Safe_Last : constant Name_Id := N + 366; - Name_Safe_Small : constant Name_Id := N + 367; -- Ada 83 - Name_Scale : constant Name_Id := N + 368; - Name_Scaling : constant Name_Id := N + 369; - Name_Signed_Zeros : constant Name_Id := N + 370; - Name_Size : constant Name_Id := N + 371; - Name_Small : constant Name_Id := N + 372; - Name_Storage_Size : constant Name_Id := N + 373; - Name_Storage_Unit : constant Name_Id := N + 374; -- GNAT - Name_Tag : constant Name_Id := N + 375; - Name_Terminated : constant Name_Id := N + 376; - Name_Tick : constant Name_Id := N + 377; -- GNAT - Name_To_Address : constant Name_Id := N + 378; -- GNAT - Name_Type_Class : constant Name_Id := N + 379; -- GNAT - Name_UET_Address : constant Name_Id := N + 380; -- GNAT - Name_Unbiased_Rounding : constant Name_Id := N + 381; - Name_Unchecked_Access : constant Name_Id := N + 382; - Name_Universal_Literal_String : constant Name_Id := N + 383; -- GNAT - Name_Unrestricted_Access : constant Name_Id := N + 384; -- GNAT - Name_VADS_Size : constant Name_Id := N + 385; -- GNAT - Name_Val : constant Name_Id := N + 386; - Name_Valid : constant Name_Id := N + 387; - Name_Value_Size : constant Name_Id := N + 388; -- GNAT - Name_Version : constant Name_Id := N + 389; - Name_Wchar_T_Size : constant Name_Id := N + 390; -- GNAT - Name_Wide_Width : constant Name_Id := N + 391; - Name_Width : constant Name_Id := N + 392; - Name_Word_Size : constant Name_Id := N + 393; -- GNAT + First_Attribute_Name : constant Name_Id := N + 297; + Name_Abort_Signal : constant Name_Id := N + 297; -- GNAT + Name_Access : constant Name_Id := N + 298; + Name_Address : constant Name_Id := N + 299; + Name_Address_Size : constant Name_Id := N + 300; -- GNAT + Name_Aft : constant Name_Id := N + 301; + Name_Alignment : constant Name_Id := N + 302; + Name_Asm_Input : constant Name_Id := N + 303; -- GNAT + Name_Asm_Output : constant Name_Id := N + 304; -- GNAT + Name_AST_Entry : constant Name_Id := N + 305; -- VMS + Name_Bit : constant Name_Id := N + 306; -- GNAT + Name_Bit_Order : constant Name_Id := N + 307; + Name_Bit_Position : constant Name_Id := N + 308; -- GNAT + Name_Body_Version : constant Name_Id := N + 309; + Name_Callable : constant Name_Id := N + 310; + Name_Caller : constant Name_Id := N + 311; + Name_Code_Address : constant Name_Id := N + 312; -- GNAT + Name_Component_Size : constant Name_Id := N + 313; + Name_Compose : constant Name_Id := N + 314; + Name_Constrained : constant Name_Id := N + 315; + Name_Count : constant Name_Id := N + 316; + Name_Default_Bit_Order : constant Name_Id := N + 317; -- GNAT + Name_Definite : constant Name_Id := N + 318; + Name_Delta : constant Name_Id := N + 319; + Name_Denorm : constant Name_Id := N + 320; + Name_Digits : constant Name_Id := N + 321; + Name_Elaborated : constant Name_Id := N + 322; -- GNAT + Name_Emax : constant Name_Id := N + 323; -- Ada 83 + Name_Enum_Rep : constant Name_Id := N + 324; -- GNAT + Name_Epsilon : constant Name_Id := N + 325; -- Ada 83 + Name_Exponent : constant Name_Id := N + 326; + Name_External_Tag : constant Name_Id := N + 327; + Name_First : constant Name_Id := N + 328; + Name_First_Bit : constant Name_Id := N + 329; + Name_Fixed_Value : constant Name_Id := N + 330; -- GNAT + Name_Fore : constant Name_Id := N + 331; + Name_Has_Discriminants : constant Name_Id := N + 332; -- GNAT + Name_Identity : constant Name_Id := N + 333; + Name_Img : constant Name_Id := N + 334; -- GNAT + Name_Integer_Value : constant Name_Id := N + 335; -- GNAT + Name_Large : constant Name_Id := N + 336; -- Ada 83 + Name_Last : constant Name_Id := N + 337; + Name_Last_Bit : constant Name_Id := N + 338; + Name_Leading_Part : constant Name_Id := N + 339; + Name_Length : constant Name_Id := N + 340; + Name_Machine_Emax : constant Name_Id := N + 341; + Name_Machine_Emin : constant Name_Id := N + 342; + Name_Machine_Mantissa : constant Name_Id := N + 343; + Name_Machine_Overflows : constant Name_Id := N + 344; + Name_Machine_Radix : constant Name_Id := N + 345; + Name_Machine_Rounds : constant Name_Id := N + 346; + Name_Machine_Size : constant Name_Id := N + 347; -- GNAT + Name_Mantissa : constant Name_Id := N + 348; -- Ada 83 + Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 349; + Name_Maximum_Alignment : constant Name_Id := N + 350; -- GNAT + Name_Mechanism_Code : constant Name_Id := N + 351; -- GNAT + Name_Model_Emin : constant Name_Id := N + 352; + Name_Model_Epsilon : constant Name_Id := N + 353; + Name_Model_Mantissa : constant Name_Id := N + 354; + Name_Model_Small : constant Name_Id := N + 355; + Name_Modulus : constant Name_Id := N + 356; + Name_Null_Parameter : constant Name_Id := N + 357; -- GNAT + Name_Object_Size : constant Name_Id := N + 358; -- GNAT + Name_Partition_ID : constant Name_Id := N + 359; + Name_Passed_By_Reference : constant Name_Id := N + 360; -- GNAT + Name_Pos : constant Name_Id := N + 361; + Name_Position : constant Name_Id := N + 362; + Name_Range : constant Name_Id := N + 363; + Name_Range_Length : constant Name_Id := N + 364; -- GNAT + Name_Round : constant Name_Id := N + 365; + Name_Safe_Emax : constant Name_Id := N + 366; -- Ada 83 + Name_Safe_First : constant Name_Id := N + 367; + Name_Safe_Large : constant Name_Id := N + 368; -- Ada 83 + Name_Safe_Last : constant Name_Id := N + 369; + Name_Safe_Small : constant Name_Id := N + 370; -- Ada 83 + Name_Scale : constant Name_Id := N + 371; + Name_Scaling : constant Name_Id := N + 372; + Name_Signed_Zeros : constant Name_Id := N + 373; + Name_Size : constant Name_Id := N + 374; + Name_Small : constant Name_Id := N + 375; + Name_Storage_Size : constant Name_Id := N + 376; + Name_Storage_Unit : constant Name_Id := N + 377; -- GNAT + Name_Tag : constant Name_Id := N + 378; + Name_Terminated : constant Name_Id := N + 379; + Name_To_Address : constant Name_Id := N + 380; -- GNAT + Name_Type_Class : constant Name_Id := N + 381; -- GNAT + Name_UET_Address : constant Name_Id := N + 382; -- GNAT + Name_Unbiased_Rounding : constant Name_Id := N + 383; + Name_Unchecked_Access : constant Name_Id := N + 384; + Name_Universal_Literal_String : constant Name_Id := N + 385; -- GNAT + Name_Unrestricted_Access : constant Name_Id := N + 386; -- GNAT + Name_VADS_Size : constant Name_Id := N + 387; -- GNAT + Name_Val : constant Name_Id := N + 388; + Name_Valid : constant Name_Id := N + 389; + Name_Value_Size : constant Name_Id := N + 390; -- GNAT + Name_Version : constant Name_Id := N + 391; + Name_Wchar_T_Size : constant Name_Id := N + 392; -- GNAT + Name_Wide_Width : constant Name_Id := N + 393; + Name_Width : constant Name_Id := N + 394; + Name_Word_Size : constant Name_Id := N + 395; -- GNAT -- Attributes that designate attributes returning renamable functions, -- i.e. functions that return other than a universal value. - First_Renamable_Function_Attribute : constant Name_Id := N + 394; - Name_Adjacent : constant Name_Id := N + 394; - Name_Ceiling : constant Name_Id := N + 395; - Name_Copy_Sign : constant Name_Id := N + 396; - Name_Floor : constant Name_Id := N + 397; - Name_Fraction : constant Name_Id := N + 398; - Name_Image : constant Name_Id := N + 399; - Name_Input : constant Name_Id := N + 400; - Name_Machine : constant Name_Id := N + 401; - Name_Max : constant Name_Id := N + 402; - Name_Min : constant Name_Id := N + 403; - Name_Model : constant Name_Id := N + 404; - Name_Pred : constant Name_Id := N + 405; - Name_Remainder : constant Name_Id := N + 406; - Name_Rounding : constant Name_Id := N + 407; - Name_Succ : constant Name_Id := N + 408; - Name_Truncation : constant Name_Id := N + 409; - Name_Value : constant Name_Id := N + 410; - Name_Wide_Image : constant Name_Id := N + 411; - Name_Wide_Value : constant Name_Id := N + 412; - Last_Renamable_Function_Attribute : constant Name_Id := N + 412; + First_Renamable_Function_Attribute : constant Name_Id := N + 396; + Name_Adjacent : constant Name_Id := N + 396; + Name_Ceiling : constant Name_Id := N + 397; + Name_Copy_Sign : constant Name_Id := N + 398; + Name_Floor : constant Name_Id := N + 399; + Name_Fraction : constant Name_Id := N + 400; + Name_Image : constant Name_Id := N + 401; + Name_Input : constant Name_Id := N + 402; + Name_Machine : constant Name_Id := N + 403; + Name_Max : constant Name_Id := N + 404; + Name_Min : constant Name_Id := N + 405; + Name_Model : constant Name_Id := N + 406; + Name_Pred : constant Name_Id := N + 407; + Name_Remainder : constant Name_Id := N + 408; + Name_Rounding : constant Name_Id := N + 409; + Name_Succ : constant Name_Id := N + 410; + Name_Truncation : constant Name_Id := N + 411; + Name_Value : constant Name_Id := N + 412; + Name_Wide_Image : constant Name_Id := N + 413; + Name_Wide_Value : constant Name_Id := N + 414; + Last_Renamable_Function_Attribute : constant Name_Id := N + 414; -- Attributes that designate procedures - First_Procedure_Attribute : constant Name_Id := N + 413; - Name_Output : constant Name_Id := N + 413; - Name_Read : constant Name_Id := N + 414; - Name_Write : constant Name_Id := N + 415; - Last_Procedure_Attribute : constant Name_Id := N + 415; + First_Procedure_Attribute : constant Name_Id := N + 415; + Name_Output : constant Name_Id := N + 415; + Name_Read : constant Name_Id := N + 416; + Name_Write : constant Name_Id := N + 417; + Last_Procedure_Attribute : constant Name_Id := N + 417; -- Remaining attributes are ones that return entities - First_Entity_Attribute_Name : constant Name_Id := N + 416; - Name_Elab_Body : constant Name_Id := N + 416; -- GNAT - Name_Elab_Spec : constant Name_Id := N + 417; -- GNAT - Name_Storage_Pool : constant Name_Id := N + 418; + First_Entity_Attribute_Name : constant Name_Id := N + 418; + Name_Elab_Body : constant Name_Id := N + 418; -- GNAT + Name_Elab_Spec : constant Name_Id := N + 419; -- GNAT + Name_Storage_Pool : constant Name_Id := N + 420; -- These attributes are the ones that return types - First_Type_Attribute_Name : constant Name_Id := N + 419; - Name_Base : constant Name_Id := N + 419; - Name_Class : constant Name_Id := N + 420; - Last_Type_Attribute_Name : constant Name_Id := N + 420; - Last_Entity_Attribute_Name : constant Name_Id := N + 420; - Last_Attribute_Name : constant Name_Id := N + 420; + First_Type_Attribute_Name : constant Name_Id := N + 421; + Name_Base : constant Name_Id := N + 421; + Name_Class : constant Name_Id := N + 422; + Last_Type_Attribute_Name : constant Name_Id := N + 422; + Last_Entity_Attribute_Name : constant Name_Id := N + 422; + Last_Attribute_Name : constant Name_Id := N + 422; -- Names of recognized locking policy identifiers @@ -707,10 +718,10 @@ package Snames is -- name (e.g. C for Ceiling_Locking). If new policy names are added, -- the first character must be distinct. - First_Locking_Policy_Name : constant Name_Id := N + 421; - Name_Ceiling_Locking : constant Name_Id := N + 421; - Name_Inheritance_Locking : constant Name_Id := N + 422; - Last_Locking_Policy_Name : constant Name_Id := N + 422; + First_Locking_Policy_Name : constant Name_Id := N + 423; + Name_Ceiling_Locking : constant Name_Id := N + 423; + Name_Inheritance_Locking : constant Name_Id := N + 424; + Last_Locking_Policy_Name : constant Name_Id := N + 424; -- Names of recognized queuing policy identifiers. @@ -718,10 +729,10 @@ package Snames is -- name (e.g. F for FIFO_Queuing). If new policy names are added, -- the first character must be distinct. - First_Queuing_Policy_Name : constant Name_Id := N + 423; - Name_FIFO_Queuing : constant Name_Id := N + 423; - Name_Priority_Queuing : constant Name_Id := N + 424; - Last_Queuing_Policy_Name : constant Name_Id := N + 424; + First_Queuing_Policy_Name : constant Name_Id := N + 425; + Name_FIFO_Queuing : constant Name_Id := N + 425; + Name_Priority_Queuing : constant Name_Id := N + 426; + Last_Queuing_Policy_Name : constant Name_Id := N + 426; -- Names of recognized task dispatching policy identifiers @@ -729,172 +740,172 @@ package Snames is -- name (e.g. F for FIFO_WIthinn_Priorities). If new policy names -- are added, the first character must be distinct. - First_Task_Dispatching_Policy_Name : constant Name_Id := N + 425; - Name_Fifo_Within_Priorities : constant Name_Id := N + 425; - Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 425; + First_Task_Dispatching_Policy_Name : constant Name_Id := N + 427; + Name_Fifo_Within_Priorities : constant Name_Id := N + 427; + Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 427; -- Names of recognized checks for pragma Suppress - First_Check_Name : constant Name_Id := N + 426; - Name_Access_Check : constant Name_Id := N + 426; - Name_Accessibility_Check : constant Name_Id := N + 427; - Name_Discriminant_Check : constant Name_Id := N + 428; - Name_Division_Check : constant Name_Id := N + 429; - Name_Elaboration_Check : constant Name_Id := N + 430; - Name_Index_Check : constant Name_Id := N + 431; - Name_Length_Check : constant Name_Id := N + 432; - Name_Overflow_Check : constant Name_Id := N + 433; - Name_Range_Check : constant Name_Id := N + 434; - Name_Storage_Check : constant Name_Id := N + 435; - Name_Tag_Check : constant Name_Id := N + 436; - Name_All_Checks : constant Name_Id := N + 437; - Last_Check_Name : constant Name_Id := N + 437; + First_Check_Name : constant Name_Id := N + 428; + Name_Access_Check : constant Name_Id := N + 428; + Name_Accessibility_Check : constant Name_Id := N + 429; + Name_Discriminant_Check : constant Name_Id := N + 430; + Name_Division_Check : constant Name_Id := N + 431; + Name_Elaboration_Check : constant Name_Id := N + 432; + Name_Index_Check : constant Name_Id := N + 433; + Name_Length_Check : constant Name_Id := N + 434; + Name_Overflow_Check : constant Name_Id := N + 435; + Name_Range_Check : constant Name_Id := N + 436; + Name_Storage_Check : constant Name_Id := N + 437; + Name_Tag_Check : constant Name_Id := N + 438; + Name_All_Checks : constant Name_Id := N + 439; + Last_Check_Name : constant Name_Id := N + 439; -- Names corresponding to reserved keywords, excluding those already -- declared in the attribute list (Access, Delta, Digits, Range). - Name_Abort : constant Name_Id := N + 438; - Name_Abs : constant Name_Id := N + 439; - Name_Accept : constant Name_Id := N + 440; - Name_And : constant Name_Id := N + 441; - Name_All : constant Name_Id := N + 442; - Name_Array : constant Name_Id := N + 443; - Name_At : constant Name_Id := N + 444; - Name_Begin : constant Name_Id := N + 445; - Name_Body : constant Name_Id := N + 446; - Name_Case : constant Name_Id := N + 447; - Name_Constant : constant Name_Id := N + 448; - Name_Declare : constant Name_Id := N + 449; - Name_Delay : constant Name_Id := N + 450; - Name_Do : constant Name_Id := N + 451; - Name_Else : constant Name_Id := N + 452; - Name_Elsif : constant Name_Id := N + 453; - Name_End : constant Name_Id := N + 454; - Name_Entry : constant Name_Id := N + 455; - Name_Exception : constant Name_Id := N + 456; - Name_Exit : constant Name_Id := N + 457; - Name_For : constant Name_Id := N + 458; - Name_Function : constant Name_Id := N + 459; - Name_Generic : constant Name_Id := N + 460; - Name_Goto : constant Name_Id := N + 461; - Name_If : constant Name_Id := N + 462; - Name_In : constant Name_Id := N + 463; - Name_Is : constant Name_Id := N + 464; - Name_Limited : constant Name_Id := N + 465; - Name_Loop : constant Name_Id := N + 466; - Name_Mod : constant Name_Id := N + 467; - Name_New : constant Name_Id := N + 468; - Name_Not : constant Name_Id := N + 469; - Name_Null : constant Name_Id := N + 470; - Name_Of : constant Name_Id := N + 471; - Name_Or : constant Name_Id := N + 472; - Name_Others : constant Name_Id := N + 473; - Name_Out : constant Name_Id := N + 474; - Name_Package : constant Name_Id := N + 475; - Name_Pragma : constant Name_Id := N + 476; - Name_Private : constant Name_Id := N + 477; - Name_Procedure : constant Name_Id := N + 478; - Name_Raise : constant Name_Id := N + 479; - Name_Record : constant Name_Id := N + 480; - Name_Rem : constant Name_Id := N + 481; - Name_Renames : constant Name_Id := N + 482; - Name_Return : constant Name_Id := N + 483; - Name_Reverse : constant Name_Id := N + 484; - Name_Select : constant Name_Id := N + 485; - Name_Separate : constant Name_Id := N + 486; - Name_Subtype : constant Name_Id := N + 487; - Name_Task : constant Name_Id := N + 488; - Name_Terminate : constant Name_Id := N + 489; - Name_Then : constant Name_Id := N + 490; - Name_Type : constant Name_Id := N + 491; - Name_Use : constant Name_Id := N + 492; - Name_When : constant Name_Id := N + 493; - Name_While : constant Name_Id := N + 494; - Name_With : constant Name_Id := N + 495; - Name_Xor : constant Name_Id := N + 496; + Name_Abort : constant Name_Id := N + 440; + Name_Abs : constant Name_Id := N + 441; + Name_Accept : constant Name_Id := N + 442; + Name_And : constant Name_Id := N + 443; + Name_All : constant Name_Id := N + 444; + Name_Array : constant Name_Id := N + 445; + Name_At : constant Name_Id := N + 446; + Name_Begin : constant Name_Id := N + 447; + Name_Body : constant Name_Id := N + 448; + Name_Case : constant Name_Id := N + 449; + Name_Constant : constant Name_Id := N + 450; + Name_Declare : constant Name_Id := N + 451; + Name_Delay : constant Name_Id := N + 452; + Name_Do : constant Name_Id := N + 453; + Name_Else : constant Name_Id := N + 454; + Name_Elsif : constant Name_Id := N + 455; + Name_End : constant Name_Id := N + 456; + Name_Entry : constant Name_Id := N + 457; + Name_Exception : constant Name_Id := N + 458; + Name_Exit : constant Name_Id := N + 459; + Name_For : constant Name_Id := N + 460; + Name_Function : constant Name_Id := N + 461; + Name_Generic : constant Name_Id := N + 462; + Name_Goto : constant Name_Id := N + 463; + Name_If : constant Name_Id := N + 464; + Name_In : constant Name_Id := N + 465; + Name_Is : constant Name_Id := N + 466; + Name_Limited : constant Name_Id := N + 467; + Name_Loop : constant Name_Id := N + 468; + Name_Mod : constant Name_Id := N + 469; + Name_New : constant Name_Id := N + 470; + Name_Not : constant Name_Id := N + 471; + Name_Null : constant Name_Id := N + 472; + Name_Of : constant Name_Id := N + 473; + Name_Or : constant Name_Id := N + 474; + Name_Others : constant Name_Id := N + 475; + Name_Out : constant Name_Id := N + 476; + Name_Package : constant Name_Id := N + 477; + Name_Pragma : constant Name_Id := N + 478; + Name_Private : constant Name_Id := N + 479; + Name_Procedure : constant Name_Id := N + 480; + Name_Raise : constant Name_Id := N + 481; + Name_Record : constant Name_Id := N + 482; + Name_Rem : constant Name_Id := N + 483; + Name_Renames : constant Name_Id := N + 484; + Name_Return : constant Name_Id := N + 485; + Name_Reverse : constant Name_Id := N + 486; + Name_Select : constant Name_Id := N + 487; + Name_Separate : constant Name_Id := N + 488; + Name_Subtype : constant Name_Id := N + 489; + Name_Task : constant Name_Id := N + 490; + Name_Terminate : constant Name_Id := N + 491; + Name_Then : constant Name_Id := N + 492; + Name_Type : constant Name_Id := N + 493; + Name_Use : constant Name_Id := N + 494; + Name_When : constant Name_Id := N + 495; + Name_While : constant Name_Id := N + 496; + Name_With : constant Name_Id := N + 497; + Name_Xor : constant Name_Id := N + 498; -- Names of intrinsic subprograms -- Note: Asm is missing from this list, since Asm is a legitimate -- convention name. - First_Intrinsic_Name : constant Name_Id := N + 497; - Name_Divide : constant Name_Id := N + 497; - Name_Enclosing_Entity : constant Name_Id := N + 498; - Name_Exception_Information : constant Name_Id := N + 499; - Name_Exception_Message : constant Name_Id := N + 500; - Name_Exception_Name : constant Name_Id := N + 501; - Name_File : constant Name_Id := N + 502; - Name_Import_Address : constant Name_Id := N + 503; - Name_Import_Largest_Value : constant Name_Id := N + 504; - Name_Import_Value : constant Name_Id := N + 505; - Name_Is_Negative : constant Name_Id := N + 506; - Name_Line : constant Name_Id := N + 507; - Name_Rotate_Left : constant Name_Id := N + 508; - Name_Rotate_Right : constant Name_Id := N + 509; - Name_Shift_Left : constant Name_Id := N + 510; - Name_Shift_Right : constant Name_Id := N + 511; - Name_Shift_Right_Arithmetic : constant Name_Id := N + 512; - Name_Source_Location : constant Name_Id := N + 513; - Name_Unchecked_Conversion : constant Name_Id := N + 514; - Name_Unchecked_Deallocation : constant Name_Id := N + 515; - Last_Intrinsic_Name : constant Name_Id := N + 515; + First_Intrinsic_Name : constant Name_Id := N + 499; + Name_Divide : constant Name_Id := N + 499; + Name_Enclosing_Entity : constant Name_Id := N + 500; + Name_Exception_Information : constant Name_Id := N + 501; + Name_Exception_Message : constant Name_Id := N + 502; + Name_Exception_Name : constant Name_Id := N + 503; + Name_File : constant Name_Id := N + 504; + Name_Import_Address : constant Name_Id := N + 505; + Name_Import_Largest_Value : constant Name_Id := N + 506; + Name_Import_Value : constant Name_Id := N + 507; + Name_Is_Negative : constant Name_Id := N + 508; + Name_Line : constant Name_Id := N + 509; + Name_Rotate_Left : constant Name_Id := N + 510; + Name_Rotate_Right : constant Name_Id := N + 511; + Name_Shift_Left : constant Name_Id := N + 512; + Name_Shift_Right : constant Name_Id := N + 513; + Name_Shift_Right_Arithmetic : constant Name_Id := N + 514; + Name_Source_Location : constant Name_Id := N + 515; + Name_Unchecked_Conversion : constant Name_Id := N + 516; + Name_Unchecked_Deallocation : constant Name_Id := N + 517; + Last_Intrinsic_Name : constant Name_Id := N + 517; -- Reserved words used only in Ada 95 - First_95_Reserved_Word : constant Name_Id := N + 516; - Name_Abstract : constant Name_Id := N + 516; - Name_Aliased : constant Name_Id := N + 517; - Name_Protected : constant Name_Id := N + 518; - Name_Until : constant Name_Id := N + 519; - Name_Requeue : constant Name_Id := N + 520; - Name_Tagged : constant Name_Id := N + 521; - Last_95_Reserved_Word : constant Name_Id := N + 521; + First_95_Reserved_Word : constant Name_Id := N + 518; + Name_Abstract : constant Name_Id := N + 518; + Name_Aliased : constant Name_Id := N + 519; + Name_Protected : constant Name_Id := N + 520; + Name_Until : constant Name_Id := N + 521; + Name_Requeue : constant Name_Id := N + 522; + Name_Tagged : constant Name_Id := N + 523; + Last_95_Reserved_Word : constant Name_Id := N + 523; subtype Ada_95_Reserved_Words is Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word; -- Miscellaneous names used in semantic checking - Name_Raise_Exception : constant Name_Id := N + 522; + Name_Raise_Exception : constant Name_Id := N + 524; -- Additional reserved words in GNAT Project Files -- Note that Name_External is already previously declared - Name_Binder : constant Name_Id := N + 523; - Name_Builder : constant Name_Id := N + 524; - Name_Compiler : constant Name_Id := N + 525; - Name_Cross_Reference : constant Name_Id := N + 526; - Name_Default_Switches : constant Name_Id := N + 527; - Name_Exec_Dir : constant Name_Id := N + 528; - Name_Extends : constant Name_Id := N + 529; - Name_Finder : constant Name_Id := N + 530; - Name_Gnatls : constant Name_Id := N + 531; - Name_Gnatstub : constant Name_Id := N + 532; - Name_Implementation : constant Name_Id := N + 533; - Name_Implementation_Exceptions : constant Name_Id := N + 534; - Name_Implementation_Suffix : constant Name_Id := N + 535; - Name_Languages : constant Name_Id := N + 536; - Name_Library_Dir : constant Name_Id := N + 537; - Name_Library_Elaboration : constant Name_Id := N + 538; - Name_Library_Kind : constant Name_Id := N + 539; - Name_Library_Name : constant Name_Id := N + 540; - Name_Library_Version : constant Name_Id := N + 541; - Name_Linker : constant Name_Id := N + 542; - Name_Naming : constant Name_Id := N + 543; - Name_Object_Dir : constant Name_Id := N + 544; - Name_Project : constant Name_Id := N + 545; - Name_Separate_Suffix : constant Name_Id := N + 546; - Name_Source_Dirs : constant Name_Id := N + 547; - Name_Source_Files : constant Name_Id := N + 548; - Name_Source_List_File : constant Name_Id := N + 549; - Name_Specification : constant Name_Id := N + 550; - Name_Specification_Exceptions : constant Name_Id := N + 551; - Name_Specification_Suffix : constant Name_Id := N + 552; - Name_Switches : constant Name_Id := N + 553; + Name_Binder : constant Name_Id := N + 525; + Name_Builder : constant Name_Id := N + 526; + Name_Compiler : constant Name_Id := N + 527; + Name_Cross_Reference : constant Name_Id := N + 528; + Name_Default_Switches : constant Name_Id := N + 529; + Name_Exec_Dir : constant Name_Id := N + 530; + Name_Extends : constant Name_Id := N + 531; + Name_Finder : constant Name_Id := N + 532; + Name_Gnatls : constant Name_Id := N + 533; + Name_Gnatstub : constant Name_Id := N + 534; + Name_Implementation : constant Name_Id := N + 535; + Name_Implementation_Exceptions : constant Name_Id := N + 536; + Name_Implementation_Suffix : constant Name_Id := N + 537; + Name_Languages : constant Name_Id := N + 538; + Name_Library_Dir : constant Name_Id := N + 539; + Name_Library_Elaboration : constant Name_Id := N + 540; + Name_Library_Kind : constant Name_Id := N + 541; + Name_Library_Name : constant Name_Id := N + 542; + Name_Library_Version : constant Name_Id := N + 543; + Name_Linker : constant Name_Id := N + 544; + Name_Naming : constant Name_Id := N + 545; + Name_Object_Dir : constant Name_Id := N + 546; + Name_Project : constant Name_Id := N + 547; + Name_Separate_Suffix : constant Name_Id := N + 548; + Name_Source_Dirs : constant Name_Id := N + 549; + Name_Source_Files : constant Name_Id := N + 550; + Name_Source_List_File : constant Name_Id := N + 551; + Name_Specification : constant Name_Id := N + 552; + Name_Specification_Exceptions : constant Name_Id := N + 553; + Name_Specification_Suffix : constant Name_Id := N + 554; + Name_Switches : constant Name_Id := N + 555; -- Mark last defined name for consistency check in Snames body - Last_Predefined_Name : constant Name_Id := N + 553; + Last_Predefined_Name : constant Name_Id := N + 555; subtype Any_Operator_Name is Name_Id range First_Operator_Name .. Last_Operator_Name; @@ -956,8 +967,6 @@ package Snames is Attribute_Machine_Rounds, Attribute_Machine_Size, Attribute_Mantissa, - Attribute_Max_Interrupt_Priority, - Attribute_Max_Priority, Attribute_Max_Size_In_Storage_Elements, Attribute_Maximum_Alignment, Attribute_Mechanism_Code, @@ -989,7 +998,6 @@ package Snames is Attribute_Storage_Unit, Attribute_Tag, Attribute_Terminated, - Attribute_Tick, Attribute_To_Address, Attribute_Type_Class, Attribute_UET_Address, @@ -1079,24 +1087,19 @@ package Snames is -- The remaining conventions are foreign language conventions - Convention_Assembler, - Convention_C, + Convention_Assembler, -- also Asm, Assembly + Convention_C, -- also Default, External Convention_COBOL, Convention_CPP, Convention_Fortran, Convention_Java, - Convention_Stdcall, + Convention_Stdcall, -- also DLL, Win32 Convention_Stubbed); - -- Note: Conventions C_Pass_By_Copy, External, and Default are all - -- treated as synonyms for convention C (with an appropriate flag - -- being set in a record type in the case of C_Pass_By_Copy). See - -- processing in Sem_Prag for details. - - -- Note: convention Win32 has the same effect as convention Stdcall - -- and as a special exception to normal rules is considered to be - -- conformant with convention Stdcall. Therefore if the convention - -- Win32 is encountered, it is translated into Convention_Stdcall. + -- Note: Convention C_Pass_By_Copy is allowed only for record + -- types (where it is treated like C except that the appropriate + -- flag is set in the record type). Recognizion of this convention + -- is specially handled in Sem_Prag. for Convention_Id'Size use 8; -- Plenty of space for expansion @@ -1124,6 +1127,7 @@ package Snames is Pragma_Ada_95, Pragma_C_Pass_By_Copy, Pragma_Component_Alignment, + Pragma_Convention_Identifier, Pragma_Discard_Names, Pragma_Elaboration_Checks, Pragma_Eliminate, @@ -1239,6 +1243,8 @@ package Snames is Pragma_Title, Pragma_Unchecked_Union, Pragma_Unimplemented_Unit, + Pragma_Universal_Data, + Pragma_Unreferenced, Pragma_Unreserve_All_Interrupts, Pragma_Volatile, Pragma_Volatile_Components, @@ -1330,7 +1336,8 @@ package Snames is function Get_Convention_Id (N : Name_Id) return Convention_Id; -- Returns Id of language convention corresponding to given name. It is an - -- to call this function with a name that is not the name of a check. + -- to call this function with a name that is not the name of a convention, + -- or one previously given in a call to Record_Convention_Identifier. function Get_Check_Id (N : Name_Id) return Check_Id; -- Returns Id of suppress check corresponding to given name. It is an error @@ -1354,9 +1361,16 @@ package Snames is function Get_Task_Dispatching_Policy_Id (N : Name_Id) return Task_Dispatching_Policy_Id; - -- Returns Id of task dispatching policy corresponding to given name. It - -- is an error to call this function with a name that is not the name - -- of a check. + -- Returns Id of task dispatching policy corresponding to given name. + -- It is an error to call this function with a name that is not the + -- name of a check. + + procedure Record_Convention_Identifier + (Id : Name_Id; + Convention : Convention_Id); + -- A call to this procedure, resulting from an occurrence of a pragma + -- Convention_Identifier, records that from now on an occurrence of + -- Id will be recognized as a name for the specified convention. private pragma Inline (Is_Attribute_Name); diff --git a/gcc/ada/snames.h b/gcc/ada/snames.h index 1312f64f575..746ce7d427f 100644 --- a/gcc/ada/snames.h +++ b/gcc/ada/snames.h @@ -8,7 +8,7 @@ * * * $Revision$ * * - * Copyright (C) 1992-2001 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- * @@ -101,87 +101,84 @@ extern char Get_Attribute_Id PARAMS ((int)); #define Attr_Machine_Rounds 49 #define Attr_Machine_Size 50 #define Attr_Mantissa 51 -#define Attr_Max_Interrupt_Priority 52 -#define Attr_Max_Priority 53 -#define Attr_Max_Size_In_Storage_Elements 54 -#define Attr_Maximum_Alignment 55 -#define Attr_Mechanism_Code 56 -#define Attr_Model_Emin 57 -#define Attr_Model_Epsilon 58 -#define Attr_Model_Mantissa 59 -#define Attr_Model_Small 60 -#define Attr_Modulus 61 -#define Attr_Null_Parameter 62 -#define Attr_Object_Size 63 -#define Attr_Partition_ID 64 -#define Attr_Passed_By_Reference 65 -#define Attr_Pos 66 -#define Attr_Position 67 -#define Attr_Range 68 -#define Attr_Range_Length 69 -#define Attr_Round 70 -#define Attr_Safe_Emax 71 -#define Attr_Safe_First 72 -#define Attr_Safe_Large 73 -#define Attr_Safe_Last 74 -#define Attr_Safe_Small 75 -#define Attr_Scale 76 -#define Attr_Scaling 77 -#define Attr_Signed_Zeros 78 -#define Attr_Size 79 -#define Attr_Small 80 -#define Attr_Storage_Size 81 -#define Attr_Storage_Unit 82 -#define Attr_Tag 83 -#define Attr_Terminated 84 -#define Attr_Tick 85 -#define Attr_To_Address 86 -#define Attr_Type_Class 87 -#define Attr_UET_Address 88 -#define Attr_Unbiased_Rounding 89 -#define Attr_Unchecked_Access 90 -#define Attr_Universal_Literal_String 91 -#define Attr_Unrestricted_Access 92 -#define Attr_VADS_Size 93 -#define Attr_Val 94 -#define Attr_Valid 95 -#define Attr_Value_Size 96 -#define Attr_Version 97 -#define Attr_Wide_Character_Size 98 -#define Attr_Wide_Width 99 -#define Attr_Width 100 -#define Attr_Word_Size 101 +#define Attr_Max_Size_In_Storage_Elements 52 +#define Attr_Maximum_Alignment 53 +#define Attr_Mechanism_Code 54 +#define Attr_Model_Emin 55 +#define Attr_Model_Epsilon 56 +#define Attr_Model_Mantissa 57 +#define Attr_Model_Small 58 +#define Attr_Modulus 59 +#define Attr_Null_Parameter 60 +#define Attr_Object_Size 61 +#define Attr_Partition_ID 62 +#define Attr_Passed_By_Reference 63 +#define Attr_Pos 64 +#define Attr_Position 65 +#define Attr_Range 66 +#define Attr_Range_Length 67 +#define Attr_Round 68 +#define Attr_Safe_Emax 69 +#define Attr_Safe_First 70 +#define Attr_Safe_Large 71 +#define Attr_Safe_Last 72 +#define Attr_Safe_Small 73 +#define Attr_Scale 74 +#define Attr_Scaling 75 +#define Attr_Signed_Zeros 76 +#define Attr_Size 77 +#define Attr_Small 78 +#define Attr_Storage_Size 79 +#define Attr_Storage_Unit 80 +#define Attr_Tag 81 +#define Attr_Terminated 82 +#define Attr_To_Address 83 +#define Attr_Type_Class 84 +#define Attr_UET_Address 85 +#define Attr_Unbiased_Rounding 86 +#define Attr_Unchecked_Access 87 +#define Attr_Universal_Literal_String 88 +#define Attr_Unrestricted_Access 89 +#define Attr_VADS_Size 90 +#define Attr_Val 91 +#define Attr_Valid 92 +#define Attr_Value_Size 93 +#define Attr_Version 94 +#define Attr_Wide_Character_Size 95 +#define Attr_Wide_Width 96 +#define Attr_Width 97 +#define Attr_Word_Size 98 -#define Attr_Adjacent 102 -#define Attr_Ceiling 103 -#define Attr_Copy_Sign 104 -#define Attr_Floor 105 -#define Attr_Fraction 106 -#define Attr_Image 107 -#define Attr_Input 108 -#define Attr_Machine 109 -#define Attr_Max 110 -#define Attr_Min 111 -#define Attr_Model 112 -#define Attr_Pred 113 -#define Attr_Remainder 114 -#define Attr_Rounding 115 -#define Attr_Succ 116 -#define Attr_Truncation 117 -#define Attr_Value 118 -#define Attr_Wide_Image 119 -#define Attr_Wide_Value 120 +#define Attr_Adjacent 99 +#define Attr_Ceiling 100 +#define Attr_Copy_Sign 101 +#define Attr_Floor 102 +#define Attr_Fraction 103 +#define Attr_Image 104 +#define Attr_Input 105 +#define Attr_Machine 106 +#define Attr_Max 107 +#define Attr_Min 108 +#define Attr_Model 109 +#define Attr_Pred 110 +#define Attr_Remainder 111 +#define Attr_Rounding 112 +#define Attr_Succ 113 +#define Attr_Truncation 114 +#define Attr_Value 115 +#define Attr_Wide_Image 116 +#define Attr_Wide_Value 117 -#define Attr_Output 121 -#define Attr_Read 122 -#define Attr_Write 123 +#define Attr_Output 118 +#define Attr_Read 119 +#define Attr_Write 120 -#define Attr_Elab_Body 124 -#define Attr_Elab_Spec 125 -#define Attr_Storage_Pool 126 +#define Attr_Elab_Body 121 +#define Attr_Elab_Spec 122 +#define Attr_Storage_Pool 123 -#define Attr_Base 127 -#define Attr_Class 128 +#define Attr_Base 124 +#define Attr_Class 125 /* Define the function to check if a Name_Id value is a valid pragma */ @@ -204,131 +201,134 @@ extern char Get_Pragma_Id PARAMS ((int)); #define Pragma_Ada_95 1 #define Pragma_C_Pass_By_Copy 2 #define Pragma_Component_Alignment 3 -#define Pragma_Discard_Names 4 -#define Pragma_Elaboration_Checking 5 -#define Pragma_Eliminate 6 -#define Pragma_Extend_System 7 -#define Pragma_Extensions_Allowed 8 -#define Pragma_External_Name_Casing 9 -#define Pragma_Float_Representation 10 -#define Pragma_Initialize 11 -#define Pragma_License 12 -#define Pragma_Locking_Policy 13 -#define Pragma_Long_Float 14 -#define Pragma_No_Run_Time 15 -#define Pragma_Normalize_Scalars 16 -#define Pragma_Polling 17 -#define Pragma_Propagate_Exceptions 18 -#define Pragma_Queuing_Policy 19 -#define Pragma_Ravenscar 20 -#define Pragma_Restricted_Run_Time 21 -#define Pragma_Restrictions 22 -#define Pragma_Reviewable 23 -#define Pragma_Source_File_Name 24 -#define Pragma_Style_Checks 25 -#define Pragma_Suppress 26 -#define Pragma_Task_Dispatching_Policy 27 -#define Pragma_Unsuppress 28 -#define Pragma_Use_VADS_Size 29 -#define Pragma_Validity_Checks 30 -#define Pragma_Warnings 31 +#define Pragma_Convention_Identifier 4 +#define Pragma_Discard_Names 5 +#define Pragma_Elaboration_Checking 6 +#define Pragma_Eliminate 7 +#define Pragma_Extend_System 8 +#define Pragma_Extensions_Allowed 9 +#define Pragma_External_Name_Casing 10 +#define Pragma_Float_Representation 11 +#define Pragma_Initialize 12 +#define Pragma_License 13 +#define Pragma_Locking_Policy 14 +#define Pragma_Long_Float 15 +#define Pragma_No_Run_Time 16 +#define Pragma_Normalize_Scalars 17 +#define Pragma_Polling 18 +#define Pragma_Propagate_Exceptions 19 +#define Pragma_Queuing_Policy 20 +#define Pragma_Ravenscar 21 +#define Pragma_Restricted_Run_Time 22 +#define Pragma_Restrictions 23 +#define Pragma_Reviewable 24 +#define Pragma_Source_File_Name 25 +#define Pragma_Style_Checks 26 +#define Pragma_Suppress 27 +#define Pragma_Task_Dispatching_Policy 28 +#define Pragma_Unsuppress 29 +#define Pragma_Use_VADS_Size 30 +#define Pragma_Validity_Checks 31 +#define Pragma_Warnings 32 /* Remaining pragmas */ -#define Pragma_Abort_Defer 32 -#define Pragma_All_Calls_Remote 33 -#define Pragma_Annotate 34 -#define Pragma_Assert 35 -#define Pragma_Asynchronous 36 -#define Pragma_Atomic 37 -#define Pragma_Atomic_Components 38 -#define Pragma_Attach_Handler 39 -#define Pragma_Comment 40 -#define Pragma_Common_Object 41 -#define Pragma_Complex_Representation 42 -#define Pragma_Controlled 43 -#define Pragma_Convention 44 -#define Pragma_CPP_Class 45 -#define Pragma_CPP_Constructor 46 -#define Pragma_CPP_Virtual 47 -#define Pragma_CPP_Vtable 48 -#define Pragma_Debug 49 -#define Pragma_Elaborate 50 -#define Pragma_Elaborate_All 51 -#define Pragma_Elaborate_Body 52 -#define Pragma_Export 53 -#define Pragma_Export_Exception 54 -#define Pragma_Export_Function 55 -#define Pragma_Export_Object 56 -#define Pragma_Export_Procedure 57 -#define Pragma_Export_Valued_Procedure 58 -#define Pragma_External 59 -#define Pragma_Finalize_Storage_Only 60 -#define Pragma_Ident 61 -#define Pragma_Import 62 -#define Pragma_Import_Exception 63 -#define Pragma_Import_Function 64 -#define Pragma_Import_Object 65 -#define Pragma_Import_Procedure 66 -#define Pragma_Import_Valued_Procedure 67 -#define Pragma_Inline 68 -#define Pragma_Inline_Always 69 -#define Pragma_Inline_Generic 70 -#define Pragma_Inspection_Point 71 -#define Pragma_Interface 72 -#define Pragma_Interface_Name 73 -#define Pragma_Interrupt_Handler 74 -#define Pragma_Interrupt_Priority 75 -#define Pragma_Java_Constructor 76 -#define Pragma_Java_Interface 77 -#define Pragma_Link_With 78 -#define Pragma_Linker_Alias 79 -#define Pragma_Linker_Options 80 -#define Pragma_Linker_Section 81 -#define Pragma_List 82 -#define Pragma_Machine_Attribute 83 -#define Pragma_Main 84 -#define Pragma_Main_Storage 85 -#define Pragma_Memory_Size 86 -#define Pragma_No_Return 87 -#define Pragma_Optimize 88 -#define Pragma_Pack 89 -#define Pragma_Page 90 -#define Pragma_Passive 91 -#define Pragma_Preelaborate 92 -#define Pragma_Priority 93 -#define Pragma_Psect_Object 94 -#define Pragma_Pure 95 -#define Pragma_Pure_Function 96 -#define Pragma_Remote_Call_Interface 97 -#define Pragma_Remote_Types 98 -#define Pragma_Share_Generic 99 -#define Pragma_Shared 100 -#define Pragma_Shared_Passive 101 -#define Pragma_Source_Reference 102 -#define Pragma_Stream_Convert 103 -#define Pragma_Subtitle 104 -#define Pragma_Suppress_All 105 -#define Pragma_Suppress_Debug_Info 106 -#define Pragma_Suppress_Initialization 107 -#define Pragma_System_Name 108 -#define Pragma_Task_Info 109 -#define Pragma_Task_Name 110 -#define Pragma_Task_Storage 111 -#define Pragma_Time_Slice 112 -#define Pragma_Title 113 -#define Pragma_Unchecked_Union 114 -#define Pragma_Unimplemented_Unit 115 -#define Pragma_Unreserve_All_Interrupts 116 -#define Pragma_Volatile 117 -#define Pragma_Volatile_Components 118 -#define Pragma_Weak_External 119 +#define Pragma_Abort_Defer 33 +#define Pragma_All_Calls_Remote 34 +#define Pragma_Annotate 35 +#define Pragma_Assert 36 +#define Pragma_Asynchronous 37 +#define Pragma_Atomic 38 +#define Pragma_Atomic_Components 39 +#define Pragma_Attach_Handler 40 +#define Pragma_Comment 41 +#define Pragma_Common_Object 42 +#define Pragma_Complex_Representation 43 +#define Pragma_Controlled 44 +#define Pragma_Convention 45 +#define Pragma_CPP_Class 46 +#define Pragma_CPP_Constructor 47 +#define Pragma_CPP_Virtual 48 +#define Pragma_CPP_Vtable 49 +#define Pragma_Debug 50 +#define Pragma_Elaborate 51 +#define Pragma_Elaborate_All 52 +#define Pragma_Elaborate_Body 53 +#define Pragma_Export 54 +#define Pragma_Export_Exception 55 +#define Pragma_Export_Function 56 +#define Pragma_Export_Object 57 +#define Pragma_Export_Procedure 58 +#define Pragma_Export_Valued_Procedure 59 +#define Pragma_External 60 +#define Pragma_Finalize_Storage_Only 61 +#define Pragma_Ident 62 +#define Pragma_Import 63 +#define Pragma_Import_Exception 64 +#define Pragma_Import_Function 65 +#define Pragma_Import_Object 66 +#define Pragma_Import_Procedure 67 +#define Pragma_Import_Valued_Procedure 68 +#define Pragma_Inline 69 +#define Pragma_Inline_Always 70 +#define Pragma_Inline_Generic 71 +#define Pragma_Inspection_Point 72 +#define Pragma_Interface 73 +#define Pragma_Interface_Name 74 +#define Pragma_Interrupt_Handler 75 +#define Pragma_Interrupt_Priority 76 +#define Pragma_Java_Constructor 77 +#define Pragma_Java_Interface 78 +#define Pragma_Link_With 79 +#define Pragma_Linker_Alias 80 +#define Pragma_Linker_Options 81 +#define Pragma_Linker_Section 82 +#define Pragma_List 83 +#define Pragma_Machine_Attribute 84 +#define Pragma_Main 85 +#define Pragma_Main_Storage 86 +#define Pragma_Memory_Size 87 +#define Pragma_No_Return 88 +#define Pragma_Optimize 89 +#define Pragma_Pack 90 +#define Pragma_Page 91 +#define Pragma_Passive 92 +#define Pragma_Preelaborate 93 +#define Pragma_Priority 94 +#define Pragma_Psect_Object 95 +#define Pragma_Pure 96 +#define Pragma_Pure_Function 97 +#define Pragma_Remote_Call_Interface 98 +#define Pragma_Remote_Types 99 +#define Pragma_Share_Generic 100 +#define Pragma_Shared 101 +#define Pragma_Shared_Passive 102 +#define Pragma_Source_Reference 103 +#define Pragma_Stream_Convert 104 +#define Pragma_Subtitle 105 +#define Pragma_Suppress_All 106 +#define Pragma_Suppress_Debug_Info 107 +#define Pragma_Suppress_Initialization 108 +#define Pragma_System_Name 109 +#define Pragma_Task_Info 110 +#define Pragma_Task_Name 111 +#define Pragma_Task_Storage 112 +#define Pragma_Time_Slice 113 +#define Pragma_Title 114 +#define Pragma_Unchecked_Union 115 +#define Pragma_Unimplemented_Unit 116 +#define Pragma_Universal_Data 117 +#define Pragma_Unreferenced 118 +#define Pragma_Unreserve_All_Interrupts 119 +#define Pragma_Volatile 120 +#define Pragma_Volatile_Components 121 +#define Pragma_Weak_External 122 /* The following are deliberately out of alphabetical order, see Snames */ -#define Pragma_AST_Entry 120 -#define Pragma_Storage_Size 121 -#define Pragma_Storage_Unit 122 +#define Pragma_AST_Entry 123 +#define Pragma_Storage_Size 124 +#define Pragma_Storage_Unit 125 /* Define the numeric values for the conventions. */ diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index e7c1a6a0de9..ab2b585da58 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -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. -- -- -- -- 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- -- @@ -28,6 +28,7 @@ with Atree; use Atree; with Casing; use Casing; +with Csets; use Csets; with Debug; use Debug; with Einfo; use Einfo; with Lib; use Lib; @@ -38,7 +39,7 @@ with Output; use Output; with Rtsfind; use Rtsfind; with Sinfo; use Sinfo; with Sinput; use Sinput; -with Sinput.L; use Sinput.L; +with Sinput.D; use Sinput.D; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; @@ -81,6 +82,55 @@ package body Sprint is -- Keep track of freeze indent level (controls blank lines before -- procedures within expression freeze actions) + ------------------------------- + -- Operator Precedence Table -- + ------------------------------- + + -- This table is used to decide whether a subexpression needs to be + -- parenthesized. The rule is that if an operand of an operator (which + -- for this purpose includes AND THEN and OR ELSE) is itself an operator + -- with a lower precedence than the operator (or equal precedence if + -- appearing as the right operand), then parentheses are required. + + Op_Prec : array (N_Subexpr) of Short_Short_Integer := + (N_Op_And => 1, + N_Op_Or => 1, + N_Op_Xor => 1, + N_And_Then => 1, + N_Or_Else => 1, + + N_In => 2, + N_Not_In => 2, + N_Op_Eq => 2, + N_Op_Ge => 2, + N_Op_Gt => 2, + N_Op_Le => 2, + N_Op_Lt => 2, + N_Op_Ne => 2, + + N_Op_Add => 3, + N_Op_Concat => 3, + N_Op_Subtract => 3, + N_Op_Plus => 3, + N_Op_Minus => 3, + + N_Op_Divide => 4, + N_Op_Mod => 4, + N_Op_Rem => 4, + N_Op_Multiply => 4, + + N_Op_Expon => 5, + N_Op_Abs => 5, + N_Op_Not => 5, + + others => 6); + + procedure Sprint_Left_Opnd (N : Node_Id); + -- Print left operand of operator, parenthesizing if necessary + + procedure Sprint_Right_Opnd (N : Node_Id); + -- Print right operand of operator, parenthesizing if necessary + ----------------------- -- Local Subprograms -- ----------------------- @@ -102,8 +152,9 @@ package body Sprint is procedure Indent_End; -- Decrease indentation level - procedure Print_Eol; - -- Terminate current line in line buffer + procedure Print_Debug_Line (S : String); + -- Used to print output lines in Debug_Generated_Code mode (this is used + -- as the argument for a call to Set_Special_Output in package Output). procedure Process_TFAI_RR_Flags (Nod : Node_Id); -- Given a divide, multiplication or division node, check the flags @@ -133,6 +184,9 @@ package body Sprint is -- Like Write_Char, except that if C is non-blank, Set_Debug_Sloc is -- called to ensure that the current node has a proper Sloc set. + procedure Write_Condition_And_Reason (Node : Node_Id); + -- Write Condition and Reason codes of Raise_xxx_Error node + procedure Write_Discr_Specs (N : Node_Id); -- Output discriminant specification for node, which is any of the type -- declarations that can have discriminants. @@ -269,50 +323,37 @@ package body Sprint is end Indent_End; -------- - -- PG -- + -- pg -- -------- - procedure PG (Node : Node_Id) is + procedure pg (Node : Node_Id) is begin Dump_Generated_Only := True; Dump_Original_Only := False; Sprint_Node (Node); - Print_Eol; - end PG; + Write_Eol; + end pg; -------- - -- PO -- + -- po -- -------- - procedure PO (Node : Node_Id) is + procedure po (Node : Node_Id) is begin Dump_Generated_Only := False; Dump_Original_Only := True; Sprint_Node (Node); - Print_Eol; - end PO; + Write_Eol; + end po; - --------------- - -- Print_Eol -- - --------------- + ---------------------- + -- Print_Debug_Line -- + ---------------------- - procedure Print_Eol is + procedure Print_Debug_Line (S : String) is begin - -- If we are writing a debug source file, then grab it from the - -- Output buffer, and reset the column counter (the routines in - -- Output never actually write any output for us in this mode, - -- they just build line images in Buffer). - - if Debug_Generated_Code then - Write_Debug_Line (Buffer (1 .. Natural (Column) - 1), Debug_Sloc); - Column := 1; - - -- In normal mode, we call Write_Eol to write the line normally - - else - Write_Eol; - end if; - end Print_Eol; + Write_Debug_Line (S, Debug_Sloc); + end Print_Debug_Line; --------------------------- -- Process_TFAI_RR_Flags -- @@ -330,16 +371,16 @@ package body Sprint is end Process_TFAI_RR_Flags; -------- - -- PS -- + -- ps -- -------- - procedure PS (Node : Node_Id) is + procedure ps (Node : Node_Id) is begin Dump_Generated_Only := False; Dump_Original_Only := False; Sprint_Node (Node); - Print_Eol; - end PS; + Write_Eol; + end ps; -------------------- -- Set_Debug_Sloc -- @@ -366,13 +407,13 @@ package body Sprint is Col : constant Int := Column; begin - Print_Eol; + Write_Eol; while Col > Column loop Write_Char ('-'); end loop; - Print_Eol; + Write_Eol; end Underline; -- Start of processing for Tree_Dump. @@ -391,13 +432,13 @@ package body Sprint is if Debug_Flag_Z then Debug_Flag_Z := False; - Print_Eol; - Print_Eol; + Write_Eol; + Write_Eol; Write_Str ("Source recreated from tree of Standard (spec)"); Underline; Sprint_Node (Standard_Package_Node); - Print_Eol; - Print_Eol; + Write_Eol; + Write_Eol; end if; if Debug_Flag_S or Dump_Generated_Only or Dump_Original_Only then @@ -418,10 +459,12 @@ package body Sprint is -- If we are generating debug files, setup to write them if Debug_Generated_Code then + Set_Special_Output (Print_Debug_Line'Access); Create_Debug_Source (Source_Index (U), Debug_Sloc); Sprint_Node (Cunit (U)); - Print_Eol; + Write_Eol; Close_Debug_Source; + Set_Special_Output (null); -- Normal output to standard output file @@ -495,6 +538,26 @@ package body Sprint is Indent_End; end Sprint_Indented_List; + --------------------- + -- Sprint_Left_Opnd -- + --------------------- + + procedure Sprint_Left_Opnd (N : Node_Id) is + Opnd : constant Node_Id := Left_Opnd (N); + + begin + if Paren_Count (Opnd) /= 0 + or else Op_Prec (Nkind (Opnd)) >= Op_Prec (Nkind (N)) + then + Sprint_Node (Opnd); + + else + Write_Char ('('); + Sprint_Node (Opnd); + Write_Char (')'); + end if; + end Sprint_Left_Opnd; + ----------------- -- Sprint_Node -- ----------------- @@ -722,9 +785,9 @@ package body Sprint is end if; when N_And_Then => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Str_Sloc (" and then "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_At_Clause => Write_Indent_Str_Sloc ("for "); @@ -1466,9 +1529,9 @@ package body Sprint is end if; when N_In => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Str_Sloc (" in "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Incomplete_Type_Declaration => Write_Indent_Str_Sloc ("type "); @@ -1565,9 +1628,9 @@ package body Sprint is Sprint_Node (Expression (Node)); when N_Not_In => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Str_Sloc (" not in "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Null => Write_Str_With_Col_Check_Sloc ("null"); @@ -1648,108 +1711,108 @@ package body Sprint is when N_Op_Abs => Write_Operator (Node, "abs "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Add => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Operator (Node, " + "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_And => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Operator (Node, " and "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Concat => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Operator (Node, " & "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Divide => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Char (' '); Process_TFAI_RR_Flags (Node); Write_Operator (Node, "/ "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Eq => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Operator (Node, " = "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Expon => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Operator (Node, " ** "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Ge => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Operator (Node, " >= "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Gt => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Operator (Node, " > "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Le => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Operator (Node, " <= "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Lt => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Operator (Node, " < "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Minus => Write_Operator (Node, "-"); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Mod => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); if Treat_Fixed_As_Integer (Node) then Write_Str (" #"); end if; Write_Operator (Node, " mod "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Multiply => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Char (' '); Process_TFAI_RR_Flags (Node); Write_Operator (Node, "* "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Ne => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Operator (Node, " /= "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Not => Write_Operator (Node, "not "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Or => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Operator (Node, " or "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Plus => Write_Operator (Node, "+"); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Rem => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); if Treat_Fixed_As_Integer (Node) then Write_Str (" #"); end if; Write_Operator (Node, " rem "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Shift => Set_Debug_Sloc; @@ -1762,14 +1825,14 @@ package body Sprint is Write_Char (')'); when N_Op_Subtract => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Operator (Node, " - "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Op_Xor => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Operator (Node, " xor "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Operator_Symbol => Write_Name_With_Col_Check_Sloc (Chars (Node)); @@ -1780,9 +1843,9 @@ package body Sprint is Sprint_Opt_Node (Real_Range_Specification (Node)); when N_Or_Else => - Sprint_Node (Left_Opnd (Node)); + Sprint_Left_Opnd (Node); Write_Str_Sloc (" or else "); - Sprint_Node (Right_Opnd (Node)); + Sprint_Right_Opnd (Node); when N_Others_Choice => if All_Others (Node) then @@ -1991,7 +2054,20 @@ package body Sprint is when N_Qualified_Expression => Sprint_Node (Subtype_Mark (Node)); Write_Char_Sloc ('''); - Sprint_Node (Expression (Node)); + + -- Print expression, make sure we have at least one level of + -- parentheses around the expression. For cases of qualified + -- expressions in the source, this is always the case, but + -- for generated qualifications, there may be no explicit + -- parentheses present. + + if Paren_Count (Expression (Node)) /= 0 then + Sprint_Node (Expression (Node)); + else + Write_Char ('('); + Sprint_Node (Expression (Node)); + Write_Char (')'); + end if; when N_Raise_Constraint_Error => @@ -2006,35 +2082,37 @@ package body Sprint is end if; Write_Str_With_Col_Check_Sloc ("[constraint_error"); - - if Present (Condition (Node)) then - Write_Str_With_Col_Check (" when "); - Sprint_Node (Condition (Node)); - end if; - - Write_Char (']'); + Write_Condition_And_Reason (Node); when N_Raise_Program_Error => - Write_Indent; - Write_Str_With_Col_Check_Sloc ("[program_error"); - if Present (Condition (Node)) then - Write_Str_With_Col_Check (" when "); - Sprint_Node (Condition (Node)); + -- This node can be used either as a subexpression or as a + -- statement form. The following test is a reasonably reliable + -- way to distinguish the two cases. + + if Is_List_Member (Node) + and then Nkind (Parent (Node)) not in N_Subexpr + then + Write_Indent; end if; - Write_Char (']'); + Write_Str_With_Col_Check_Sloc ("[program_error"); + Write_Condition_And_Reason (Node); when N_Raise_Storage_Error => - Write_Indent; - Write_Str_With_Col_Check_Sloc ("[storage_error"); - if Present (Condition (Node)) then - Write_Str_With_Col_Check (" when "); - Sprint_Node (Condition (Node)); + -- This node can be used either as a subexpression or as a + -- statement form. The following test is a reasonably reliable + -- way to distinguish the two cases. + + if Is_List_Member (Node) + and then Nkind (Parent (Node)) not in N_Subexpr + then + Write_Indent; end if; - Write_Char (']'); + Write_Str_With_Col_Check_Sloc ("[storage_error"); + Write_Condition_And_Reason (Node); when N_Raise_Statement => Write_Indent_Str_Sloc ("raise "); @@ -2248,7 +2326,7 @@ package body Sprint is Write_Indent_Str_Sloc ("separate ("); Sprint_Node (Name (Node)); Write_Char (')'); - Print_Eol; + Write_Eol; Sprint_Node (Proper_Body (Node)); when N_Task_Body => @@ -2381,7 +2459,7 @@ package body Sprint is when N_Unused_At_Start | N_Unused_At_End => Write_Indent_Str ("***** Error, unused node encountered *****"); - Print_Eol; + Write_Eol; when N_Use_Package_Clause => Write_Indent_Str_Sloc ("use "); @@ -2573,6 +2651,26 @@ package body Sprint is end if; end Sprint_Paren_Comma_List; + ---------------------- + -- Sprint_Right_Opnd -- + ---------------------- + + procedure Sprint_Right_Opnd (N : Node_Id) is + Opnd : constant Node_Id := Right_Opnd (N); + + begin + if Paren_Count (Opnd) /= 0 + or else Op_Prec (Nkind (Opnd)) > Op_Prec (Nkind (N)) + then + Sprint_Node (Opnd); + + else + Write_Char ('('); + Sprint_Node (Opnd); + Write_Char (')'); + end if; + end Sprint_Right_Opnd; + --------------------- -- Write_Char_Sloc -- --------------------- @@ -2586,6 +2684,34 @@ package body Sprint is Write_Char (C); end Write_Char_Sloc; + -------------------------------- + -- Write_Condition_And_Reason -- + -------------------------------- + + procedure Write_Condition_And_Reason (Node : Node_Id) is + Image : constant String := RT_Exception_Code'Image + (RT_Exception_Code'Val + (UI_To_Int (Reason (Node)))); + + begin + if Present (Condition (Node)) then + Write_Str_With_Col_Check (" when "); + Sprint_Node (Condition (Node)); + end if; + + Write_Str (" """); + + for J in 4 .. Image'Last loop + if Image (J) = '_' then + Write_Char (' '); + else + Write_Char (Fold_Lower (Image (J))); + end if; + end loop; + + Write_Str ("""]"); + end Write_Condition_And_Reason; + ------------------------ -- Write_Discr_Specs -- ------------------------ @@ -2756,7 +2882,8 @@ package body Sprint is if Indent_Annull_Flag then Indent_Annull_Flag := False; else - Print_Eol; + Write_Eol; + for J in 1 .. Indent loop Write_Char (' '); end loop; @@ -2909,25 +3036,31 @@ package body Sprint is T : Natural := S'Last; begin - if S (F) = ' ' then - Write_Char (' '); - F := F + 1; - end if; + -- If no overflow check, just write string out, and we are done - if S (T) = ' ' then - T := T - 1; - end if; + if not Do_Overflow_Check (N) then + Write_Str_Sloc (S); + + -- If overflow check, we want to surround the operator with curly + -- brackets, but not include spaces within the brackets. + + else + if S (F) = ' ' then + Write_Char (' '); + F := F + 1; + end if; + + if S (T) = ' ' then + T := T - 1; + end if; - if Do_Overflow_Check (N) then Write_Char ('{'); Write_Str_Sloc (S (F .. T)); Write_Char ('}'); - else - Write_Str_Sloc (S); - end if; - if S (S'Last) = ' ' then - Write_Char (' '); + if S (S'Last) = ' ' then + Write_Char (' '); + end if; end if; end Write_Operator; diff --git a/gcc/ada/sprint.ads b/gcc/ada/sprint.ads index d307eb74250..9ef3e0b994f 100644 --- a/gcc/ada/sprint.ads +++ b/gcc/ada/sprint.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.44 $ +-- $Revision$ -- -- --- Copyright (C) 1992-1999, 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- -- @@ -67,7 +67,8 @@ package Sprint is -- Multiply wi Treat_Fixed_As_Integer x #* y -- Multiply wi Rounded_Result x @* y -- Others choice for cleanup when all others - -- Raise xxx error [xxx_error [when condition]] + -- Raise xxx error [xxx_error [when cond]] + -- Raise xxx error with msg [xxx_error [when cond], "msg"] -- Rational literal See UR_Write for details -- Rem wi Treat_Fixed_As_Integer x #rem y -- Reference expression'reference @@ -133,15 +134,18 @@ package Sprint is -- Same as normal Sprint_Node procedure, except that one leading -- blank is output before the node if it is non-empty. - procedure PG (Node : Node_Id); + procedure pg (Node : Node_Id); + pragma Export (Ada, pg); -- Print generated source for node N (like -gnatdg output). This is -- intended only for use from gdb for debugging purposes. - procedure PO (Node : Node_Id); + procedure po (Node : Node_Id); + pragma Export (Ada, po); -- Print original source for node N (like -gnatdo output). This is -- intended only for use from gdb for debugging purposes. - procedure PS (Node : Node_Id); + procedure ps (Node : Node_Id); + pragma Export (Ada, ps); -- Print generated and original source for node N (like -gnatds output). -- This is intended only for use from gdb for debugging purposes. diff --git a/gcc/ada/stringt.adb b/gcc/ada/stringt.adb index b2631ad2c03..84817a9482d 100644 --- a/gcc/ada/stringt.adb +++ b/gcc/ada/stringt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.43 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -80,6 +80,7 @@ package body Stringt is procedure Add_String_To_Name_Buffer (S : String_Id) is Len : constant Natural := Natural (String_Length (S)); + begin for J in 1 .. Len loop Name_Buffer (Name_Len + J) := diff --git a/gcc/ada/stringt.ads b/gcc/ada/stringt.ads index 0d4350ec090..7aa30223729 100644 --- a/gcc/ada/stringt.ads +++ b/gcc/ada/stringt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.39 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -108,10 +108,14 @@ package Stringt is -- Determines if two string literals represent the same string procedure String_To_Name_Buffer (S : String_Id); - -- Place characters of given string in Name_Buffer, setting Name_Len + -- Place characters of given string in Name_Buffer, setting Name_Len. + -- Error if any characters are out of Character range. Does not attempt + -- to do any encoding of any characters. procedure Add_String_To_Name_Buffer (S : String_Id); - -- Append characters of given string to Name_Buffer, updating Name_Len + -- Append characters of given string to Name_Buffer, updating Name_Len. + -- Error if any characters are out of Character range. Does not attempt + -- to do any encoding of any characters. function String_Chars_Address return System.Address; -- Return address of String_Chars table (used by Back_End call to Gigi) @@ -140,18 +144,18 @@ package Stringt is -- the code is output as ["hh"] where hh is the two digit hex value for -- the code. Codes greater than 16#FF# are output as ["hhhh"] where hhhh -- is the four digit hex representation of the code value (high order - -- byte first). Hex letters are always in upper case. + -- byte first). Hex letters are always in lower case. procedure Write_String_Table_Entry (Id : String_Id); -- Writes a string value with enclosing quotes to the current file using -- routines in package Output. Does not write an end of line character. -- This procedure is used for debug output purposes, and also for output -- of strings specified by pragma Linker Option to the ali file. 7-bit - -- ASCII graphics (except for double quote and left brace) are output - -- literally. The double quote appears as two successive double quotes. + -- ASCII graphics (except for double quote) are output literally. + -- The double quote appears as two successive double quotes. -- All other codes, are output as described for Write_Char_Code. For -- example, the string created by folding "A" & ASCII.LF & "Hello" will - -- print as "A{0A}Hello". A No_String value prints simply as "no string" + -- print as "A["0a"]Hello". A No_String value prints simply as "no string" -- without surrounding quote marks. private diff --git a/gcc/ada/stringt.h b/gcc/ada/stringt.h index 3a1e1f684a3..a8c19663dab 100644 --- a/gcc/ada/stringt.h +++ b/gcc/ada/stringt.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * $Revision: 1.1 $ + * $Revision$ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * @@ -56,9 +56,7 @@ struct String_Entry }; /* Pointer to string entry vector. This pointer is passed to the tree - transformer and stored in a global location for access from here after - subtracting String_First_Entry, so that String_Id values can be used as - subscripts into the vector. */ + transformer and stored in a global location. */ extern struct String_Entry *Strings_Ptr; /* Pointer to name characters table. This pointer is passed to the tree @@ -74,7 +72,7 @@ INLINE Int String_Length (Id) String_Id Id; { - return Strings_Ptr [Id].Length; + return Strings_Ptr[Id - First_String_Id].Length; } @@ -88,5 +86,7 @@ Get_String_Char (Id, Index) String_Id Id; Int Index; { - return String_Chars_Ptr [Strings_Ptr [Id].String_Index + Index - 1]; + return + String_Chars_Ptr + [Strings_Ptr[Id - First_String_Id].String_Index + Index - 1]; } diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb index 9b74d614774..31a05fea8fd 100644 --- a/gcc/ada/style.adb +++ b/gcc/ada/style.adb @@ -136,6 +136,8 @@ package body Style is -- lower case, except after an underline character. procedure Check_Attribute_Name (Reserved : Boolean) is + pragma Warnings (Off, Reserved); + begin if Style_Check_Attribute_Casing then if Determine_Token_Casing /= Mixed_Case then diff --git a/gcc/ada/switch.adb b/gcc/ada/switch.adb index 53ed7ae1b89..30701cabf0c 100644 --- a/gcc/ada/switch.adb +++ b/gcc/ada/switch.adb @@ -26,67 +26,23 @@ -- -- ------------------------------------------------------------------------------ --- Option switch scanning for both the compiler and the binder - --- Note: this version of the package should be usable in both Unix and DOS - -with Debug; use Debug; -with Osint; use Osint; -with Opt; use Opt; -with Validsw; use Validsw; -with Stylesw; use Stylesw; -with Types; use Types; - -with System.WCh_Con; use System.WCh_Con; - package body Switch is - Bad_Switch : exception; - -- Exception raised if bad switch encountered - - Bad_Switch_Value : exception; - -- Exception raised if bad switch value encountered - - Missing_Switch_Value : exception; - -- Exception raised if no switch value encountered - - Too_Many_Output_Files : exception; - -- Exception raised if the -o switch is encountered more than once - - Switch_Max_Value : constant := 999; - -- Maximum value permitted in switches that take a value - - procedure Scan_Nat - (Switch_Chars : String; - Max : Integer; - Ptr : in out Integer; - Result : out Nat); - -- Scan natural integer parameter for switch. On entry, Ptr points - -- just past the switch character, on exit it points past the last - -- digit of the integer value. - - procedure Scan_Pos - (Switch_Chars : String; - Max : Integer; - Ptr : in out Integer; - Result : out Pos); - -- Scan positive integer parameter for switch. On entry, Ptr points - -- just past the switch character, on exit it points past the last - -- digit of the integer value. - ------------------------- -- Is_Front_End_Switch -- ------------------------- function Is_Front_End_Switch (Switch_Chars : String) return Boolean is - Ptr : constant Positive := Switch_Chars'First; + Ptr : constant Positive := Switch_Chars'First; + begin return Is_Switch (Switch_Chars) and then - (Switch_Chars (Ptr + 1) = 'I' - or else - (Switch_Chars'Length >= 5 - and then Switch_Chars (Ptr + 1 .. Ptr + 4) = "gnat")); + (Switch_Chars (Ptr + 1) = 'I' + or else (Switch_Chars'Length >= 5 + and then Switch_Chars (Ptr + 1 .. Ptr + 4) = "gnat") + or else (Switch_Chars'Length >= 5 + and then Switch_Chars (Ptr + 1 .. Ptr + 4) = "fRTS")); end Is_Front_End_Switch; --------------- @@ -96,1252 +52,10 @@ package body Switch is function Is_Switch (Switch_Chars : String) return Boolean is begin return Switch_Chars'Length > 1 - and then (Switch_Chars (Switch_Chars'First) = '-' - or - Switch_Chars (Switch_Chars'First) = Switch_Character); + and then Switch_Chars (Switch_Chars'First) = '-'; end Is_Switch; - -------------------------- - -- Scan_Binder_Switches -- - -------------------------- - - procedure Scan_Binder_Switches (Switch_Chars : String) is - Ptr : Integer := Switch_Chars'First; - Max : Integer := Switch_Chars'Last; - C : Character := ' '; - - begin - -- Skip past the initial character (must be the switch character) - - if Ptr = Max then - raise Bad_Switch; - else - Ptr := Ptr + 1; - end if; - - -- A little check, "gnat" at the start of a switch is not allowed - -- except for the compiler - - if Switch_Chars'Last >= Ptr + 3 - and then Switch_Chars (Ptr .. Ptr + 3) = "gnat" - then - Osint.Fail ("invalid switch: """, Switch_Chars, """" - & " (gnat not needed here)"); - - end if; - - -- Loop to scan through switches given in switch string - - while Ptr <= Max loop - C := Switch_Chars (Ptr); - - case C is - - -- Processing for A switch - - when 'A' => - Ptr := Ptr + 1; - - Ada_Bind_File := True; - - -- Processing for b switch - - when 'b' => - Ptr := Ptr + 1; - Brief_Output := True; - - -- Processing for c switch - - when 'c' => - Ptr := Ptr + 1; - - Check_Only := True; - - -- Processing for C switch - - when 'C' => - Ptr := Ptr + 1; - - Ada_Bind_File := False; - - -- Processing for d switch - - when 'd' => - - -- Note: for the debug switch, the remaining characters in this - -- switch field must all be debug flags, since all valid switch - -- characters are also valid debug characters. - - -- Loop to scan out debug flags - - while Ptr < Max loop - Ptr := Ptr + 1; - C := Switch_Chars (Ptr); - exit when C = ASCII.NUL or else C = '/' or else C = '-'; - - if C in '1' .. '9' or else - C in 'a' .. 'z' or else - C in 'A' .. 'Z' - then - Set_Debug_Flag (C); - else - raise Bad_Switch; - end if; - end loop; - - -- Make sure Zero_Cost_Exceptions is set if gnatdX set. This - -- is for backwards compatibility with old versions and usage. - - if Debug_Flag_XX then - Zero_Cost_Exceptions_Set := True; - Zero_Cost_Exceptions_Val := True; - end if; - - return; - - -- Processing for e switch - - when 'e' => - Ptr := Ptr + 1; - Elab_Dependency_Output := True; - - -- Processing for E switch - - when 'E' => - Ptr := Ptr + 1; - Exception_Tracebacks := True; - - -- Processing for f switch - - when 'f' => - Ptr := Ptr + 1; - Force_RM_Elaboration_Order := True; - - -- Processing for g switch - - when 'g' => - Ptr := Ptr + 1; - - if Ptr <= Max then - C := Switch_Chars (Ptr); - - if C in '0' .. '3' then - Debugger_Level := - Character'Pos - (Switch_Chars (Ptr)) - Character'Pos ('0'); - Ptr := Ptr + 1; - end if; - - else - Debugger_Level := 2; - end if; - - -- Processing for G switch - - when 'G' => - Ptr := Ptr + 1; - Print_Generated_Code := True; - - -- Processing for h switch - - when 'h' => - Ptr := Ptr + 1; - Usage_Requested := True; - - -- Processing for i switch - - when 'i' => - if Ptr = Max then - raise Bad_Switch; - end if; - - Ptr := Ptr + 1; - C := Switch_Chars (Ptr); - - if C in '1' .. '5' - or else C = '8' - or else C = 'p' - or else C = 'f' - or else C = 'n' - or else C = 'w' - then - Identifier_Character_Set := C; - Ptr := Ptr + 1; - else - raise Bad_Switch; - end if; - - -- Processing for K switch - - when 'K' => - Ptr := Ptr + 1; - - if Program = Binder then - Output_Linker_Option_List := True; - else - raise Bad_Switch; - end if; - - -- Processing for l switch - - when 'l' => - Ptr := Ptr + 1; - Elab_Order_Output := True; - - -- Processing for m switch - - when 'm' => - Ptr := Ptr + 1; - Scan_Pos (Switch_Chars, Max, Ptr, Maximum_Errors); - - -- Processing for n switch - - when 'n' => - Ptr := Ptr + 1; - Bind_Main_Program := False; - - -- Note: The -L option of the binder also implies -n, so - -- any change here must also be reflected in the processing - -- for -L that is found in Gnatbind.Scan_Bind_Arg. - - -- Processing for o switch - - when 'o' => - Ptr := Ptr + 1; - - if Output_File_Name_Present then - raise Too_Many_Output_Files; - - else - Output_File_Name_Present := True; - end if; - - -- Processing for O switch - - when 'O' => - Ptr := Ptr + 1; - Output_Object_List := True; - - -- Processing for p switch - - when 'p' => - Ptr := Ptr + 1; - Pessimistic_Elab_Order := True; - - -- Processing for q switch - - when 'q' => - Ptr := Ptr + 1; - Quiet_Output := True; - - -- Processing for s switch - - when 's' => - Ptr := Ptr + 1; - All_Sources := True; - Check_Source_Files := True; - - -- Processing for t switch - - when 't' => - Ptr := Ptr + 1; - Tolerate_Consistency_Errors := True; - - -- Processing for T switch - - when 'T' => - Ptr := Ptr + 1; - Time_Slice_Set := True; - Scan_Nat (Switch_Chars, Max, Ptr, Time_Slice_Value); - - -- Processing for v switch - - when 'v' => - Ptr := Ptr + 1; - Verbose_Mode := True; - - -- Processing for w switch - - when 'w' => - - -- For the binder we only allow suppress/error cases - - Ptr := Ptr + 1; - - case Switch_Chars (Ptr) is - - when 'e' => - Warning_Mode := Treat_As_Error; - - when 's' => - Warning_Mode := Suppress; - - when others => - raise Bad_Switch; - end case; - - Ptr := Ptr + 1; - - -- Processing for W switch - - when 'W' => - Ptr := Ptr + 1; - - for J in WC_Encoding_Method loop - if Switch_Chars (Ptr) = WC_Encoding_Letters (J) then - Wide_Character_Encoding_Method := J; - exit; - - elsif J = WC_Encoding_Method'Last then - raise Bad_Switch; - end if; - end loop; - - Upper_Half_Encoding := - Wide_Character_Encoding_Method in - WC_Upper_Half_Encoding_Method; - - Ptr := Ptr + 1; - - -- Processing for x switch - - when 'x' => - Ptr := Ptr + 1; - All_Sources := False; - Check_Source_Files := False; - - -- Processing for z switch - - when 'z' => - Ptr := Ptr + 1; - No_Main_Subprogram := True; - - -- Ignore extra switch character - - when '/' | '-' => - Ptr := Ptr + 1; - - -- Anything else is an error (illegal switch character) - - when others => - raise Bad_Switch; - end case; - end loop; - - exception - when Bad_Switch => - Osint.Fail ("invalid switch: ", (1 => C)); - - when Bad_Switch_Value => - Osint.Fail ("numeric value too big for switch: ", (1 => C)); - - when Missing_Switch_Value => - Osint.Fail ("missing numeric value for switch: ", (1 => C)); - - when Too_Many_Output_Files => - Osint.Fail ("duplicate -o switch"); - end Scan_Binder_Switches; - - ----------------------------- - -- Scan_Front_End_Switches -- - ----------------------------- - - procedure Scan_Front_End_Switches (Switch_Chars : String) is - Switch_Starts_With_Gnat : Boolean; - Ptr : Integer := Switch_Chars'First; - Max : constant Integer := Switch_Chars'Last; - C : Character := ' '; - - begin - -- Skip past the initial character (must be the switch character) - - if Ptr = Max then - raise Bad_Switch; - - else - Ptr := Ptr + 1; - end if; - - -- A little check, "gnat" at the start of a switch is not allowed - -- except for the compiler (where it was already removed) - - Switch_Starts_With_Gnat := - Ptr + 3 <= Max and then Switch_Chars (Ptr .. Ptr + 3) = "gnat"; - - if Switch_Starts_With_Gnat then - Ptr := Ptr + 4; - end if; - - -- Loop to scan through switches given in switch string - - while Ptr <= Max loop - C := Switch_Chars (Ptr); - - -- Processing for a switch - - case Switch_Starts_With_Gnat is - - when False => - -- There is only one front-end switch that - -- does not start with -gnat, namely -I - - case C is - - when 'I' => - Ptr := Ptr + 1; - - if Ptr > Max then - raise Bad_Switch; - end if; - - -- Find out whether this is a -I- or regular -Ixxx switch - - if Ptr = Max and then Switch_Chars (Ptr) = '-' then - Look_In_Primary_Dir := False; - - else - Add_Src_Search_Dir (Switch_Chars (Ptr .. Max)); - end if; - - Ptr := Max + 1; - - when others => - -- Should not happen, as Scan_Switches is supposed - -- to be called for front-end switches only. - -- Still, it is safest to raise Bad_Switch error. - - raise Bad_Switch; - end case; - - when True => - -- Process -gnat* options - - case C is - - when 'a' => - Ptr := Ptr + 1; - Assertions_Enabled := True; - - -- Processing for A switch - - when 'A' => - Ptr := Ptr + 1; - Config_File := False; - - -- Processing for b switch - - when 'b' => - Ptr := Ptr + 1; - Brief_Output := True; - - -- Processing for c switch - - when 'c' => - Ptr := Ptr + 1; - Operating_Mode := Check_Semantics; - - -- Processing for C switch - - when 'C' => - Ptr := Ptr + 1; - Compress_Debug_Names := True; - - -- Processing for d switch - - when 'd' => - - -- Note: for the debug switch, the remaining characters in this - -- switch field must all be debug flags, since all valid switch - -- characters are also valid debug characters. - - -- Loop to scan out debug flags - - while Ptr < Max loop - Ptr := Ptr + 1; - C := Switch_Chars (Ptr); - exit when C = ASCII.NUL or else C = '/' or else C = '-'; - - if C in '1' .. '9' or else - C in 'a' .. 'z' or else - C in 'A' .. 'Z' - then - Set_Debug_Flag (C); - - else - raise Bad_Switch; - end if; - end loop; - - -- Make sure Zero_Cost_Exceptions is set if gnatdX set. This - -- is for backwards compatibility with old versions and usage. - - if Debug_Flag_XX then - Zero_Cost_Exceptions_Set := True; - Zero_Cost_Exceptions_Val := True; - end if; - - return; - - -- Processing for D switch - - when 'D' => - Ptr := Ptr + 1; - - -- Note: -gnatD also sets -gnatx (to turn off cross-reference - -- generation in the ali file) since otherwise this generation - -- gets confused by the "wrong" Sloc values put in the tree. - - Debug_Generated_Code := True; - Xref_Active := False; - Set_Debug_Flag ('g'); - - -- Processing for e switch - - when 'e' => - Ptr := Ptr + 1; - - if Ptr > Max then - raise Bad_Switch; - end if; - - case Switch_Chars (Ptr) is - - -- Configuration pragmas - - when 'c' => - Ptr := Ptr + 1; - - if Ptr > Max then - raise Bad_Switch; - end if; - - Config_File_Name := - new String'(Switch_Chars (Ptr .. Max)); - - return; - - -- Mapping file - - when 'm' => - Ptr := Ptr + 1; - - if Ptr > Max then - raise Bad_Switch; - end if; - - Mapping_File_Name := - new String'(Switch_Chars (Ptr .. Max)); - return; - - when others => - raise Bad_Switch; - end case; - - -- Processing for E switch - - when 'E' => - Ptr := Ptr + 1; - Dynamic_Elaboration_Checks := True; - - -- Processing for f switch - - when 'f' => - Ptr := Ptr + 1; - All_Errors_Mode := True; - - -- Processing for F switch - - when 'F' => - Ptr := Ptr + 1; - External_Name_Exp_Casing := Uppercase; - External_Name_Imp_Casing := Uppercase; - - -- Processing for g switch - - when 'g' => - Ptr := Ptr + 1; - GNAT_Mode := True; - Identifier_Character_Set := 'n'; - Warning_Mode := Treat_As_Error; - Check_Unreferenced := True; - Check_Withs := True; - - Set_Default_Style_Check_Options; - - -- Processing for G switch - - when 'G' => - Ptr := Ptr + 1; - Print_Generated_Code := True; - - -- Processing for h switch - - when 'h' => - Ptr := Ptr + 1; - Usage_Requested := True; - - -- Processing for H switch - - when 'H' => - Ptr := Ptr + 1; - HLO_Active := True; - - -- Processing for i switch - - when 'i' => - if Ptr = Max then - raise Bad_Switch; - end if; - - Ptr := Ptr + 1; - C := Switch_Chars (Ptr); - - if C in '1' .. '5' - or else C = '8' - or else C = 'p' - or else C = 'f' - or else C = 'n' - or else C = 'w' - then - Identifier_Character_Set := C; - Ptr := Ptr + 1; - - else - raise Bad_Switch; - end if; - - -- Processing for k switch - - when 'k' => - Ptr := Ptr + 1; - Scan_Pos (Switch_Chars, Max, Ptr, Maximum_File_Name_Length); - - -- Processing for l switch - - when 'l' => - Ptr := Ptr + 1; - Full_List := True; - - -- Processing for L switch - - when 'L' => - Ptr := Ptr + 1; - Zero_Cost_Exceptions_Set := True; - Zero_Cost_Exceptions_Val := False; - - -- Processing for m switch - - when 'm' => - Ptr := Ptr + 1; - Scan_Pos (Switch_Chars, Max, Ptr, Maximum_Errors); - - -- Processing for n switch - - when 'n' => - Ptr := Ptr + 1; - Inline_Active := True; - - -- Processing for N switch - - when 'N' => - Ptr := Ptr + 1; - Inline_Active := True; - Front_End_Inlining := True; - - -- Processing for o switch - - when 'o' => - Ptr := Ptr + 1; - Suppress_Options.Overflow_Checks := False; - - -- Processing for O switch - - when 'O' => - Ptr := Ptr + 1; - Output_File_Name_Present := True; - - -- Processing for p switch - - when 'p' => - Ptr := Ptr + 1; - Suppress_Options.Access_Checks := True; - Suppress_Options.Accessibility_Checks := True; - Suppress_Options.Discriminant_Checks := True; - Suppress_Options.Division_Checks := True; - Suppress_Options.Elaboration_Checks := True; - Suppress_Options.Index_Checks := True; - Suppress_Options.Length_Checks := True; - Suppress_Options.Overflow_Checks := True; - Suppress_Options.Range_Checks := True; - Suppress_Options.Division_Checks := True; - Suppress_Options.Length_Checks := True; - Suppress_Options.Range_Checks := True; - Suppress_Options.Storage_Checks := True; - Suppress_Options.Tag_Checks := True; - - Validity_Checks_On := False; - - -- Processing for P switch - - when 'P' => - Ptr := Ptr + 1; - Polling_Required := True; - - -- Processing for q switch - - when 'q' => - Ptr := Ptr + 1; - Try_Semantics := True; - - -- Processing for q switch - - when 'Q' => - Ptr := Ptr + 1; - Force_ALI_Tree_File := True; - Try_Semantics := True; - - -- Processing for r switch - - when 'r' => - Ptr := Ptr + 1; - - -- Temporarily allow -gnatr to mean -gnatyl (use RM layout) - -- for compatibility with pre 3.12 versions of GNAT, - -- to be removed for 3.13 ??? - - Set_Style_Check_Options ("l"); - - -- Processing for R switch - - when 'R' => - Ptr := Ptr + 1; - Back_Annotate_Rep_Info := True; - - if Ptr <= Max - and then Switch_Chars (Ptr) in '0' .. '9' - then - C := Switch_Chars (Ptr); - - if C in '4' .. '9' then - raise Bad_Switch; - else - List_Representation_Info := - Character'Pos (C) - Character'Pos ('0'); - Ptr := Ptr + 1; - end if; - - else - List_Representation_Info := 1; - end if; - - -- Processing for s switch - - when 's' => - Ptr := Ptr + 1; - Operating_Mode := Check_Syntax; - - -- Processing for t switch - - when 't' => - Ptr := Ptr + 1; - Tree_Output := True; - Back_Annotate_Rep_Info := True; - - -- Processing for T switch - - when 'T' => - Ptr := Ptr + 1; - Time_Slice_Set := True; - Scan_Nat (Switch_Chars, Max, Ptr, Time_Slice_Value); - - -- Processing for u switch - - when 'u' => - Ptr := Ptr + 1; - List_Units := True; - - -- Processing for U switch - - when 'U' => - Ptr := Ptr + 1; - Unique_Error_Tag := True; - - -- Processing for v switch - - when 'v' => - Ptr := Ptr + 1; - Verbose_Mode := True; - - -- Processing for V switch - - when 'V' => - Ptr := Ptr + 1; - - if Ptr > Max then - raise Bad_Switch; - - else - declare - OK : Boolean; - - begin - Set_Validity_Check_Options - (Switch_Chars (Ptr .. Max), OK, Ptr); - - if not OK then - raise Bad_Switch; - end if; - end; - end if; - - -- Processing for w switch - - when 'w' => - Ptr := Ptr + 1; - - if Ptr > Max then - raise Bad_Switch; - end if; - - while Ptr <= Max loop - C := Switch_Chars (Ptr); - - case C is - - when 'a' => - Constant_Condition_Warnings := True; - Elab_Warnings := True; - Check_Unreferenced := True; - Check_Withs := True; - Implementation_Unit_Warnings := True; - Ineffective_Inline_Warnings := True; - Warn_On_Redundant_Constructs := True; - - when 'A' => - Constant_Condition_Warnings := False; - Elab_Warnings := False; - Check_Unreferenced := False; - Check_Withs := False; - Implementation_Unit_Warnings := False; - Warn_On_Biased_Rounding := False; - Warn_On_Hiding := False; - Warn_On_Redundant_Constructs := False; - Ineffective_Inline_Warnings := False; - - when 'c' => - Constant_Condition_Warnings := True; - - when 'C' => - Constant_Condition_Warnings := False; - - when 'b' => - Warn_On_Biased_Rounding := True; - - when 'B' => - Warn_On_Biased_Rounding := False; - - when 'e' => - Warning_Mode := Treat_As_Error; - - when 'h' => - Warn_On_Hiding := True; - - when 'H' => - Warn_On_Hiding := False; - - when 'i' => - Implementation_Unit_Warnings := True; - - when 'I' => - Implementation_Unit_Warnings := False; - - when 'l' => - Elab_Warnings := True; - - when 'L' => - Elab_Warnings := False; - - when 'o' => - Address_Clause_Overlay_Warnings := True; - - when 'O' => - Address_Clause_Overlay_Warnings := False; - - when 'p' => - Ineffective_Inline_Warnings := True; - - when 'P' => - Ineffective_Inline_Warnings := False; - - when 'r' => - Warn_On_Redundant_Constructs := True; - - when 'R' => - Warn_On_Redundant_Constructs := False; - - when 's' => - Warning_Mode := Suppress; - - when 'u' => - Check_Unreferenced := True; - Check_Withs := True; - - when 'U' => - Check_Unreferenced := False; - Check_Withs := False; - - -- Allow and ignore 'w' so that the old - -- format (e.g. -gnatwuwl) will work. - - when 'w' => - null; - - when others => - raise Bad_Switch; - end case; - - Ptr := Ptr + 1; - end loop; - - return; - - -- Processing for W switch - - when 'W' => - Ptr := Ptr + 1; - - for J in WC_Encoding_Method loop - if Switch_Chars (Ptr) = WC_Encoding_Letters (J) then - Wide_Character_Encoding_Method := J; - exit; - - elsif J = WC_Encoding_Method'Last then - raise Bad_Switch; - end if; - end loop; - - Upper_Half_Encoding := - Wide_Character_Encoding_Method in - WC_Upper_Half_Encoding_Method; - - Ptr := Ptr + 1; - - -- Processing for x switch - - when 'x' => - Ptr := Ptr + 1; - Xref_Active := False; - - -- Processing for X switch - - when 'X' => - Ptr := Ptr + 1; - Extensions_Allowed := True; - - -- Processing for y switch - - when 'y' => - Ptr := Ptr + 1; - - if Ptr > Max then - Set_Default_Style_Check_Options; - - else - declare - OK : Boolean; - - begin - Set_Style_Check_Options - (Switch_Chars (Ptr .. Max), OK, Ptr); - - if not OK then - raise Bad_Switch; - end if; - end; - end if; - - -- Processing for z switch - - when 'z' => - Ptr := Ptr + 1; - - -- Allowed for compiler, only if this is the only - -- -z switch, we do not allow multiple occurrences - - if Distribution_Stub_Mode = No_Stubs then - case Switch_Chars (Ptr) is - when 'r' => - Distribution_Stub_Mode := Generate_Receiver_Stub_Body; - - when 'c' => - Distribution_Stub_Mode := Generate_Caller_Stub_Body; - - when others => - raise Bad_Switch; - end case; - - Ptr := Ptr + 1; - - end if; - - -- Processing for Z switch - - when 'Z' => - Ptr := Ptr + 1; - Zero_Cost_Exceptions_Set := True; - Zero_Cost_Exceptions_Val := True; - - -- Processing for 83 switch - - when '8' => - - if Ptr = Max then - raise Bad_Switch; - end if; - - Ptr := Ptr + 1; - - if Switch_Chars (Ptr) /= '3' then - raise Bad_Switch; - else - Ptr := Ptr + 1; - Ada_95 := False; - Ada_83 := True; - end if; - - -- Ignore extra switch character - - when '/' | '-' => - Ptr := Ptr + 1; - - -- Anything else is an error (illegal switch character) - - when others => - raise Bad_Switch; - end case; - end case; - end loop; - - exception - when Bad_Switch => - Osint.Fail ("invalid switch: ", (1 => C)); - - when Bad_Switch_Value => - Osint.Fail ("numeric value too big for switch: ", (1 => C)); - - when Missing_Switch_Value => - Osint.Fail ("missing numeric value for switch: ", (1 => C)); - - end Scan_Front_End_Switches; - - ------------------------ - -- Scan_Make_Switches -- ------------------------ - - procedure Scan_Make_Switches (Switch_Chars : String) is - Ptr : Integer := Switch_Chars'First; - Max : Integer := Switch_Chars'Last; - C : Character := ' '; - - begin - -- Skip past the initial character (must be the switch character) - - if Ptr = Max then - raise Bad_Switch; - - else - Ptr := Ptr + 1; - end if; - - -- A little check, "gnat" at the start of a switch is not allowed - -- except for the compiler (where it was already removed) - - if Switch_Chars'Length >= Ptr + 3 - and then Switch_Chars (Ptr .. Ptr + 3) = "gnat" - then - Osint.Fail - ("invalid switch: """, Switch_Chars, """ (gnat not needed here)"); - end if; - - -- Loop to scan through switches given in switch string - - while Ptr <= Max loop - C := Switch_Chars (Ptr); - - -- Processing for a switch - - case C is - - when 'a' => - Ptr := Ptr + 1; - Check_Readonly_Files := True; - - -- Processing for b switch - - when 'b' => - Ptr := Ptr + 1; - Bind_Only := True; - - -- Processing for c switch - - when 'c' => - Ptr := Ptr + 1; - Compile_Only := True; - - when 'd' => - - -- Note: for the debug switch, the remaining characters in this - -- switch field must all be debug flags, since all valid switch - -- characters are also valid debug characters. - - -- Loop to scan out debug flags - - while Ptr < Max loop - Ptr := Ptr + 1; - C := Switch_Chars (Ptr); - exit when C = ASCII.NUL or else C = '/' or else C = '-'; - - if C in '1' .. '9' or else - C in 'a' .. 'z' or else - C in 'A' .. 'Z' - then - Set_Debug_Flag (C); - else - raise Bad_Switch; - end if; - end loop; - - -- Make sure Zero_Cost_Exceptions is set if gnatdX set. This - -- is for backwards compatibility with old versions and usage. - - if Debug_Flag_XX then - Zero_Cost_Exceptions_Set := True; - Zero_Cost_Exceptions_Val := True; - end if; - - return; - - -- Processing for f switch - - when 'f' => - Ptr := Ptr + 1; - Force_Compilations := True; - - -- Processing for G switch - - when 'G' => - Ptr := Ptr + 1; - Print_Generated_Code := True; - - -- Processing for h switch - - when 'h' => - Ptr := Ptr + 1; - Usage_Requested := True; - - -- Processing for i switch - - when 'i' => - Ptr := Ptr + 1; - In_Place_Mode := True; - - -- Processing for j switch - - when 'j' => - Ptr := Ptr + 1; - - declare - Max_Proc : Pos; - begin - Scan_Pos (Switch_Chars, Max, Ptr, Max_Proc); - Maximum_Processes := Positive (Max_Proc); - end; - - -- Processing for k switch - - when 'k' => - Ptr := Ptr + 1; - Keep_Going := True; - - -- Processing for l switch - - when 'l' => - Ptr := Ptr + 1; - Link_Only := True; - - when 'M' => - Ptr := Ptr + 1; - List_Dependencies := True; - - -- Processing for n switch - - when 'n' => - Ptr := Ptr + 1; - Do_Not_Execute := True; - - -- Processing for o switch - - when 'o' => - Ptr := Ptr + 1; - - if Output_File_Name_Present then - raise Too_Many_Output_Files; - else - Output_File_Name_Present := True; - end if; - - -- Processing for q switch - - when 'q' => - Ptr := Ptr + 1; - Quiet_Output := True; - - -- Processing for s switch - - when 's' => - Ptr := Ptr + 1; - Check_Switches := True; - - -- Processing for v switch - - when 'v' => - Ptr := Ptr + 1; - Verbose_Mode := True; - - -- Processing for z switch - - when 'z' => - Ptr := Ptr + 1; - No_Main_Subprogram := True; - - -- Ignore extra switch character - - when '/' | '-' => - Ptr := Ptr + 1; - - -- Anything else is an error (illegal switch character) - - when others => - raise Bad_Switch; - - end case; - end loop; - - exception - when Bad_Switch => - Osint.Fail ("invalid switch: ", (1 => C)); - - when Bad_Switch_Value => - Osint.Fail ("numeric value too big for switch: ", (1 => C)); - - when Missing_Switch_Value => - Osint.Fail ("missing numeric value for switch: ", (1 => C)); - - when Too_Many_Output_Files => - Osint.Fail ("duplicate -o switch"); - - end Scan_Make_Switches; - -------------- -- Scan_Nat -- -------------- @@ -1350,9 +64,11 @@ package body Switch is (Switch_Chars : String; Max : Integer; Ptr : in out Integer; - Result : out Nat) is + Result : out Nat) + is begin Result := 0; + if Ptr > Max or else Switch_Chars (Ptr) not in '0' .. '9' then raise Missing_Switch_Value; end if; @@ -1380,6 +96,7 @@ package body Switch is begin Scan_Nat (Switch_Chars, Max, Ptr, Result); + if Result = 0 then raise Bad_Switch_Value; end if; diff --git a/gcc/ada/switch.ads b/gcc/ada/switch.ads index 7153cdaa765..c02c29b351e 100644 --- a/gcc/ada/switch.ads +++ b/gcc/ada/switch.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.17 $ -- +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -26,12 +26,15 @@ -- -- ------------------------------------------------------------------------------ --- This package scans switches. Note that the body of Usage must be --- coordinated with the switches that are recognized by this package. --- The Usage package also acts as the official documentation for the +-- This package together with a child package appropriate to the client +-- tool scans switches. Note that the body of the appropraite Usage package +-- must be coordinated with the switches that are recognized by this package. +-- These Usage packages also act as the official documentation for the -- switches that are recognized. In addition, package Debug documents -- the otherwise undocumented debug switches that are also recognized. +with Types; use Types; + package Switch is -- Note: The default switch character is indicated by Switch_Character, @@ -55,15 +58,43 @@ package Switch is -- Returns True iff Switch_Chars represents a front-end switch, -- ie. it starts with -I or -gnat. - procedure Scan_Front_End_Switches (Switch_Chars : String); - procedure Scan_Binder_Switches (Switch_Chars : String); - procedure Scan_Make_Switches (Switch_Chars : String); - -- Procedures to scan out switches stored in the given string. The first - -- character is known to be a valid switch character, and there are no - -- blanks or other switch terminator characters in the string, so the - -- entire string should consist of valid switch characters, except that - -- an optional terminating NUL character is allowed. A bad switch causes - -- a fatal error exit and control does not return. The call also sets - -- Usage_Requested to True if a ? switch is encountered. +private + + -- This section contains some common routines used by the tool dependent + -- child packages (there is one such child package for each tool that + -- uses Switches to scan switches - Compiler/gnatbind/gnatmake/. + + Bad_Switch : exception; + -- Exception raised if bad switch encountered + + Bad_Switch_Value : exception; + -- Exception raised if bad switch value encountered + + Missing_Switch_Value : exception; + -- Exception raised if no switch value encountered + + Too_Many_Output_Files : exception; + -- Exception raised if the -o switch is encountered more than once + + Switch_Max_Value : constant := 999; + -- Maximum value permitted in switches that take a value + + procedure Scan_Nat + (Switch_Chars : String; + Max : Integer; + Ptr : in out Integer; + Result : out Nat); + -- Scan natural integer parameter for switch. On entry, Ptr points + -- just past the switch character, on exit it points past the last + -- digit of the integer value. + + procedure Scan_Pos + (Switch_Chars : String; + Max : Integer; + Ptr : in out Integer; + Result : out Pos); + -- Scan positive integer parameter for switch. On entry, Ptr points + -- just past the switch character, on exit it points past the last + -- digit of the integer value. end Switch; diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 2ab58074c02..a2804c66025 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -6,9 +6,9 @@ * * * C Implementation File * * * - * $Revision: 1.4 $ + * $Revision$ * * - * Copyright (C) 1992-2001 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- * @@ -36,6 +36,8 @@ GNAT Run Time Library */ #ifdef __vxworks +#include "ioLib.h" +#include "selectLib.h" #include "vxWorks.h" #endif #ifdef IN_RTS @@ -142,18 +144,18 @@ */ #if defined(WINNT) || defined (MSDOS) || defined (__EMX__) -const char *mode_read_text = "rt"; -const char *mode_write_text = "wt"; -const char *mode_append_text = "at"; -const char *mode_read_binary = "rb"; -const char *mode_write_binary = "wb"; -const char *mode_append_binary = "ab"; -const char *mode_read_text_plus = "r+t"; -const char *mode_write_text_plus = "w+t"; -const char *mode_append_text_plus = "a+t"; -const char *mode_read_binary_plus = "r+b"; -const char *mode_write_binary_plus = "w+b"; -const char *mode_append_binary_plus = "a+b"; +static const char *mode_read_text = "rt"; +static const char *mode_write_text = "wt"; +static const char *mode_append_text = "at"; +static const char *mode_read_binary = "rb"; +static const char *mode_write_binary = "wb"; +static const char *mode_append_binary = "ab"; +static const char *mode_read_text_plus = "r+t"; +static const char *mode_write_text_plus = "w+t"; +static const char *mode_append_text_plus = "a+t"; +static const char *mode_read_binary_plus = "r+b"; +static const char *mode_write_binary_plus = "w+b"; +static const char *mode_append_binary_plus = "a+b"; const char __gnat_text_translation_required = 1; void @@ -247,18 +249,18 @@ static void winflush_nt () #else -const char *mode_read_text = "r"; -const char *mode_write_text = "w"; -const char *mode_append_text = "a"; -const char *mode_read_binary = "r"; -const char *mode_write_binary = "w"; -const char *mode_append_binary = "a"; -const char *mode_read_text_plus = "r+"; -const char *mode_write_text_plus = "w+"; -const char *mode_append_text_plus = "a+"; -const char *mode_read_binary_plus = "r+"; -const char *mode_write_binary_plus = "w+"; -const char *mode_append_binary_plus = "a+"; +static const char *mode_read_text = "r"; +static const char *mode_write_text = "w"; +static const char *mode_append_text = "a"; +static const char *mode_read_binary = "r"; +static const char *mode_write_binary = "w"; +static const char *mode_append_binary = "a"; +static const char *mode_read_text_plus = "r+"; +static const char *mode_write_text_plus = "w+"; +static const char *mode_append_text_plus = "a+"; +static const char *mode_read_binary_plus = "r+"; +static const char *mode_write_binary_plus = "w+"; +static const char *mode_append_binary_plus = "a+"; const char __gnat_text_translation_required = 0; /* These functions do nothing in non-DOS systems. */ @@ -292,7 +294,8 @@ __gnat_ttyname (filedes) #if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ || (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \ - || defined (__MACHTEN__) + || defined (__MACHTEN__) || defined (hpux) || defined (_AIX) \ + || (defined (__svr4__) && defined (i386)) || defined (__Lynx__) #include <termios.h> #else @@ -347,7 +350,9 @@ getc_immediate_common (stream, ch, end_of_file, avail, waiting) { #if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ || (defined (__osf__) && ! defined (__alpha_vxworks)) \ - || defined (__CYGWIN32__) || defined (__MACHTEN__) + || defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (hpux) \ + || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ + || defined (__Lynx__) char c; int nread; int good_one = 0; @@ -359,34 +364,37 @@ getc_immediate_common (stream, ch, end_of_file, avail, waiting) { tcgetattr (fd, &termios_rec); memcpy (&otermios_rec, &termios_rec, sizeof (struct termios)); - while (! good_one) - { - /* Set RAW mode */ - termios_rec.c_lflag = termios_rec.c_lflag & ~ICANON; -#if defined(sgi) || defined (sun) || defined (__EMX__) || defined (__osf__) \ - || defined (linux) || defined (__MACHTEN__) - eof_ch = termios_rec.c_cc[VEOF]; - - /* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for - a character forever. This doesn't seem to effect Ctrl-Z or - Ctrl-C processing except on OS/2 where Ctrl-C won't work right - unless we do a read loop. Luckily we can delay a bit between - iterations. If not waiting (i.e. Get_Immediate (Char, Available)), - don't wait for anything but timeout immediately. */ + + /* Set RAW mode, with no echo */ + termios_rec.c_lflag = termios_rec.c_lflag & ~ICANON & ~ECHO; + +#if defined(linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ + || defined (__osf__) || defined (__MACHTEN__) || defined (hpux) \ + || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ + || defined (__Lynx__) + eof_ch = termios_rec.c_cc[VEOF]; + + /* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for + a character forever. This doesn't seem to effect Ctrl-Z or + Ctrl-C processing except on OS/2 where Ctrl-C won't work right + unless we do a read loop. Luckily we can delay a bit between + iterations. If not waiting (i.e. Get_Immediate (Char, Available)), + don't wait for anything but timeout immediately. */ #ifdef __EMX__ - termios_rec.c_cc[VMIN] = 0; - termios_rec.c_cc[VTIME] = waiting; + termios_rec.c_cc[VMIN] = 0; + termios_rec.c_cc[VTIME] = waiting; #else - termios_rec.c_cc[VMIN] = waiting; - termios_rec.c_cc[VTIME] = 0; + termios_rec.c_cc[VMIN] = waiting; + termios_rec.c_cc[VTIME] = 0; #endif #endif - tcsetattr (fd, TCSANOW, &termios_rec); + tcsetattr (fd, TCSANOW, &termios_rec); - /* Read() is used here instead of fread(), because fread() doesn't + while (! good_one) + { + /* Read is used here instead of fread, because fread doesn't work on Solaris5 and Sunos4 in this situation. Maybe because we are mixing calls that use file descriptors and streams. */ - nread = read (fd, &c, 1); if (nread > 0) { @@ -414,9 +422,7 @@ getc_immediate_common (stream, ch, end_of_file, avail, waiting) good_one = 1; } else - { - good_one = 0; - } + good_one = 0; } tcsetattr (fd, TCSANOW, &otermios_rec); @@ -424,8 +430,7 @@ getc_immediate_common (stream, ch, end_of_file, avail, waiting) } else -#else -#if defined (VMS) +#elif defined (VMS) int fd = fileno (stream); if (isatty (fd)) @@ -435,6 +440,7 @@ getc_immediate_common (stream, ch, end_of_file, avail, waiting) decc$bsd_initscr (); initted = 1; } + decc$bsd_cbreak (); *ch = decc$bsd_wgetch (decc$ga_stdscr); @@ -447,8 +453,7 @@ getc_immediate_common (stream, ch, end_of_file, avail, waiting) decc$bsd_nocbreak (); } else -#else -#if defined (__MINGW32__) +#elif defined (__MINGW32__) int fd = fileno (stream); int char_waiting; int eot_ch = 4; /* Ctrl-D */ @@ -457,8 +462,8 @@ getc_immediate_common (stream, ch, end_of_file, avail, waiting) { if (waiting) { - *ch = getch(); - (*winflush_function)(); + *ch = getch (); + (*winflush_function) (); if (*ch == eot_ch) *end_of_file = 1; @@ -474,8 +479,8 @@ getc_immediate_common (stream, ch, end_of_file, avail, waiting) if (char_waiting == 1) { *avail = 1; - *ch = getch(); - (*winflush_function)(); + *ch = getch (); + (*winflush_function) (); if (*ch == eot_ch) *end_of_file = 1; @@ -490,13 +495,94 @@ getc_immediate_common (stream, ch, end_of_file, avail, waiting) } } else -#endif -#endif +#elif defined (__vxworks) + /* Bit masks of file descriptors to read from. */ + struct fd_set readFds; + /* Timeout before select returns if nothing can be read. */ + struct timeval timeOut; + char c; + int fd = fileno (stream); + int nread; + int option; + int readable; + int status; + int width; + + if (isatty (fd)) + { + /* If we do not want to wait, we have to set up fd in RAW mode. This + should be done outside this function as setting fd in RAW mode under + vxWorks flushes the buffer of fd. If the RAW mode was set here, the + buffer would be empty and we would always return that no character + is available */ + if (! waiting) + { + /* Initialization of timeOut for its use with select. */ + timeOut.tv_sec = 0; + timeOut.tv_usec = 0; + + /* Initialization of readFds for its use with select; + FD is the only file descriptor to be monitored */ + FD_ZERO (&readFds); + FD_SET (fd, &readFds); + width = 2; + + /* We do all this processing to emulate a non blocking read. */ + readable = select (width, &readFds, NULL, NULL, &timeOut); + if (readable == ERROR) + *avail = -1, *end_of_file = -1; + /* No character available in input. */ + else if (readable == 0) + *avail = 0, *end_of_file = 0; + else + { + nread = read (fd, &c, 1); + if (nread > 0) + *avail = 1, *end_of_file = 0; + /* End Of File. */ + else if (nread == 0) + *avail = 0, *end_of_file = 1; + /* Error. */ + else + *avail = -1, *end_of_file = -1; + } + } + + /* We have to wait until we get a character */ + else + { + *avail = -1; + *end_of_file = -1; + + /* Save the current mode of FD. */ + option = ioctl (fd, FIOGETOPTIONS, 0); + + /* Set FD in RAW mode. */ + status = ioctl (fd, FIOSETOPTIONS, OPT_RAW); + if (status != -1) + { + nread = read (fd, &c, 1); + if (nread > 0) + *avail = 1, *end_of_file = 0; + /* End of file. */ + else if (nread == 0) + *avail = 0, *end_of_file = 1; + /* Else there is an ERROR. */ + } + + /* Revert FD to its previous mode. */ + status = ioctl (fd, FIOSETOPTIONS, option); + } + + *ch = c; + } + else #endif { /* If we're not on a terminal, then we don't need any fancy processing. Also this is the only thing that's left if we're not on one of the - supported systems. */ + supported systems; which means that for non supported systems, + get_immediate may wait for a carriage return on terminals. */ *ch = fgetc (stream); if (feof (stream)) { @@ -584,7 +670,7 @@ extern void (*Unlock_Task) PARAMS ((void)); provide localtime_r, but in the library libc_r which doesn't get included systematically, so we can't use it. */ -exrern void struct tm *__gnat_localtime_r PARAMS ((const time_t *, +extern void struct tm *__gnat_localtime_r PARAMS ((const time_t *, struct tm *)); struct tm * diff --git a/gcc/ada/system.ads b/gcc/ada/system.ads index a6f849e2719..73b2ca4dcc9 100644 --- a/gcc/ada/system.ads +++ b/gcc/ada/system.ads @@ -7,9 +7,9 @@ -- S p e c -- -- (Compiler Version) -- -- -- --- $Revision: 1.48 $ +-- $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 -- @@ -38,6 +38,11 @@ -- -- ------------------------------------------------------------------------------ +-- This version of System is a generic version that is used in building +-- the compiler. Right now, we have a host/target problem if we try to +-- use the "proper" System, and since the compiler itself does not care +-- about most System parameters, this generic version works fine. + package System is pragma Pure (System); -- Note that we take advantage of the implementation permission to @@ -60,7 +65,7 @@ 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 @@ -93,27 +98,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 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; + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; - Default_Priority : constant Priority := - Standard."/" (Standard."+" (Priority'First, Priority'Last), 2); + Default_Priority : constant Priority := 15; private @@ -138,8 +130,11 @@ private -- do not use floating-point anyway in the compiler). 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; diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb index f8084691e35..29fc5af9084 100644 --- a/gcc/ada/table.adb +++ b/gcc/ada/table.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -35,9 +35,12 @@ with Debug; use Debug; with Opt; -with Output; use Output; -with System; use System; -with Tree_IO; use Tree_IO; +with Output; use Output; +pragma Elaborate_All (Output); +with System; use System; +with Tree_IO; use Tree_IO; +with System.Memory; use System.Memory; +with System.Address_To_Access_Conversions; package body Table is package body Table is @@ -49,9 +52,6 @@ package body Table is -- Number of entries in currently allocated table. The value of zero -- ensures that we initially allocate the table. - procedure free (T : Table_Ptr); - pragma Import (C, free); - ----------------------- -- Local Subprograms -- ----------------------- @@ -65,6 +65,18 @@ package body Table is -- Return Null_Address if the table length is zero, -- Table (First)'Address if not. + package Table_Conversions is + new System.Address_To_Access_Conversions (Big_Table_Type); + -- Address and Access conversions for a Table object. + + function To_Address (Table : Table_Ptr) return Address; + pragma Inline (To_Address); + -- Returns the Address for the Table object. + + function To_Pointer (Table : Address) return Table_Ptr; + pragma Inline (To_Pointer); + -- Returns the Access pointer for the Table object. + ------------ -- Append -- ------------ @@ -90,7 +102,7 @@ package body Table is procedure Free is begin - free (Table); + Free (To_Address (Table)); Table := null; Length := 0; end Free; @@ -151,19 +163,7 @@ package body Table is ---------------- procedure Reallocate is - - function realloc - (memblock : Table_Ptr; - size : size_t) - return Table_Ptr; - pragma Import (C, realloc); - - function malloc - (size : size_t) - return Table_Ptr; - pragma Import (C, malloc); - - New_Size : size_t; + New_Size : Memory.size_t; begin if Max < Last_Val then @@ -191,17 +191,16 @@ package body Table is end if; New_Size := - size_t ((Max - Min + 1) * - (Table_Type'Component_Size / Storage_Unit)); + Memory.size_t ((Max - Min + 1) * + (Table_Type'Component_Size / Storage_Unit)); if Table = null then - Table := malloc (New_Size); + Table := To_Pointer (Alloc (New_Size)); elsif New_Size > 0 then Table := - realloc - (memblock => Table, - size => New_Size); + To_Pointer (Realloc (Ptr => To_Address (Table), + Size => New_Size)); end if; if Length /= 0 and then Table = null then @@ -231,7 +230,7 @@ package body Table is procedure Restore (T : Saved_Table) is begin - free (Table); + Free (To_Address (Table)); Last_Val := T.Last_Val; Max := T.Max; Table := T.Table; @@ -289,6 +288,25 @@ package body Table is end if; end Set_Last; + ---------------- + -- To_Address -- + ---------------- + + function To_Address (Table : Table_Ptr) return Address is + begin + return Table_Conversions.To_Address + (Table_Conversions.Object_Pointer (Table)); + end To_Address; + + ---------------- + -- To_Pointer -- + ---------------- + + function To_Pointer (Table : Address) return Table_Ptr is + begin + return Table_Ptr (Table_Conversions.To_Pointer (Table)); + end To_Pointer; + ---------------------------- -- Tree_Get_Table_Address -- ---------------------------- diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index 9e823d89971..6192b09199d 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.15 $ +-- $Revision$ -- -- -- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- -- -- @@ -30,23 +30,43 @@ with Namet; use Namet; with Output; use Output; with Sinput; use Sinput; with Sinput.L; use Sinput.L; -with Fname.UF; use Fname.UF; with Types; use Types; package body Targparm is type Targparm_Tags is - (AAM, CLA, DEN, DSP, FEL, HIM, LSI, MOV, - MRN, SCD, SCP, SNZ, UAM, VMS, ZCD, ZCG, ZCF); + (AAM, -- AAMP; + BDC, -- Backend_Divide_Checks; + BOC, -- Backend_Overflow_Checks; + CLA, -- Command_Line_Args; + DEN, -- Denorm; + DSP, -- Functions_Return_By_DSP; + FEL, -- Frontend_Layout; + FFO, -- Fractional_Fixed_Ops + HIM, -- High_Integrity_Mode; + LSI, -- Long_Shifts_Inlined; + MOV, -- Machine_Overflows; + MRN, -- Machine_Rounds; + SCD, -- Stack_Check_Default; + SCP, -- Stack_Check_Probes; + SNZ, -- Signed_Zeros; + UAM, -- Use_Ada_Main_Program_Name; + VMS, -- OpenVMS; + ZCD, -- ZCX_By_Default; + ZCG, -- GCC_ZCX_Support; + ZCF); -- Front_End_ZCX_Support; Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False); -- Flag is set True if corresponding parameter is scanned AAM_Str : aliased constant Source_Buffer := "AAMP"; + BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks"; + BOC_Str : aliased constant Source_Buffer := "Backend_Overflow_Checks"; CLA_Str : aliased constant Source_Buffer := "Command_Line_Args"; DEN_Str : aliased constant Source_Buffer := "Denorm"; DSP_Str : aliased constant Source_Buffer := "Functions_Return_By_DSP"; FEL_Str : aliased constant Source_Buffer := "Frontend_Layout"; + FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops"; HIM_Str : aliased constant Source_Buffer := "High_Integrity_Mode"; LSI_Str : aliased constant Source_Buffer := "Long_Shifts_Inlined"; MOV_Str : aliased constant Source_Buffer := "Machine_Overflows"; @@ -63,10 +83,13 @@ package body Targparm is type Buffer_Ptr is access constant Source_Buffer; Targparm_Str : array (Targparm_Tags) of Buffer_Ptr := (AAM_Str'Access, + BDC_Str'Access, + BOC_Str'Access, CLA_Str'Access, DEN_Str'Access, DSP_Str'Access, FEL_Str'Access, + FFO_Str'Access, HIM_Str'Access, LSI_Str'Access, MOV_Str'Access, @@ -100,9 +123,9 @@ package body Targparm is -- Records boolean from system line begin - Name_Buffer (1 .. 6) := "system"; - Name_Len := 6; - N := File_Name_Of_Spec (Name_Find); + Name_Buffer (1 .. 10) := "system.ads"; + Name_Len := 10; + N := Name_Find; S := Load_Source_File (N); if S = No_Source_File then @@ -163,10 +186,13 @@ package body Targparm is case K is when AAM => AAMP_On_Target := Result; + when BDC => Backend_Divide_Checks_On_Target := Result; + when BOC => Backend_Overflow_Checks_On_Target := Result; when CLA => Command_Line_Args_On_Target := Result; when DEN => Denorm_On_Target := Result; when DSP => Functions_Return_By_DSP_On_Target := Result; when FEL => Frontend_Layout_On_Target := Result; + when FFO => Fractional_Fixed_Ops_On_Target := Result; when HIM => High_Integrity_Mode_On_Target := Result; when LSI => Long_Shifts_Inlined_On_Target := Result; when MOV => Machine_Overflows_On_Target := Result; diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index 2346fd209e7..229ef937fd8 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.13 $ +-- $Revision$ -- -- -- Copyright (C) 1999-2001 Free Software Foundation, Inc. -- -- -- @@ -49,7 +49,32 @@ package Targparm is -- The following parameters correspond to the variables defined in the -- private part of System (without the terminating _On_Target). Note - -- that it is required that all parameters be specified in system.ads. + -- that it is required that all parameters defined here be specified + -- in the target specific version of system.ads (there are no defaults). + + -- All these parameters should be regarded as read only by all clients + -- of the package. The only way they get modified is by calling the + -- Get_Target_Parameters routine which reads the values from System. + + ------------------------------- + -- Backend Arithmetic Checks -- + ------------------------------- + + -- Divide and overflow checks are either done in the front end or + -- back end. The front end will generate checks when required unless + -- the corresponding parameter here is set to indicate that the back + -- end will generate the required checks (or that the checks are + -- automatically performed by the hardware in an appropriate form). + + Backend_Divide_Checks_On_Target : Boolean; + -- Set True if the back end generates divide checks, or if the hardware + -- checks automatically. Set False if the front end must generate the + -- required tests using explicit expanded code. + + Backend_Overflow_Checks_On_Target : Boolean; + -- Set True if the back end generates arithmetic overflow checks, or if + -- the hardware checks automatically. Set False if the front end must + -- generate the required tests using explicit expanded code. ----------------------------------- -- Control of Exception Handling -- @@ -75,8 +100,7 @@ package Targparm is -- available. ZCX_By_Default_On_Target : Boolean; - -- Indicates if zero cost exceptions are active by default. Can be modified - -- by the use of -gnatZ and -gnatL switches. + -- Indicates if zero cost exceptions are active by default. GCC_ZCX_Support_On_Target : Boolean; -- Indicates that when ZCX is active the mechanism to be used is the @@ -225,6 +249,16 @@ package Targparm is OpenVMS_On_Target : Boolean; -- Set to True if target is OpenVMS. + ------------------------------------------- + -- Boolean-Valued Fixed-Point Attributes -- + ------------------------------------------- + + Fractional_Fixed_Ops_On_Target : Boolean; + -- Set to True for targets that support fixed-by-fixed multiplication + -- and division for fixed-point types with a small value equal to + -- 2 ** (-(T'Object_Size - 1)) and whose values have an absolute + -- value less than 1.0. + -------------------------------------------------------------- -- Handling of Unconstrained Values Returned from Functions -- -------------------------------------------------------------- diff --git a/gcc/ada/targtyps.c b/gcc/ada/targtyps.c index 900762b2e1e..85c1de44cf7 100644 --- a/gcc/ada/targtyps.c +++ b/gcc/ada/targtyps.c @@ -6,7 +6,7 @@ * * * Body * * * - * $Revision: 1.1 $ + * $Revision$ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * @@ -55,44 +55,10 @@ #include "ada-tree.h" #include "gigi.h" -#define MIN(X,Y) ((X) < (Y) ? (X) : (Y)) - -/* Standard data type sizes. Most of these are not used. */ - -#ifndef CHAR_TYPE_SIZE -#define CHAR_TYPE_SIZE BITS_PER_UNIT -#endif - -#ifndef SHORT_TYPE_SIZE -#define SHORT_TYPE_SIZE (BITS_PER_UNIT * MIN ((UNITS_PER_WORD + 1) / 2, 2)) -#endif - -#ifndef INT_TYPE_SIZE -#define INT_TYPE_SIZE BITS_PER_WORD -#endif - -#ifdef OPEN_VMS /* A target macro defined in vms.h */ -#define LONG_TYPE_SIZE 64 -#else -#ifndef LONG_TYPE_SIZE -#define LONG_TYPE_SIZE BITS_PER_WORD -#endif -#endif - -#ifndef LONG_LONG_TYPE_SIZE -#define LONG_LONG_TYPE_SIZE (BITS_PER_WORD * 2) -#endif - -#ifndef FLOAT_TYPE_SIZE -#define FLOAT_TYPE_SIZE BITS_PER_WORD -#endif - -#ifndef DOUBLE_TYPE_SIZE -#define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) -#endif - -#ifndef LONG_DOUBLE_TYPE_SIZE -#define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) +/* If we don't have a specific size for Ada's equivalent of `long', use that + of C. */ +#ifndef ADA_LONG_TYPE_SIZE +#define ADA_LONG_TYPE_SIZE LONG_TYPE_SIZE #endif #ifndef WIDEST_HARDWARE_FP_SIZE @@ -142,7 +108,7 @@ get_target_int_size () Pos get_target_long_size () { - return LONG_TYPE_SIZE; + return ADA_LONG_TYPE_SIZE; } Pos diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 3ccd7a7472e..b8ac33addc3 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.98 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -108,6 +108,29 @@ package body Tbuild is end if; end Convert_To; + ------------------------------------------- + -- Make_Byte_Aligned_Attribute_Reference -- + ------------------------------------------- + + function Make_Byte_Aligned_Attribute_Reference + (Sloc : Source_Ptr; + Prefix : Node_Id; + Attribute_Name : Name_Id) + return Node_Id + is + N : constant Node_Id := + Make_Attribute_Reference (Sloc, + Prefix => Prefix, + Attribute_Name => Attribute_Name); + + begin + pragma Assert (Attribute_Name = Name_Address + or else + Attribute_Name = Name_Unrestricted_Access); + Set_Must_Be_Byte_Aligned (N, True); + return N; + end Make_Byte_Aligned_Attribute_Reference; + -------------------- -- Make_DT_Access -- -------------------- @@ -244,6 +267,63 @@ package body Tbuild is return Make_Integer_Literal (Loc, UI_From_Int (Intval)); end Make_Integer_Literal; + --------------------------------- + -- Make_Raise_Constraint_Error -- + --------------------------------- + + function Make_Raise_Constraint_Error + (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Reason : RT_Exception_Code) + return Node_Id + is + begin + pragma Assert (Reason in RT_CE_Exceptions); + return + Make_Raise_Constraint_Error (Sloc, + Condition => Condition, + Reason => + UI_From_Int (RT_Exception_Code'Pos (Reason))); + end Make_Raise_Constraint_Error; + + ------------------------------ + -- Make_Raise_Program_Error -- + ------------------------------ + + function Make_Raise_Program_Error + (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Reason : RT_Exception_Code) + return Node_Id + is + begin + pragma Assert (Reason in RT_PE_Exceptions); + return + Make_Raise_Program_Error (Sloc, + Condition => Condition, + Reason => + UI_From_Int (RT_Exception_Code'Pos (Reason))); + end Make_Raise_Program_Error; + + ------------------------------ + -- Make_Raise_Storage_Error -- + ------------------------------ + + function Make_Raise_Storage_Error + (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Reason : RT_Exception_Code) + return Node_Id + is + begin + pragma Assert (Reason in RT_SE_Exceptions); + return + Make_Raise_Storage_Error (Sloc, + Condition => Condition, + Reason => + UI_From_Int (RT_Exception_Code'Pos (Reason))); + end Make_Raise_Storage_Error; + --------------------------- -- Make_Unsuppress_Block -- --------------------------- diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index b2b2176ae2d..9db4a54a958 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.1 $ +-- $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- -- @@ -33,6 +33,31 @@ with Types; use Types; package Tbuild is + function Checks_Off (N : Node_Id) return Node_Id; + pragma Inline (Checks_Off); + -- Returns an N_Unchecked_Expression node whose expression is the given + -- argument. The results is a subexpression identical to the argument, + -- except that it will be analyzed and resolved with checks off. + + function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id; + -- Returns an expression that represents the result of a checked convert + -- of expression Exp to type T. If the base type of Exp is T, then no + -- conversion is required, and Exp is returned unchanged. Otherwise an + -- N_Type_Conversion node is constructed to convert the expression. + -- If an N_Type_Conversion node is required, Relocate_Node is used on + -- Exp. This means that it is safe to replace a node by a Convert_To + -- of itself to some other type. + + function Make_Byte_Aligned_Attribute_Reference + (Sloc : Source_Ptr; + Prefix : Node_Id; + Attribute_Name : Name_Id) + return Node_Id; + pragma Inline (Make_Byte_Aligned_Attribute_Reference); + -- Like the standard Make_Attribute_Reference but the special flag + -- Must_Be_Byte_Aligned is set in the attribute reference node. The + -- Attribute_Name must be Name_Address or Name_Unrestricted_Access. + function Make_DT_Component (Loc : Source_Ptr; Typ : Entity_Id; @@ -101,6 +126,33 @@ package Tbuild is pragma Inline (Make_Integer_Literal); -- A convenient form of Make_Integer_Literal taking Int instead of Uint + function Make_Raise_Constraint_Error + (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Reason : RT_Exception_Code) + return Node_Id; + pragma Inline (Make_Raise_Constraint_Error); + -- A convenient form of Make_Raise_Constraint_Error where the Reason + -- is given simply as an enumeration value, rather than a Uint code. + + function Make_Raise_Program_Error + (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Reason : RT_Exception_Code) + return Node_Id; + pragma Inline (Make_Raise_Program_Error); + -- A convenient form of Make_Raise_Program_Error where the Reason + -- is given simply as an enumeration value, rather than a Uint code. + + function Make_Raise_Storage_Error + (Sloc : Source_Ptr; + Condition : Node_Id := Empty; + Reason : RT_Exception_Code) + return Node_Id; + pragma Inline (Make_Raise_Storage_Error); + -- A convenient form of Make_Raise_Storage_Error where the Reason + -- is given simply as an enumeration value, rather than a Uint code. + function Make_Unsuppress_Block (Loc : Source_Ptr; Check : Name_Id; @@ -183,16 +235,6 @@ package Tbuild is -- of sources, the numbers will be consistent. This means that it is fine -- to use these as public symbols. - function New_Suffixed_Name - (Related_Id : Name_Id; - Suffix : String) - return Name_Id; - -- This function is used to create special suffixed names used by the - -- debugger. Suffix is a string of upper case letters, used to construct - -- the required name. For instance, the special type used to record the - -- fixed-point small is called typ_SMALL where typ is the name of the - -- fixed-point type (as passed in Related_Id), and Suffix is "SMALL". - function New_Occurrence_Of (Def_Id : Entity_Id; Loc : Source_Ptr) @@ -212,20 +254,15 @@ package Tbuild is -- It is used from the expander, where Etype fields are generally not set, -- since they are set when the expanded tree is reanalyzed. - function Checks_Off (N : Node_Id) return Node_Id; - pragma Inline (Checks_Off); - -- Returns an N_Unchecked_Expression node whose expression is the given - -- argument. The results is a subexpression identical to the argument, - -- except that it will be analyzed and resolved with checks off. - - function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id; - -- Returns an expression that represents the result of a checked convert - -- of expression Exp to type T. If the base type of Exp is T, then no - -- conversion is required, and Exp is returned unchanged. Otherwise an - -- N_Type_Conversion node is constructed to convert the expression. - -- If an N_Type_Conversion node is required, Relocate_Node is used on - -- Exp. This means that it is safe to replace a node by a Convert_To - -- of itself to some other type. + function New_Suffixed_Name + (Related_Id : Name_Id; + Suffix : String) + return Name_Id; + -- This function is used to create special suffixed names used by the + -- debugger. Suffix is a string of upper case letters, used to construct + -- the required name. For instance, the special type used to record the + -- fixed-point small is called typ_SMALL where typ is the name of the + -- fixed-point type (as passed in Related_Id), and Suffix is "SMALL". function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id; -- Like Convert_To, except that a conversion node is always generated, diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index 287e8d4608b..1a489420861 100644 --- a/gcc/ada/tracebak.c +++ b/gcc/ada/tracebak.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * $Revision: 1.2 $ + * $Revision$ * * * Copyright (C) 2000-2001 Ada Core Technologies, Inc. * * * @@ -144,14 +144,43 @@ struct layout void *return_address; }; +#ifdef _WIN32 +/* _image_base__ is the image starting address, no stack addresses should be + under this value */ +extern unsigned int _image_base__; +#define LOWEST_ADDR ((unsigned int) (&_image_base__)) +#else +#define LOWEST_ADDR 0 +#endif + #define FRAME_LEVEL 0 #define FRAME_OFFSET 0 #define SKIP_FRAME 1 #define PC_ADJUST -2 #define STOP_FRAME(CURRENT, TOP_STACK) \ - ((CURRENT)->return_address == 0|| (CURRENT)->next == 0 \ + ((unsigned int)(CURRENT)->return_address < LOWEST_ADDR \ + || (CURRENT)->return_address == 0|| (CURRENT)->next == 0 \ || (void *) (CURRENT) < (TOP_STACK)) +/* On i386 architecture we check that at the call point we really have a call + insn. Possible call instructions are: + + call addr16 E8 xx xx xx xx + call reg FF Dx + call off(reg) FF xx xx + lcall addr seg 9A xx xx xx xx xx xx + + This check will not catch all cases but it will increase the backtrace + reliability on this architecture. +*/ + +#define VALID_STACK_FRAME(ptr) \ + (((*((ptr) - 3) & 0xff) == 0xe8) \ + || ((*((ptr) - 4) & 0xff) == 0x9a) \ + || ((*((ptr) - 2) & 0xff) == 0xff) \ + || (((*((ptr) - 1) & 0xff00) == 0xff00) \ + && ((*((ptr) - 1) & 0xf0) == 0xd0))) + #elif defined (__alpha_vxworks) #define SKIP_FRAME 1 @@ -192,6 +221,10 @@ segv_handler (ignored) } #endif +#ifndef VALID_STACK_FRAME +#define VALID_STACK_FRAME(ptr) 1 +#endif + int __gnat_backtrace (array, size, exclude_min, exclude_max) void **array; @@ -236,7 +269,8 @@ __gnat_backtrace (array, size, exclude_min, exclude_max) cnt = 0; while (cnt < size) { - if (STOP_FRAME (current, top_stack)) + if (STOP_FRAME (current, top_stack) || + !VALID_STACK_FRAME((char *)(current->return_address + PC_ADJUST))) break; if (current->return_address < exclude_min diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index 7c376e5b2d8..0375dbf0274 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -6,9 +6,9 @@ * * * C Implementation File * * * - * $Revision: 1.10 $ + * $Revision$ * * - * Copyright (C) 1992-2001, 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- * @@ -35,6 +35,7 @@ #include "expr.h" #include "ggc.h" #include "function.h" +#include "except.h" #include "debug.h" #include "output.h" #include "ada.h" @@ -85,7 +86,7 @@ tree gnu_block_stack; /* List of TREE_LIST nodes representing a stack of exception pointer variables. TREE_VALUE is the VAR_DECL that stores the address of the raised exception. Nonzero means we are in an exception - handler. Set to error_mark_node in the zero-cost case. */ + handler. Not used in the zero-cost case. */ static tree gnu_except_ptr_stack; /* Map GNAT tree codes to GCC tree codes for simple expressions. */ @@ -108,7 +109,7 @@ static tree emit_access_check PARAMS((tree)); static tree emit_discriminant_check PARAMS((tree, Node_Id)); static tree emit_range_check PARAMS((tree, Node_Id)); static tree emit_index_check PARAMS((tree, tree, tree, tree)); -static tree emit_check PARAMS((tree, tree)); +static tree emit_check PARAMS((tree, tree, int)); static tree convert_with_check PARAMS((Entity_Id, tree, int, int, int)); static int addressable_p PARAMS((tree)); @@ -127,17 +128,13 @@ static REAL_VALUE_TYPE dconstmp5; structures and then generates code. */ void -gigi (gnat_root, max_gnat_node, number_name, - nodes_ptr, next_node_ptr, prev_node_ptr, elists_ptr, elmts_ptr, - strings_ptr, string_chars_ptr, list_headers_ptr, - number_units, file_info_ptr, - standard_integer, standard_long_long_float, standard_exception_type, - gigi_operating_mode) - +gigi (gnat_root, max_gnat_node, number_name, nodes_ptr, next_node_ptr, + prev_node_ptr, elists_ptr, elmts_ptr, strings_ptr, string_chars_ptr, + list_headers_ptr, number_units, file_info_ptr, standard_integer, + standard_long_long_float, standard_exception_type, gigi_operating_mode) Node_Id gnat_root; int max_gnat_node; int number_name; - struct Node *nodes_ptr; Node_Id *next_node_ptr; Node_Id *prev_node_ptr; @@ -148,11 +145,9 @@ gigi (gnat_root, max_gnat_node, number_name, struct List_Header *list_headers_ptr; Int number_units ATTRIBUTE_UNUSED; char *file_info_ptr ATTRIBUTE_UNUSED; - Entity_Id standard_integer; Entity_Id standard_long_long_float; Entity_Id standard_exception_type; - Int gigi_operating_mode; { tree gnu_standard_long_long_float; @@ -160,14 +155,14 @@ gigi (gnat_root, max_gnat_node, number_name, max_gnat_nodes = max_gnat_node; number_names = number_name; - Nodes_Ptr = nodes_ptr - First_Node_Id; - Next_Node_Ptr = next_node_ptr - First_Node_Id; - Prev_Node_Ptr = prev_node_ptr - First_Node_Id; - Elists_Ptr = elists_ptr - First_Elist_Id; - Elmts_Ptr = elmts_ptr - First_Elmt_Id; - Strings_Ptr = strings_ptr - First_String_Id; + Nodes_Ptr = nodes_ptr; + Next_Node_Ptr = next_node_ptr; + Prev_Node_Ptr = prev_node_ptr; + Elists_Ptr = elists_ptr; + Elmts_Ptr = elmts_ptr; + Strings_Ptr = strings_ptr; String_Chars_Ptr = string_chars_ptr; - List_Headers_Ptr = list_headers_ptr - First_List_Id; + List_Headers_Ptr = list_headers_ptr; type_annotate_only = (gigi_operating_mode == 1); @@ -209,17 +204,7 @@ gigi (gnat_root, max_gnat_node, number_name, init_gigi_decls (gnu_standard_long_long_float, gnu_standard_exception_type); - /* Emit global symbols containing context list info for the SGI Workshop - debugger */ - -#ifdef MIPS_DEBUGGING_INFO - if (Spec_Context_List != 0) - emit_unit_label (Spec_Context_List, Spec_Filename); - - if (Body_Context_List != 0) - emit_unit_label (Body_Context_List, Body_Filename); -#endif - + /* Process any Pragma Ident for the main unit. */ #ifdef ASM_OUTPUT_IDENT if (Present (Ident_String (Main_Unit))) ASM_OUTPUT_IDENT @@ -227,6 +212,10 @@ gigi (gnat_root, max_gnat_node, number_name, TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit)))); #endif + /* If we are using the GCC exception mechanism, let GCC know. */ + if (Exception_Mechanism == GCC_ZCX) + gnat_init_gcc_eh (); + gnat_to_code (gnat_root); } @@ -336,7 +325,7 @@ tree_transform (gnat_node) return error_mark_node; else return build1 (NULL_EXPR, gnu_result_type, - build_call_raise (raise_constraint_error_decl)); + build_call_raise (CE_Range_Check_Failed)); } switch (Nkind (gnat_node)) @@ -505,29 +494,13 @@ tree_transform (gnat_node) gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type); - /* Get the type of the result, looking inside any padding and - left-justified modular types. Then get the value in that type. */ - gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type)) - gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); - gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type); - - /* If the result overflows (meaning it doesn't fit in its base type) - or is outside of the range of the subtype, we have an illegal tree - entry, so abort. Note that the test for of types with biased - representation is harder, so we don't test in that case. */ - if (TREE_CONSTANT_OVERFLOW (gnu_result) - || (TREE_CODE (TYPE_MIN_VALUE (gnu_result_type)) == INTEGER_CST - && ! TYPE_BIASED_REPRESENTATION_P (gnu_result_type) - && tree_int_cst_lt (gnu_result, - TYPE_MIN_VALUE (gnu_result_type))) - || (TREE_CODE (TYPE_MAX_VALUE (gnu_result_type)) == INTEGER_CST - && ! TYPE_BIASED_REPRESENTATION_P (gnu_result_type) - && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_result_type), - gnu_result))) + /* If the result overflows (meaning it doesn't fit in its base type), + abort. We would like to check that the value is within the range + of the subtype, but that causes problems with subtypes whose usage + will raise Constraint_Error and with biased representation, so + we don't. */ + if (TREE_CONSTANT_OVERFLOW (gnu_result)) gigi_abort (305); } break; @@ -800,14 +773,13 @@ tree_transform (gnat_node) gnat_temp = Defining_Entity (gnat_node); - /* Don't do anything if this renaming handled by the front end. - or if we are just annotating types and this object has an - unconstrained or task type, don't elaborate it. */ + /* Don't do anything if this renaming is handled by the front end. + or if we are just annotating types and this object has a + composite or task type, don't elaborate it. */ if (! Is_Renaming_Of_Object (gnat_temp) && ! (type_annotate_only - && (((Is_Array_Type (Etype (gnat_temp)) - || Is_Record_Type (Etype (gnat_temp))) - && ! Is_Constrained (Etype (gnat_temp))) + && (Is_Array_Type (Etype (gnat_temp)) + || Is_Record_Type (Etype (gnat_temp)) || Is_Concurrent_Type (Etype (gnat_temp))))) { gnu_expr = gnat_to_gnu (Renamed_Object (gnat_temp)); @@ -1028,13 +1000,11 @@ tree_transform (gnat_node) /* If there are discriminants, the prefix might be evaluated more than once, which is a problem if it has side-effects. */ - if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node))) ? Designated_Type (Etype (Prefix (gnat_node))) - : Etype (Prefix (gnat_node))) - && TREE_SIDE_EFFECTS (gnu_prefix)) - gnu_prefix = make_save_expr (gnu_prefix); + : Etype (Prefix (gnat_node)))) + gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0); /* Emit discriminant check if necessary. */ if (Do_Discriminant_Check (gnat_node)) @@ -1109,7 +1079,7 @@ tree_transform (gnat_node) if (Do_Range_Check (First (Expressions (gnat_node)))) { - gnu_expr = make_save_expr (gnu_expr); + gnu_expr = protect_multiple_eval (gnu_expr); gnu_expr = emit_check (build_binary_op (EQ_EXPR, integer_type_node, @@ -1117,7 +1087,7 @@ tree_transform (gnat_node) attribute == Attr_Pred ? TYPE_MIN_VALUE (gnu_result_type) : TYPE_MAX_VALUE (gnu_result_type)), - gnu_expr); + gnu_expr, CE_Range_Check_Failed); } gnu_result @@ -1132,7 +1102,9 @@ tree_transform (gnat_node) /* Conversions don't change something's address but can cause us to miss the COMPONENT_REF case below, so strip them off. */ - gnu_prefix = remove_conversions (gnu_prefix); + gnu_prefix + = remove_conversions (gnu_prefix, + ! Must_Be_Byte_Aligned (gnat_node)); /* If we are taking 'Address of an unconstrained object, this is the pointer to the underlying array. */ @@ -1146,8 +1118,9 @@ tree_transform (gnat_node) gnu_result_type = get_unpadded_type (Etype (gnat_node)); gnu_result - = build_unary_op (attribute == Attr_Address - || attribute == Attr_Unrestricted_Access + = build_unary_op (((attribute == Attr_Address + || attribute == Attr_Unrestricted_Access) + && ! Must_Be_Byte_Aligned (gnat_node)) ? ATTR_ADDR_EXPR : ADDR_EXPR, gnu_result_type, gnu_prefix); @@ -1180,7 +1153,7 @@ tree_transform (gnat_node) while (TREE_CODE (gnu_expr) == NOP_EXPR) gnu_expr = TREE_OPERAND (gnu_expr, 0); - gnu_prefix = remove_conversions (gnu_prefix); + gnu_prefix = remove_conversions (gnu_prefix, 1); prefix_unused = 1; gnu_type = TREE_TYPE (gnu_prefix); @@ -1423,7 +1396,7 @@ tree_transform (gnat_node) int unsignedp, volatilep; gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_prefix = remove_conversions (gnu_prefix); + gnu_prefix = remove_conversions (gnu_prefix, 1); prefix_unused = 1; /* We can have 'Bit on any object, but if it isn't a @@ -1445,7 +1418,6 @@ tree_transform (gnat_node) get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset, &mode, &unsignedp, &volatilep); - if (TREE_CODE (gnu_prefix) == COMPONENT_REF) { gnu_field_bitpos @@ -1485,13 +1457,11 @@ tree_transform (gnat_node) gnu_result = gnu_field_offset; break; - case Attr_First_Bit: case Attr_Bit: gnu_result = size_int (bitpos % BITS_PER_UNIT); break; - case Attr_Last_Bit: gnu_result = bitsize_int (bitpos % BITS_PER_UNIT); gnu_result @@ -1611,8 +1581,12 @@ tree_transform (gnat_node) } /* If this is an attribute where the prefix was unused, - force a use of it if it has a side-effect. */ - if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)) + force a use of it if it has a side-effect. But don't do it if + the prefix is just an entity name. However, if an access check + is needed, we must do it. See second example in AARM 11.6(5.e). */ + if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix) + && (! Is_Entity_Name (Prefix (gnat_node)) + || Do_Access_Check (gnat_node))) gnu_result = fold (build (COMPOUND_EXPR, TREE_TYPE (gnu_result), gnu_prefix, gnu_result)); } @@ -1717,7 +1691,7 @@ tree_transform (gnat_node) = TREE_CODE (gnu_obj_type) == FUNCTION_TYPE ? FUNCTION_BOUNDARY : TYPE_ALIGN (gnu_obj_type); - if (align != 0 && align < oalign && ! TYPE_ALIGN_OK_P (gnu_obj_type)) + if (align != 0 && align < oalign && ! TYPE_ALIGN_OK (gnu_obj_type)) post_error_ne_tree_2 ("?source alignment (^) < alignment of & (^)", gnat_node, Designated_Type (Etype (gnat_node)), @@ -1763,7 +1737,7 @@ tree_transform (gnat_node) gnu_object, gnu_low); else { - gnu_object = make_save_expr (gnu_object); + gnu_object = protect_multiple_eval (gnu_object); gnu_result = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, build_binary_op (GE_EXPR, gnu_result_type, @@ -2071,7 +2045,7 @@ tree_transform (gnat_node) && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs)))) || (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs))) == INTEGER_CST && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs))))) - expand_expr_stmt (build_call_raise (raise_storage_error_decl)); + expand_expr_stmt (build_call_raise (SE_Object_Too_Large)); else expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs)); @@ -2220,7 +2194,12 @@ tree_transform (gnat_node) /* After compiling the choices attached to the WHEN compile the body of statements that have to be executed, should the - "WHEN ... =>" be taken. */ + "WHEN ... =>" be taken. Push a binding level here in case + variables are declared since we want them to be local to this + set of statements instead of the block containing the Case + statement. */ + pushlevel (0); + expand_start_bindings (0); for (gnat_statement = First (Statements (gnat_when)); Present (gnat_statement); gnat_statement = Next (gnat_statement)) @@ -2229,6 +2208,8 @@ tree_transform (gnat_node) /* Communicate to GCC that we are done with the current WHEN, i.e. insert a "break" statement. */ expand_exit_something (); + expand_end_bindings (getdecls (), kept_level_p (), 0); + poplevel (kept_level_p (), 1, 0); } expand_end_case (gnu_expr); @@ -2582,7 +2563,7 @@ tree_transform (gnat_node) { /* Save debug output mode in case it is reset. */ enum debug_info_type save_write_symbols = write_symbols; - struct gcc_debug_hooks *save_debug_hooks = debug_hooks; + const struct gcc_debug_hooks *const save_debug_hooks = debug_hooks; /* Definining identifier of a parameter to the subprogram. */ Entity_Id gnat_param; /* The defining identifier for the subprogram body. Note that if a @@ -2798,10 +2779,11 @@ tree_transform (gnat_node) gnu_result_type = TREE_TYPE (gnu_subprog_type); gnu_result = build1 (NULL_EXPR, gnu_result_type, - build_call_raise (raise_program_error_decl)); + build_call_raise (PE_Stubbed_Subprogram_Called)); } else - expand_expr_stmt (build_call_raise (raise_program_error_decl)); + expand_expr_stmt + (build_call_raise (PE_Stubbed_Subprogram_Called)); break; } @@ -3062,7 +3044,7 @@ tree_transform (gnat_node) { tree gnu_name; - gnu_subprog_call = make_save_expr (gnu_subprog_call); + gnu_subprog_call = protect_multiple_eval (gnu_subprog_call); /* If any of the names had side-effects, ensure they are all evaluated before the call. */ @@ -3299,6 +3281,37 @@ tree_transform (gnat_node) /***************************/ case N_Handled_Sequence_Of_Statements: + + /* The GCC exception handling mechanism can handle both ZCX and SJLJ + schemes and we have our own SJLJ mechanism. To call the GCC + mechanism, we first call expand_eh_region_start if there is at least + one handler associated with the region. We then generate code for + the region and call expand_start_all_catch to announce that the + associated handlers are going to be generated. + + For each handler we call expand_start_catch, generate code for the + handler, and then call expand_end_catch. + + After all the handlers, we call expand_end_all_catch. + + Here we deal with the region level calls and the + N_Exception_Handler branch deals with the handler level calls + (start_catch/end_catch). + + ??? The region level calls down there have been specifically put in + place for a ZCX context and currently the order in which things are + emitted (region/handlers) is different from the SJLJ case. Instead of + putting other calls with different conditions at other places for the + SJLJ case, it seems cleaner to reorder things for the SJLJ case and + generalize the condition to make it not ZCX specific. */ + + /* Tell the back-end we are starting a new exception region if + necessary. */ + if (! type_annotate_only + && Exception_Mechanism == GCC_ZCX + && Present (Exception_Handlers (gnat_node))) + expand_eh_region_start (); + /* If there are exception handlers, start a new binding level that we can exit (since each exception handler will do so). Then declare a variable to save the old __gnat_jmpbuf value and a @@ -3315,7 +3328,7 @@ tree_transform (gnat_node) pushlevel (0); expand_start_bindings (1); - if (! Zero_Cost_Handling (gnat_node)) + if (Exception_Mechanism == Setjmp_Longjmp) { gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE, @@ -3344,7 +3357,7 @@ tree_transform (gnat_node) expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call); } - if (! Zero_Cost_Handling (gnat_node)) + if (Exception_Mechanism == Setjmp_Longjmp) { /* When we exit this block, restore the saved value. */ expand_decl_cleanup (gnu_jmpsave_decl, @@ -3412,9 +3425,29 @@ tree_transform (gnat_node) /* If there are no exception handlers, we must not have an at end cleanup identifier, since the cleanup identifier should always - generate a corresponding exception handler. */ + generate a corresponding exception handler, except in the case + of the No_Exception_Handlers restriction, where the front-end + does not generate exception handlers. */ else if (! type_annotate_only && Present (At_End_Proc (gnat_node))) - gigi_abort (335); + { + if (No_Exception_Handlers_Set ()) + { + tree gnu_cleanup_call = 0; + tree gnu_cleanup_decl; + + gnu_cleanup_call + = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))); + + gnu_cleanup_decl + = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE, + integer_type_node, NULL_TREE, 0, 0, 0, 0, + 0); + + expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call); + } + else + gigi_abort (335); + } /* Generate code and declarations for the prefix of this block, if any. */ @@ -3429,23 +3462,44 @@ tree_transform (gnat_node) Present (gnat_temp); gnat_temp = Next (gnat_temp)) gnat_to_code (gnat_temp); + /* Tell the back-end we are ending the new exception region and + starting the associated handlers. */ + if (! type_annotate_only + && Exception_Mechanism == GCC_ZCX + && Present (Exception_Handlers (gnat_node))) + expand_start_all_catch (); + /* For zero-cost exceptions, exit the block and then compile the handlers. */ - if (! type_annotate_only && Zero_Cost_Handling (gnat_node) + if (! type_annotate_only + && Exception_Mechanism == GCC_ZCX && Present (Exception_Handlers (gnat_node))) { expand_exit_something (); - gnu_except_ptr_stack - = tree_cons (NULL_TREE, error_mark_node, gnu_except_ptr_stack); - for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp)) gnat_to_code (gnat_temp); + } - gnu_except_ptr_stack = TREE_CHAIN (gnu_except_ptr_stack); + /* We don't support Front_End_ZCX in GNAT 5.0, but we don't want to + crash if -gnatdX is specified. */ + if (! type_annotate_only + && Exception_Mechanism == Front_End_ZCX + && Present (Exception_Handlers (gnat_node))) + { + for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); + Present (gnat_temp); + gnat_temp = Next_Non_Pragma (gnat_temp)) + gnat_to_code (gnat_temp); } + /* Tell the backend when we are done with the handlers. */ + if (! type_annotate_only + && Exception_Mechanism == GCC_ZCX + && Present (Exception_Handlers (gnat_node))) + expand_end_all_catch (); + /* If we have handlers, close the block we made. */ if (! type_annotate_only && Present (Exception_Handlers (gnat_node))) { @@ -3456,7 +3510,7 @@ tree_transform (gnat_node) break; case N_Exception_Handler: - if (! Zero_Cost_Handling (gnat_node)) + if (Exception_Mechanism == Setjmp_Longjmp) { /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make an "if" statement to select the proper @@ -3552,6 +3606,72 @@ tree_transform (gnat_node) expand_start_cond (gnu_choice, 0); } + /* Tell the back end that we start an exception handler if necessary. */ + if (Exception_Mechanism == GCC_ZCX) + { + /* We build a TREE_LIST of nodes representing what exception + types this handler is able to catch, with special cases + for others and all others cases. + + Each exception type is actually identified by a pointer to the + exception id, with special value zero for "others" and one for + "all others". Beware that these special values are known and used + by the personality routine to identify the corresponding specific + kinds of handlers. + + ??? For initial time frame reasons, the others and all_others + cases have been handled using specific type trees, but this + somehow hides information to the back-end, which expects NULL to + be passed for catch all and end_cleanup to be used for cleanups. + + Care should be taken to ensure that the control flow impact of + such clauses is rendered in some way. lang_eh_type_covers is + doing the trick currently. + + ??? Should investigate the possible usage of the end_cleanup + interface in this context. */ + + tree gnu_expr, gnu_etype; + tree gnu_etypes_list = NULL_TREE; + + for (gnat_temp = First (Exception_Choices (gnat_node)); + gnat_temp; gnat_temp = Next (gnat_temp)) + { + if (Nkind (gnat_temp) == N_Others_Choice) + gnu_etype + = All_Others (gnat_temp) ? integer_one_node + : integer_zero_node; + else if (Nkind (gnat_temp) == N_Identifier + || Nkind (gnat_temp) == N_Expanded_Name) + { + gnu_expr = gnat_to_gnu_entity (Entity (gnat_temp), + NULL_TREE, 0); + gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); + } + else + gigi_abort (337); + + gnu_etypes_list + = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list); + + /* The GCC interface expects NULL to be passed for catch all + handlers, so the approach below is quite tempting : + + if (gnu_etype == integer_zero_node) + gnu_etypes_list = NULL; + + It would not work, however, because GCC's notion + of "catch all" is stronger than our notion of "others". + + Until we correctly use the cleanup interface as well, the + two lines above will prevent the "all others" handlers from + beeing seen, because nothing can be caught beyond a catch + all from GCC's point of view. */ + } + + expand_start_catch (gnu_etypes_list); + } + for (gnat_temp = First (Statements (gnat_node)); gnat_temp; gnat_temp = Next (gnat_temp)) gnat_to_code (gnat_temp); @@ -3560,7 +3680,10 @@ tree_transform (gnat_node) in N_Handled_Sequence_Of_Statements. */ expand_exit_something (); - if (! Zero_Cost_Handling (gnat_node)) + /* Tell the back end that we're done with the current handler. */ + if (Exception_Mechanism == GCC_ZCX) + expand_end_catch (); + else if (Exception_Mechanism == Setjmp_Longjmp) expand_end_cond (); break; @@ -3581,7 +3704,6 @@ tree_transform (gnat_node) to be done with them. */ break; - /***************************************************/ /* Chapter 13: Representation Clauses and */ /* Implementation-Dependent Features: */ @@ -3651,9 +3773,11 @@ tree_transform (gnat_node) build_string (strlen (clobber) + 1, clobber), gnu_clobber_list); - expand_asm_operands (gnu_template, nreverse (gnu_output_list), - nreverse (gnu_input_list), gnu_clobber_list, - Is_Asm_Volatile (gnat_node), + gnu_input_list = nreverse (gnu_input_list); + gnu_output_list = nreverse (gnu_output_list); + gnu_orig_out_list = nreverse (gnu_orig_out_list); + expand_asm_operands (gnu_template, gnu_output_list, gnu_input_list, + gnu_clobber_list, Is_Asm_Volatile (gnat_node), input_filename, lineno); /* Copy all the intermediate outputs into the specified outputs. */ @@ -3738,12 +3862,7 @@ tree_transform (gnat_node) break; gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result - = build_call_raise - (Nkind (gnat_node) == N_Raise_Constraint_Error - ? raise_constraint_error_decl - : Nkind (gnat_node) == N_Raise_Program_Error - ? raise_program_error_decl : raise_storage_error_decl); + gnu_result = build_call_raise (UI_To_Int (Reason (gnat_node))); /* If the type is VOID, this is a statement, so we need to generate the code for the call. Handle a Condition, if there @@ -3788,7 +3907,7 @@ tree_transform (gnat_node) gnu_result = build1 (NULL_EXPR, gnu_result_type, - build_call_raise (raise_constraint_error_decl)); + build_call_raise (CE_Overflow_Check_Failed)); } /* If our result has side-effects and is of an unconstrained type, @@ -4062,15 +4181,10 @@ process_freeze_entity (gnat_node) gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1); /* If we've made any pointers to the old version of this type, we - have to update them. Also copy the name of the old object to - the new one. */ - + have to update them. */ if (gnu_old != 0) - { - DECL_NAME (gnu_new) = DECL_NAME (gnu_old); - update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)), - TREE_TYPE (gnu_new)); - } + update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)), + TREE_TYPE (gnu_new)); } /* Process the list of inlined subprograms of GNAT_NODE, which is an @@ -4252,20 +4366,27 @@ static tree emit_access_check (gnu_expr) tree gnu_expr; { - tree gnu_type = TREE_TYPE (gnu_expr); - - /* This only makes sense if GNU_TYPE is a pointer of some sort. */ - if (! POINTER_TYPE_P (gnu_type) && ! TYPE_FAT_POINTER_P (gnu_type)) - gigi_abort (322); + tree gnu_check_expr; /* Checked expressions must be evaluated only once. */ - gnu_expr = make_save_expr (gnu_expr); + gnu_check_expr = gnu_expr = protect_multiple_eval (gnu_expr); + + /* Technically, we check a fat pointer against two words of zero. However, + that's wasteful and really doesn't protect against null accesses. It + makes more sense to check oly the array pointer. */ + if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_expr))) + gnu_check_expr + = build_component_ref (gnu_expr, get_identifier ("P_ARRAY"), NULL_TREE); + + if (! POINTER_TYPE_P (TREE_TYPE (gnu_check_expr))) + gigi_abort (322); return emit_check (build_binary_op (EQ_EXPR, integer_type_node, - gnu_expr, - convert (TREE_TYPE (gnu_expr), + gnu_check_expr, + convert (TREE_TYPE (gnu_check_expr), integer_zero_node)), - gnu_expr); + gnu_expr, + CE_Access_Check_Failed); } /* Emits a discriminant check. GNU_EXPR is the expression to be checked and @@ -4289,7 +4410,17 @@ emit_discriminant_check (gnu_expr, gnat_node) if (Is_Tagged_Type (Scope (orig_comp))) gnat_pref_type = Scope (orig_comp); else - gnat_pref_type = Etype (Prefix (gnat_node)); + { + gnat_pref_type = Etype (Prefix (gnat_node)); + + /* For an untagged derived type, use the discriminants of the parent, + which have been renamed in the derivation, possibly by a one-to-many + constraint. */ + if (Is_Derived_Type (gnat_pref_type) + && (Number_Discriminants (gnat_pref_type) + != Number_Discriminants (Etype (Base_Type (gnat_pref_type))))) + gnat_pref_type = Etype (Base_Type (gnat_pref_type)); + } if (! Present (gnat_discr_fct)) return gnu_expr; @@ -4297,7 +4428,7 @@ emit_discriminant_check (gnu_expr, gnat_node) gnu_discr_fct = gnat_to_gnu (gnat_discr_fct); /* Checked expressions must be evaluated only once. */ - gnu_expr = make_save_expr (gnu_expr); + gnu_expr = protect_multiple_eval (gnu_expr); /* Create the list of the actual parameters as GCC expects it. This list is the list of the discriminant fields of the @@ -4347,7 +4478,8 @@ emit_discriminant_check (gnu_expr, gnat_node) emit_check (gnu_cond, build_unary_op (ADDR_EXPR, build_reference_type (TREE_TYPE (gnu_expr)), - gnu_expr))); + gnu_expr), + CE_Discriminant_Check_Failed)); } /* Emit code for a range check. GNU_EXPR is the expression to be checked, @@ -4373,7 +4505,7 @@ emit_range_check (gnu_expr, gnat_range_type) return gnu_expr; /* Checked expressions must be evaluated only once. */ - gnu_expr = make_save_expr (gnu_expr); + gnu_expr = protect_multiple_eval (gnu_expr); /* There's no good type to use here, so we might as well use integer_type_node. Note that the form of the check is @@ -4391,7 +4523,7 @@ emit_range_check (gnu_expr, gnat_range_type) convert (gnu_compare_type, gnu_expr), convert (gnu_compare_type, gnu_high)))), - gnu_expr); + gnu_expr, CE_Range_Check_Failed); } /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object @@ -4416,7 +4548,7 @@ emit_index_check (gnu_array_object, gnu_expr, gnu_low, gnu_high) tree gnu_expr_check; /* Checked expressions must be evaluated only once. */ - gnu_expr = make_save_expr (gnu_expr); + gnu_expr = protect_multiple_eval (gnu_expr); /* Must do this computation in the base type in case the expression's type is an unsigned subtypes. */ @@ -4444,35 +4576,48 @@ emit_index_check (gnu_array_object, gnu_expr, gnu_low, gnu_high) gnu_expr_check, convert (TREE_TYPE (gnu_expr_check), gnu_high))), - gnu_expr); + gnu_expr, CE_Index_Check_Failed); } /* Given GNU_COND which contains the condition corresponding to an access, discriminant or range check, of value GNU_EXPR, build a COND_EXPR that returns GNU_EXPR if GNU_COND is false and raises a - CONSTRAINT_ERROR if GNU_COND is true. */ + CONSTRAINT_ERROR if GNU_COND is true. REASON is the code that says + why the exception was raised. */ static tree -emit_check (gnu_cond, gnu_expr) +emit_check (gnu_cond, gnu_expr, reason) tree gnu_cond; tree gnu_expr; + int reason; { tree gnu_call; + tree gnu_result; + + gnu_call = build_call_raise (reason); + + /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated + in front of the comparison in case it ends up being a SAVE_EXPR. Put the + whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak + out. */ + gnu_result = fold (build (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond, + build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), + gnu_call, gnu_expr), + gnu_expr)); + + /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and + protect it. Otherwise, show GNU_RESULT has no side effects: we + don't need to evaluate it just for the check. */ + if (TREE_SIDE_EFFECTS (gnu_expr)) + gnu_result + = build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result); + else + TREE_SIDE_EFFECTS (gnu_result) = 0; - gnu_call = build_call_raise (raise_constraint_error_decl); - - /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will - get evaluated in front of the comparison in case it ends - up being a SAVE_EXPR. Put the whole thing inside its own - SAVE_EXPR do the inner SAVE_EXPR doesn't leak out. */ - - return make_save_expr (build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, - fold (build (COND_EXPR, TREE_TYPE (gnu_expr), - gnu_cond, - build (COMPOUND_EXPR, - TREE_TYPE (gnu_expr), - gnu_call, gnu_expr), - gnu_expr)))); + /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing, + we will repeatedly do the test. It would be nice if GCC was able + to optimize this and only do it once. */ + return save_expr (gnu_result); } /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing @@ -4523,7 +4668,7 @@ convert_with_check (gnat_type, gnu_expr, overflow_p, range_p, truncate_p) && ! (FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype))) { /* Ensure GNU_EXPR only gets evaluated once. */ - tree gnu_input = make_save_expr (gnu_result); + tree gnu_input = protect_multiple_eval (gnu_result); tree gnu_cond = integer_zero_node; /* Convert the lower bounds to signed types, so we're sure we're @@ -4579,7 +4724,8 @@ convert_with_check (gnat_type, gnu_expr, overflow_p, range_p, truncate_p) gnu_out_ub)))); if (! integer_zerop (gnu_cond)) - gnu_result = emit_check (gnu_cond, gnu_input); + gnu_result = emit_check (gnu_cond, gnu_input, + CE_Overflow_Check_Failed); } /* Now convert to the result base type. If this is a non-truncating @@ -4652,23 +4798,22 @@ addressable_p (gnu_expr) return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr)) && addressable_p (TREE_OPERAND (gnu_expr, 0))); - case UNCHECKED_CONVERT_EXPR: + case VIEW_CONVERT_EXPR: { - /* This is addressable if the code in gnat_expand_expr can do - it by either just taking the operand or by pointer punning. */ - tree inner = TREE_OPERAND (gnu_expr, 0); + /* This is addressable if we can avoid a copy. */ tree type = TREE_TYPE (gnu_expr); - tree inner_type = TREE_TYPE (inner); - - return ((TYPE_MODE (type) == TYPE_MODE (inner_type) - && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type) - || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT)) - || ((TYPE_MODE (type) == BLKmode - || TYPE_MODE (inner_type) == BLKmode) - && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type) - || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT - || TYPE_ALIGN_OK_P (type) - || TYPE_ALIGN_OK_P (inner_type)))); + tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0)); + + return (((TYPE_MODE (type) == TYPE_MODE (inner_type) + && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type) + || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT)) + || ((TYPE_MODE (type) == BLKmode + || TYPE_MODE (inner_type) == BLKmode) + && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type) + || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT + || TYPE_ALIGN_OK (type) + || TYPE_ALIGN_OK (inner_type)))) + && addressable_p (TREE_OPERAND (gnu_expr, 0))); } default: @@ -4937,41 +5082,42 @@ maybe_implicit_deref (exp) return exp; } -/* Surround EXP with a SAVE_EXPR, but handle unconstrained objects specially - since it doesn't make any sense to put them in a SAVE_EXPR. */ +/* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */ tree -make_save_expr (exp) +protect_multiple_eval (exp) tree exp; { tree type = TREE_TYPE (exp); - /* If this is an unchecked conversion, save the input since we may need to - handle this expression separately if it's the operand of a component - reference. */ - if (TREE_CODE (exp) == UNCHECKED_CONVERT_EXPR) - return build1 (UNCHECKED_CONVERT_EXPR, type, - make_save_expr (TREE_OPERAND (exp, 0))); - - /* If this is an aggregate type, we may be doing a dereference of it in - the LHS side of an assignment. In that case, we need to evaluate - it , take its address, make a SAVE_EXPR of that, then do the indirect - reference. Note that for an unconstrained array, the effect will be - to make a SAVE_EXPR of the fat pointer. - - ??? This is an efficiency problem in the case of a type that can be - placed into memory, but until we can deal with the LHS issue, - we have to take that hit. This really should test for BLKmode. */ - else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE - || (AGGREGATE_TYPE_P (type) && ! TYPE_FAT_POINTER_P (type))) + /* If this has no side effects, we don't need to do anything. */ + if (! TREE_SIDE_EFFECTS (exp)) + return exp; + + /* If it is a conversion, protect what's inside the conversion. + Similarly, if we're indirectly referencing something, we only + actually need to protect the address since the data itself can't + change in these situations. */ + else if (TREE_CODE (exp) == NON_LVALUE_EXPR + || TREE_CODE (exp) == NOP_EXPR || TREE_CODE (exp) == CONVERT_EXPR + || TREE_CODE (exp) == VIEW_CONVERT_EXPR + || TREE_CODE (exp) == INDIRECT_REF + || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF) + return build1 (TREE_CODE (exp), type, + protect_multiple_eval (TREE_OPERAND (exp, 0))); + + /* If EXP is a fat pointer or something that can be placed into a register, + just make a SAVE_EXPR. */ + if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode) + return save_expr (exp); + + /* Otherwise, dereference, protect the address, and re-reference. */ + else return build_unary_op (INDIRECT_REF, type, save_expr (build_unary_op (ADDR_EXPR, build_reference_type (type), exp))); - - /* Otherwise, just do the usual thing. */ - return save_expr (exp); } /* This is equivalent to stabilize_reference in GCC's tree.c, but we know @@ -5002,7 +5148,7 @@ gnat_stabilize_reference (ref, force) case FIX_FLOOR_EXPR: case FIX_ROUND_EXPR: case FIX_CEIL_EXPR: - case UNCHECKED_CONVERT_EXPR: + case VIEW_CONVERT_EXPR: case ADDR_EXPR: result = build1 (code, type, @@ -5113,14 +5259,6 @@ gnat_stabilize_reference_1 (e, force) return e; case '2': - /* Division is slow and tends to be compiled with jumps, - especially the division by powers of 2 that is often - found inside of an array reference. So do it just once. */ - if (code == TRUNC_DIV_EXPR || code == TRUNC_MOD_EXPR - || code == FLOOR_DIV_EXPR || code == FLOOR_MOD_EXPR - || code == CEIL_DIV_EXPR || code == CEIL_MOD_EXPR - || code == ROUND_DIV_EXPR || code == ROUND_MOD_EXPR) - return save_expr (e); /* Recursively stabilize each operand. */ result = build (code, type, gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force), diff --git a/gcc/ada/tree_gen.adb b/gcc/ada/tree_gen.adb index fc54b0e45c2..dae45b7ad80 100644 --- a/gcc/ada/tree_gen.adb +++ b/gcc/ada/tree_gen.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.8 $ +-- $Revision$ -- -- --- Copyright (C) 1992-1999, 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,7 +33,7 @@ with Lib; with Namet; with Nlists; with Opt; -with Osint; +with Osint.C; with Repinfo; with Sinput; with Stand; @@ -44,7 +44,7 @@ with Urealp; procedure Tree_Gen is begin if Opt.Tree_Output then - Osint.Tree_Create; + Osint.C.Tree_Create; Opt.Tree_Write; Atree.Tree_Write; Elists.Tree_Write; @@ -58,6 +58,6 @@ begin Uintp.Tree_Write; Urealp.Tree_Write; Repinfo.Tree_Write; - Osint.Tree_Close; + Osint.C.Tree_Close; end if; end Tree_Gen; diff --git a/gcc/ada/tree_io.adb b/gcc/ada/tree_io.adb index 5f4c30fae77..df4e11e1ee5 100644 --- a/gcc/ada/tree_io.adb +++ b/gcc/ada/tree_io.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.13 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -72,9 +72,6 @@ package body Tree_IO is Max_Count : constant := 63; -- Maximum data length for one compression sequence - Max_Comp : constant := Max_Count + 1; - -- Maximum length of one compression sequence - -- The above compression scheme applies only to data written with the -- Tree_Write routine and read with Tree_Read. Data written using the -- Tree_Write_Char or Tree_Write_Int routines and read using the diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 80954c9e660..ad146696374 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.128 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -214,31 +214,31 @@ package body Treepr is -- printed lines. -------- - -- PE -- + -- pe -- -------- - procedure PE (E : Elist_Id) is + procedure pe (E : Elist_Id) is begin Print_Tree_Elist (E); - end PE; + end pe; -------- - -- PL -- + -- pl -- -------- - procedure PL (L : List_Id) is + procedure pl (L : List_Id) is begin Print_Tree_List (L); - end PL; + end pl; -------- - -- PN -- + -- pn -- -------- - procedure PN (N : Node_Id) is + procedure pn (N : Node_Id) is begin Print_Tree_Node (N); - end PN; + end pn; ---------------- -- Print_Char -- @@ -1342,13 +1342,13 @@ package body Treepr is end Print_Tree_Node; -------- - -- PT -- + -- pt -- -------- - procedure PT (N : Node_Id) is + procedure pt (N : Node_Id) is begin Print_Node_Subtree (N); - end PT; + end pt; ------------------- -- Serial_Number -- diff --git a/gcc/ada/treepr.ads b/gcc/ada/treepr.ads index b2a8c6fdd9c..6e0ab799794 100644 --- a/gcc/ada/treepr.ads +++ b/gcc/ada/treepr.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.14 $ -- +-- $Revision$ -- -- -- --- Copyright (C) 1992,1993,1994,1995 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- -- @@ -60,19 +60,23 @@ package Treepr is -- Prints the subtree consisting of the given element list and all its -- referenced descendants. - procedure PE (E : Elist_Id); + procedure pe (E : Elist_Id); + pragma Export (Ada, pe); -- Debugging procedure (to be called within gdb) -- same as Print_Tree_Elist - procedure PL (L : List_Id); + procedure pl (L : List_Id); + pragma Export (Ada, pl); -- Debugging procedure (to be called within gdb) -- same as Print_Tree_List - procedure PN (N : Node_Id); + procedure pn (N : Node_Id); + pragma Export (Ada, pn); -- Debugging procedure (to be called within gdb) -- same as Print_Tree_Node with Label = "" - procedure PT (N : Node_Id); + procedure pt (N : Node_Id); + pragma Export (Ada, pt); -- Debugging procedure (to be called within gdb) -- same as Print_Node_Subtree diff --git a/gcc/ada/treeprs.ads b/gcc/ada/treeprs.ads index 3e0f1467cfb..ee4e05456f3 100644 --- a/gcc/ada/treeprs.ads +++ b/gcc/ada/treeprs.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- Generated by xtreeprs revision 1.1 using -- --- sinfo.ads revision 1.6 -- --- treeprs.adt revision 1.1 -- +-- Generated by xtreeprs revision using -- +-- sinfo.ads revision 1.439 -- +-- treeprs.adt revision 1.17 -- -- -- -- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- -- -- @@ -195,7 +195,8 @@ package Treeprs is "" & -- Attribute_Reference "%Prefix$Attribute_Name#Expressions&Entity&Associated_Node2Do_Access_C" & - "heck8Do_Overflow_Check4Redundant_Use+OK_For_Stream" & + "heck8Do_Overflow_Check4Redundant_Use+OK_For_Stream5Must_Be_Byte_Al" & + "igned" & -- And_Then "#Actions" & -- Conditional_Expression @@ -223,11 +224,11 @@ package Treeprs is -- Qualified_Expression "&Subtype_Mark%Expression" & -- Raise_Constraint_Error - "#Condition" & + "#Condition%Reason" & -- Raise_Program_Error - "#Condition" & + "#Condition%Reason" & -- Raise_Storage_Error - "#Condition" & + "#Condition%Reason" & -- Aggregate "#Expressions$Component_Associations8Null_Record_Present%Aggregate_Bou" & "nds&Associated_Node+Static_Processing_OK9Compile_Time_Known_Aggreg" & @@ -483,7 +484,7 @@ package Treeprs is -- Discriminant_Specification "#Defining_Identifier'Discriminant_Type%Expression,More_Ids-Prev_Ids" & -- Enumeration_Type_Definition - "#Literals" & + "#Literals&End_Label" & -- Entry_Body "#Defining_Identifier'Entry_Body_Formal_Part$Declarations&Handled_Stat" & "ement_Sequence%Activation_Chain_Entity" & @@ -630,169 +631,169 @@ package Treeprs is N_Op_Not => 980, N_Op_Plus => 980, N_Attribute_Reference => 980, - N_And_Then => 1099, - N_Conditional_Expression => 1107, - N_Explicit_Dereference => 1145, - N_Function_Call => 1168, - N_In => 1289, - N_Indexed_Component => 1289, - N_Integer_Literal => 1324, - N_Not_In => 1344, - N_Null => 1344, - N_Or_Else => 1344, - N_Procedure_Call_Statement => 1352, - N_Qualified_Expression => 1473, - N_Raise_Constraint_Error => 1497, - N_Raise_Program_Error => 1507, - N_Raise_Storage_Error => 1517, - N_Aggregate => 1527, - N_Allocator => 1683, - N_Extension_Aggregate => 1760, - N_Range => 1863, - N_Real_Literal => 1904, - N_Reference => 1958, - N_Selected_Component => 1965, - N_Slice => 2040, - N_String_Literal => 2078, - N_Subprogram_Info => 2104, - N_Type_Conversion => 2115, - N_Unchecked_Expression => 2230, - N_Unchecked_Type_Conversion => 2241, - N_Subtype_Indication => 2282, - N_Component_Declaration => 2322, - N_Entry_Declaration => 2406, - N_Formal_Object_Declaration => 2479, - N_Formal_Type_Declaration => 2564, - N_Full_Type_Declaration => 2665, - N_Incomplete_Type_Declaration => 2753, - N_Loop_Parameter_Specification => 2831, - N_Object_Declaration => 2895, - N_Protected_Type_Declaration => 3142, - N_Private_Extension_Declaration => 3230, - N_Private_Type_Declaration => 3344, - N_Subtype_Declaration => 3470, - N_Function_Specification => 3544, - N_Procedure_Specification => 3636, - N_Entry_Index_Specification => 3715, - N_Freeze_Entity => 3763, - N_Access_Function_Definition => 3831, - N_Access_Procedure_Definition => 3887, - N_Task_Type_Declaration => 3930, - N_Package_Body_Stub => 4033, - N_Protected_Body_Stub => 4085, - N_Subprogram_Body_Stub => 4137, - N_Task_Body_Stub => 4183, - N_Function_Instantiation => 4235, - N_Package_Instantiation => 4321, - N_Procedure_Instantiation => 4407, - N_Package_Body => 4493, - N_Subprogram_Body => 4591, - N_Protected_Body => 4818, - N_Task_Body => 4900, - N_Implicit_Label_Declaration => 5038, - N_Package_Declaration => 5074, - N_Single_Task_Declaration => 5143, - N_Subprogram_Declaration => 5179, - N_Use_Package_Clause => 5239, - N_Generic_Package_Declaration => 5282, - N_Generic_Subprogram_Declaration => 5379, - N_Constrained_Array_Definition => 5452, - N_Unconstrained_Array_Definition => 5516, - N_Exception_Renaming_Declaration => 5565, - N_Object_Renaming_Declaration => 5590, - N_Package_Renaming_Declaration => 5662, - N_Subprogram_Renaming_Declaration => 5698, - N_Generic_Function_Renaming_Declaration => 5748, - N_Generic_Package_Renaming_Declaration => 5784, - N_Generic_Procedure_Renaming_Declaration => 5820, - N_Abort_Statement => 5856, - N_Accept_Statement => 5862, - N_Assignment_Statement => 5957, - N_Asynchronous_Select => 6043, - N_Block_Statement => 6081, - N_Case_Statement => 6246, - N_Code_Statement => 6279, - N_Conditional_Entry_Call => 6290, - N_Delay_Relative_Statement => 6329, - N_Delay_Until_Statement => 6340, - N_Entry_Call_Statement => 6351, - N_Free_Statement => 6398, - N_Goto_Statement => 6440, - N_Loop_Statement => 6460, - N_Null_Statement => 6532, - N_Raise_Statement => 6532, - N_Requeue_Statement => 6537, - N_Return_Statement => 6556, - N_Selective_Accept => 6630, - N_Timed_Entry_Call => 6666, - N_Exit_Statement => 6707, - N_If_Statement => 6722, - N_Accept_Alternative => 6785, - N_Delay_Alternative => 6861, - N_Elsif_Part => 6913, - N_Entry_Body_Formal_Part => 6957, - N_Iteration_Scheme => 7018, - N_Terminate_Alternative => 7075, - N_Abortable_Part => 7114, - N_Abstract_Subprogram_Declaration => 7125, - N_Access_Definition => 7139, - N_Access_To_Object_Definition => 7152, - N_Case_Statement_Alternative => 7200, - N_Compilation_Unit => 7228, - N_Compilation_Unit_Aux => 7367, - N_Component_Association => 7402, - N_Component_List => 7434, - N_Derived_Type_Definition => 7476, - N_Decimal_Fixed_Point_Definition => 7534, - N_Defining_Program_Unit_Name => 7594, - N_Delta_Constraint => 7619, - N_Designator => 7653, - N_Digits_Constraint => 7669, - N_Discriminant_Association => 7704, - N_Discriminant_Specification => 7730, - N_Enumeration_Type_Definition => 7797, - N_Entry_Body => 7806, - N_Entry_Call_Alternative => 7913, - N_Exception_Declaration => 7960, - N_Exception_Handler => 8009, - N_Floating_Point_Definition => 8074, - N_Formal_Decimal_Fixed_Point_Definition => 8117, - N_Formal_Derived_Type_Definition => 8117, - N_Formal_Discrete_Type_Definition => 8163, - N_Formal_Floating_Point_Definition => 8163, - N_Formal_Modular_Type_Definition => 8163, - N_Formal_Ordinary_Fixed_Point_Definition => 8163, - N_Formal_Package_Declaration => 8163, - N_Formal_Private_Type_Definition => 8250, - N_Formal_Signed_Integer_Type_Definition => 8298, - N_Formal_Subprogram_Declaration => 8298, - N_Generic_Association => 8337, - N_Handled_Sequence_Of_Statements => 8385, - N_Index_Or_Discriminant_Constraint => 8477, - N_Itype_Reference => 8489, - N_Label => 8495, - N_Modular_Type_Definition => 8521, - N_Number_Declaration => 8532, - N_Ordinary_Fixed_Point_Definition => 8581, - N_Others_Choice => 8623, - N_Package_Specification => 8658, - N_Parameter_Association => 8744, - N_Parameter_Specification => 8802, - N_Protected_Definition => 8931, - N_Range_Constraint => 9003, - N_Real_Range_Specification => 9020, - N_Record_Definition => 9041, - N_Signed_Integer_Type_Definition => 9127, - N_Single_Protected_Declaration => 9148, - N_Subunit => 9189, - N_Task_Definition => 9225, - N_Triggering_Alternative => 9363, - N_Use_Type_Clause => 9410, - N_Validate_Unchecked_Conversion => 9461, - N_Variant => 9485, - N_Variant_Part => 9564, - N_With_Clause => 9578, - N_With_Type_Clause => 9753, - N_Unused_At_End => 9773); + N_And_Then => 1120, + N_Conditional_Expression => 1128, + N_Explicit_Dereference => 1166, + N_Function_Call => 1189, + N_In => 1310, + N_Indexed_Component => 1310, + N_Integer_Literal => 1345, + N_Not_In => 1365, + N_Null => 1365, + N_Or_Else => 1365, + N_Procedure_Call_Statement => 1373, + N_Qualified_Expression => 1494, + N_Raise_Constraint_Error => 1518, + N_Raise_Program_Error => 1535, + N_Raise_Storage_Error => 1552, + N_Aggregate => 1569, + N_Allocator => 1725, + N_Extension_Aggregate => 1802, + N_Range => 1905, + N_Real_Literal => 1946, + N_Reference => 2000, + N_Selected_Component => 2007, + N_Slice => 2082, + N_String_Literal => 2120, + N_Subprogram_Info => 2146, + N_Type_Conversion => 2157, + N_Unchecked_Expression => 2272, + N_Unchecked_Type_Conversion => 2283, + N_Subtype_Indication => 2324, + N_Component_Declaration => 2364, + N_Entry_Declaration => 2448, + N_Formal_Object_Declaration => 2521, + N_Formal_Type_Declaration => 2606, + N_Full_Type_Declaration => 2707, + N_Incomplete_Type_Declaration => 2795, + N_Loop_Parameter_Specification => 2873, + N_Object_Declaration => 2937, + N_Protected_Type_Declaration => 3184, + N_Private_Extension_Declaration => 3272, + N_Private_Type_Declaration => 3386, + N_Subtype_Declaration => 3512, + N_Function_Specification => 3586, + N_Procedure_Specification => 3678, + N_Entry_Index_Specification => 3757, + N_Freeze_Entity => 3805, + N_Access_Function_Definition => 3873, + N_Access_Procedure_Definition => 3929, + N_Task_Type_Declaration => 3972, + N_Package_Body_Stub => 4075, + N_Protected_Body_Stub => 4127, + N_Subprogram_Body_Stub => 4179, + N_Task_Body_Stub => 4225, + N_Function_Instantiation => 4277, + N_Package_Instantiation => 4363, + N_Procedure_Instantiation => 4449, + N_Package_Body => 4535, + N_Subprogram_Body => 4633, + N_Protected_Body => 4860, + N_Task_Body => 4942, + N_Implicit_Label_Declaration => 5080, + N_Package_Declaration => 5116, + N_Single_Task_Declaration => 5185, + N_Subprogram_Declaration => 5221, + N_Use_Package_Clause => 5281, + N_Generic_Package_Declaration => 5324, + N_Generic_Subprogram_Declaration => 5421, + N_Constrained_Array_Definition => 5494, + N_Unconstrained_Array_Definition => 5558, + N_Exception_Renaming_Declaration => 5607, + N_Object_Renaming_Declaration => 5632, + N_Package_Renaming_Declaration => 5704, + N_Subprogram_Renaming_Declaration => 5740, + N_Generic_Function_Renaming_Declaration => 5790, + N_Generic_Package_Renaming_Declaration => 5826, + N_Generic_Procedure_Renaming_Declaration => 5862, + N_Abort_Statement => 5898, + N_Accept_Statement => 5904, + N_Assignment_Statement => 5999, + N_Asynchronous_Select => 6085, + N_Block_Statement => 6123, + N_Case_Statement => 6288, + N_Code_Statement => 6321, + N_Conditional_Entry_Call => 6332, + N_Delay_Relative_Statement => 6371, + N_Delay_Until_Statement => 6382, + N_Entry_Call_Statement => 6393, + N_Free_Statement => 6440, + N_Goto_Statement => 6482, + N_Loop_Statement => 6502, + N_Null_Statement => 6574, + N_Raise_Statement => 6574, + N_Requeue_Statement => 6579, + N_Return_Statement => 6598, + N_Selective_Accept => 6672, + N_Timed_Entry_Call => 6708, + N_Exit_Statement => 6749, + N_If_Statement => 6764, + N_Accept_Alternative => 6827, + N_Delay_Alternative => 6903, + N_Elsif_Part => 6955, + N_Entry_Body_Formal_Part => 6999, + N_Iteration_Scheme => 7060, + N_Terminate_Alternative => 7117, + N_Abortable_Part => 7156, + N_Abstract_Subprogram_Declaration => 7167, + N_Access_Definition => 7181, + N_Access_To_Object_Definition => 7194, + N_Case_Statement_Alternative => 7242, + N_Compilation_Unit => 7270, + N_Compilation_Unit_Aux => 7409, + N_Component_Association => 7444, + N_Component_List => 7476, + N_Derived_Type_Definition => 7518, + N_Decimal_Fixed_Point_Definition => 7576, + N_Defining_Program_Unit_Name => 7636, + N_Delta_Constraint => 7661, + N_Designator => 7695, + N_Digits_Constraint => 7711, + N_Discriminant_Association => 7746, + N_Discriminant_Specification => 7772, + N_Enumeration_Type_Definition => 7839, + N_Entry_Body => 7858, + N_Entry_Call_Alternative => 7965, + N_Exception_Declaration => 8012, + N_Exception_Handler => 8061, + N_Floating_Point_Definition => 8126, + N_Formal_Decimal_Fixed_Point_Definition => 8169, + N_Formal_Derived_Type_Definition => 8169, + N_Formal_Discrete_Type_Definition => 8215, + N_Formal_Floating_Point_Definition => 8215, + N_Formal_Modular_Type_Definition => 8215, + N_Formal_Ordinary_Fixed_Point_Definition => 8215, + N_Formal_Package_Declaration => 8215, + N_Formal_Private_Type_Definition => 8302, + N_Formal_Signed_Integer_Type_Definition => 8350, + N_Formal_Subprogram_Declaration => 8350, + N_Generic_Association => 8389, + N_Handled_Sequence_Of_Statements => 8437, + N_Index_Or_Discriminant_Constraint => 8529, + N_Itype_Reference => 8541, + N_Label => 8547, + N_Modular_Type_Definition => 8573, + N_Number_Declaration => 8584, + N_Ordinary_Fixed_Point_Definition => 8633, + N_Others_Choice => 8675, + N_Package_Specification => 8710, + N_Parameter_Association => 8796, + N_Parameter_Specification => 8854, + N_Protected_Definition => 8983, + N_Range_Constraint => 9055, + N_Real_Range_Specification => 9072, + N_Record_Definition => 9093, + N_Signed_Integer_Type_Definition => 9179, + N_Single_Protected_Declaration => 9200, + N_Subunit => 9241, + N_Task_Definition => 9277, + N_Triggering_Alternative => 9415, + N_Use_Type_Clause => 9462, + N_Validate_Unchecked_Conversion => 9513, + N_Variant => 9537, + N_Variant_Part => 9616, + N_With_Clause => 9630, + N_With_Type_Clause => 9805, + N_Unused_At_End => 9825); end Treeprs; diff --git a/gcc/ada/ttypes.ads b/gcc/ada/ttypes.ads index 6ac1af4395e..10186c74058 100644 --- a/gcc/ada/ttypes.ads +++ b/gcc/ada/ttypes.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.25 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -143,7 +143,7 @@ package Ttypes is Standard_Character_Size : constant Pos := Get_Char_Size; - Standard_Wide_Character_Size : constant Pos := 2 * Get_Char_Size; + Standard_Wide_Character_Size : constant Pos := 16; -- The Standard.Wide_Character type is special in the sense that -- it is not defined in terms of its corresponding C type (wchar_t). -- Unfortunately this makes the representation of Wide_Character diff --git a/gcc/ada/types.adb b/gcc/ada/types.adb index 2ab0c5b3d05..1f090de7604 100644 --- a/gcc/ada/types.adb +++ b/gcc/ada/types.adb @@ -128,10 +128,9 @@ package body Types is -- Get_Character -- ------------------- - -- Note: raises Constraint_Error if checks on and C out of range - function Get_Character (C : Char_Code) return Character is begin + pragma Assert (C <= 255); return Character'Val (C); end Get_Character; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index bd25cf616ec..3418b179994 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001 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- -- @@ -380,6 +380,9 @@ pragma Preelaborate (Types); -- indicate that some kind of error was encountered in scanning out -- the relevant name, so it does not have a representable label. + subtype Error_Name_Or_No_Name is Name_Id range No_Name .. Error_Name; + -- Used to test for either error name or no name + First_Name_Id : constant Name_Id := Names_Low_Bound + 2; -- Subscript of first entry in names table @@ -721,4 +724,80 @@ pragma Preelaborate (Types); -- than a type to avoid some annoying processing problems with certain -- routines in Einfo (processing them to create the corresponding C). + ------------------------------ + -- Run-Time Exception Codes -- + ------------------------------ + + -- When the code generator generates a run-time exception, it provides + -- a reason code which is one of the following. This reason code is used + -- to select the appropriate run-time routine to be called, determining + -- both the exception to be raised, and the message text to be added. + + -- The prefix CE/PE/SE indicates the exception to be raised + -- CE = Constraint_Error + -- PE = Program_Error + -- SE = Storage_Error + + -- The remaining part of the name indicates the message text to be added, + -- where all letters are lower case, and underscores are converted to + -- spaces (for example CE_Invalid_Data adds the text "invalid data"). + + -- To add a new code, you need to do the following: + + -- 1. Modify the type and subtype declarations below appropriately, + -- keeping things in alphabetical order. + + -- 2. Modify the corresponding definitions in a-types.h, including + -- the definition of last_reason_code. + + -- 3. Add a new routine in Ada.Exceptions with the appropriate call + -- and static string constant + + -- 4. Initialize the new entry in raise_decls + + type RT_Exception_Code is ( + CE_Access_Check_Failed, + CE_Access_Parameter_Is_Null, + CE_Discriminant_Check_Failed, + CE_Divide_By_Zero, + CE_Explicit_Raise, + CE_Index_Check_Failed, + CE_Invalid_Data, + CE_Length_Check_Failed, + CE_Overflow_Check_Failed, + CE_Partition_Check_Failed, + CE_Range_Check_Failed, + CE_Tag_Check_Failed, + + PE_Access_Before_Elaboration, + PE_Accessibility_Check_Failed, + PE_All_Guards_Closed, + PE_Duplicated_Entry_Address, + PE_Explicit_Raise, + PE_Finalize_Raised_Exception, + PE_Invalid_Data, + PE_Misaligned_Address_Value, + PE_Missing_Return, + PE_Potentially_Blocking_Operation, + PE_Stubbed_Subprogram_Called, + PE_Unchecked_Union_Restriction, + + SE_Empty_Storage_Pool, + SE_Explicit_Raise, + SE_Infinite_Recursion, + SE_Object_Too_Large, + SE_Restriction_Violation); + + subtype RT_CE_Exceptions is RT_Exception_Code range + CE_Access_Check_Failed .. + CE_Tag_Check_Failed; + + subtype RT_PE_Exceptions is RT_Exception_Code range + PE_Access_Before_Elaboration .. + PE_Unchecked_Union_Restriction; + + subtype RT_SE_Exceptions is RT_Exception_Code range + SE_Empty_Storage_Pool .. + SE_Restriction_Violation; + end Types; diff --git a/gcc/ada/types.h b/gcc/ada/types.h index e993bdbea6a..b68702c4855 100644 --- a/gcc/ada/types.h +++ b/gcc/ada/types.h @@ -6,9 +6,9 @@ * * * C Header File * * * - * $Revision: 1.1 $ + * $Revision$ * * - * Copyright (C) 1992-2001, 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- * @@ -333,3 +333,36 @@ typedef Int Mechanism_Type; #define By_Descriptor_SB (-8) #define By_Descriptor_A (-9) #define By_Descriptor_NCA (-10) + +/* Definitions of Reason codes for Raise_xxx_Error nodes */ +#define CE_Access_Check_Failed 0 +#define CE_Access_Parameter_Is_Null 1 +#define CE_Discriminant_Check_Failed 2 +#define CE_Divide_By_Zero 3 +#define CE_Explicit_Raise 4 +#define CE_Index_Check_Failed 5 +#define CE_Invalid_Data 6 +#define CE_Length_Check_Failed 7 +#define CE_Overflow_Check_Failed 8 +#define CE_Partition_Check_Failed 9 +#define CE_Range_Check_Failed 10 +#define CE_Tag_Check_Failed 11 +#define PE_Access_Before_Elaboration 12 +#define PE_Accessibility_Check_Failed 13 +#define PE_All_Guards_Closed 14 +#define PE_Duplicated_Entry_Address 15 +#define PE_Explicit_Raise 16 +#define PE_Finalize_Raised_Exception 17 +#define PE_Invalid_Data 18 +#define PE_Misaligned_Address_Value 19 +#define PE_Missing_Return 20 +#define PE_Potentially_Blocking_Operation 21 +#define PE_Stubbed_Subprogram_Called 22 +#define PE_Unchecked_Union_Restriction 23 +#define SE_Empty_Storage_Pool 24 +#define SE_Explicit_Raise 25 +#define SE_Infinite_Recursion 26 +#define SE_Object_Too_Large 27 +#define SE_Restriction_Violation 28 + +#define LAST_REASON_CODE 28 diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads index 1cfb79ae17b..bb4ea9f90ce 100644 --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.58 $ +-- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -40,6 +40,7 @@ with Alloc; with Table; +pragma Elaborate_All (Table); with Types; use Types; package Uintp is @@ -265,10 +266,12 @@ package Uintp is -- will be more convenient to read. procedure pid (Input : Uint); + pragma Export (Ada, pid); -- Writes representation of Uint in decimal with a terminating line -- return. This is intended for use from the debugger. procedure pih (Input : Uint); + pragma Export (Ada, pih); -- Writes representation of Uint in hex with a terminating line return. -- This is intended for use from the debugger. diff --git a/gcc/ada/urealp.ads b/gcc/ada/urealp.ads index 9896e0d9968..59413b55314 100644 --- a/gcc/ada/urealp.ads +++ b/gcc/ada/urealp.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.35 $ -- +-- $Revision$ -- -- --- Copyright (C) 1992-1998 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- -- @@ -265,6 +265,7 @@ package Urealp is -- output is of the form [numerator/denominator]. procedure pr (Real : Ureal); + pragma Export (Ada, pr); -- Writes value of Real to standard output with a terminating line return, -- using UR_Write as described above. This is for use from the debugger. diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 4393df19e85..7b14a654425 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, 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- -- @@ -35,7 +35,7 @@ with System.WCh_Con; use System.WCh_Con; procedure Usage is procedure Write_Switch_Char (Sw : String; Prefix : String := "gnat"); - -- Output two spaces followed by default switch character followed + -- Output two spaces followed by the switch character minus followed -- Prefix, followed by the string given as the argument, and then -- enough blanks to tab to column 13, i.e. assuming Sw is not longer -- than 5 characters, the maximum allowed, Write_Switch_Char will @@ -43,8 +43,7 @@ procedure Usage is procedure Write_Switch_Char (Sw : String; Prefix : String := "gnat") is begin - Write_Str (" "); - Write_Char (Switch_Character); + Write_Str (" -"); Write_Str (Prefix); Write_Str (Sw); @@ -193,7 +192,7 @@ begin -- Line for -gnati switch Write_Switch_Char ("i?"); - Write_Line ("Identifier char set (?=1/2/3/4/5/8/p/f/n/w)"); + Write_Line ("Identifier char set (?=1/2/3/4/5/8/9/p/f/n/w)"); -- Line for -gnatk switch @@ -296,33 +295,41 @@ begin Write_Line ("Enable selected validity checking mode, xx = list of parameters:"); Write_Line (" a turn on all validity checking options"); - Write_Line (" c turn on validity checking for copies"); - Write_Line (" C turn off validity checking for copies"); - Write_Line (" f turn on validity checking for floating-point"); - Write_Line (" F turn off validity checking for floating-point"); - Write_Line (" i turn on validity checking for in params"); - Write_Line (" I turn off validity checking for in params"); - Write_Line (" m turn on validity checking for in out params"); - Write_Line (" M turn off validity checking for in out params"); - Write_Line (" r turn on validity checking for returns"); - Write_Line (" R turn off validity checking for returns"); - Write_Line (" s turn on validity checking for subscripts"); - Write_Line (" S turn off validity checking for subscripts"); - Write_Line (" t turn on validity checking for tests"); - Write_Line (" T turn off validity checking for tests"); + Write_Line (" c turn on checking for copies"); + Write_Line (" C turn off checking for copies"); + Write_Line (" d turn on default (RM) checking"); + Write_Line (" D turn off default (RM) checking"); + Write_Line (" f turn on checking for floating-point"); + Write_Line (" F turn off checking for floating-point"); + Write_Line (" i turn on checking for in params"); + Write_Line (" I turn off checking for in params"); + Write_Line (" m turn on checking for in out params"); + Write_Line (" M turn off checking for in out params"); + Write_Line (" o turn on checking for operators/attributes"); + Write_Line (" O turn off checking for operators/attributes"); + Write_Line (" r turn on checking for returns"); + Write_Line (" R turn off checking for returns"); + Write_Line (" s turn on checking for subscripts"); + Write_Line (" S turn off checking for subscripts"); + Write_Line (" t turn on checking for tests"); + Write_Line (" T turn off checking for tests"); Write_Line (" n turn off all validity checks (including RM)"); -- Lines for -gnatw switch Write_Switch_Char ("wxx"); Write_Line ("Enable selected warning modes, xx = list of parameters:"); - Write_Line (" a turn on all optional warnings (except b,h)"); + Write_Line (" a turn on all optional warnings (except b,d,h)"); Write_Line (" A turn off all optional warnings"); Write_Line (" b turn on biased rounding warnings"); Write_Line (" B turn off biased rounding warnings"); Write_Line (" c turn on constant conditional warnings"); Write_Line (" C* turn off constant conditional warnings"); + Write_Line (" d turn on implicit dereference warnings"); + Write_Line (" D* turn off implicit dereference warnings"); Write_Line (" e treat all warnings as errors"); + Write_Line (" f turn on unreferenced formal warnings"); + Write_Line (" F* turn off unreferenced formal warnings"); Write_Line (" h turn on warnings for hiding variables"); Write_Line (" H* turn off warnings for hiding variables"); Write_Line (" i* turn on warnings for implementation units"); diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c index 224f43150aa..c606c20fb61 100644 --- a/gcc/ada/utils.c +++ b/gcc/ada/utils.c @@ -6,9 +6,9 @@ * * * C Implementation File * * * - * $Revision: 1.8 $ + * $Revision$ * * - * Copyright (C) 1992-2001, 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- * @@ -61,9 +61,12 @@ /* If nonzero, pretend we are allocating at global level. */ int force_global; -/* Global Variables for the various types we create. */ +/* Tree nodes for the various types and decls we create. */ tree gnat_std_decls[(int) ADT_LAST]; +/* Functions to call for each of the possible raise reasons. */ +tree gnat_raise_decls[(int) LAST_REASON_CODE + 1]; + /* Associates a GNAT tree node to a GCC tree node. It is used in `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation of `save_gnu_tree' for more info. */ @@ -131,7 +134,6 @@ static struct binding_level *global_binding_level; /* Binding level structures are initialized by copying this one. */ static struct binding_level clear_binding_level = {NULL, NULL, NULL, NULL}; - static tree merge_sizes PARAMS ((tree, tree, tree, int, int)); static tree compute_related_constant PARAMS ((tree, tree)); static tree split_plus PARAMS ((tree, tree *)); @@ -141,8 +143,8 @@ static tree convert_to_fat_pointer PARAMS ((tree, tree)); static tree convert_to_thin_pointer PARAMS ((tree, tree)); static tree make_descriptor_field PARAMS ((const char *,tree, tree, tree)); -static void mark_binding_level PARAMS((PTR)); -static void mark_e_stack PARAMS((PTR)); +static void mark_binding_level PARAMS ((PTR)); +static void mark_e_stack PARAMS ((PTR)); /* Initialize the association of GNAT nodes to GCC trees. */ @@ -155,9 +157,7 @@ init_gnat_to_gnu () ggc_add_tree_root (associate_gnat_to_gnu, max_gnat_nodes); for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++) - associate_gnat_to_gnu [gnat_node] = NULL_TREE; - - associate_gnat_to_gnu -= First_Node_Id; + associate_gnat_to_gnu[gnat_node] = NULL_TREE; pending_elaborations = build_tree_list (NULL_TREE, NULL_TREE); ggc_add_tree_root (&pending_elaborations, 1); @@ -184,11 +184,11 @@ save_gnu_tree (gnat_entity, gnu_decl, no_check) int no_check; { if (gnu_decl - && (associate_gnat_to_gnu [gnat_entity] + && (associate_gnat_to_gnu[gnat_entity - First_Node_Id] || (! no_check && ! DECL_P (gnu_decl)))) gigi_abort (401); - associate_gnat_to_gnu [gnat_entity] = gnu_decl; + associate_gnat_to_gnu[gnat_entity - First_Node_Id] = gnu_decl; } /* GNAT_ENTITY is a GNAT tree node for a defining identifier. @@ -202,10 +202,10 @@ tree get_gnu_tree (gnat_entity) Entity_Id gnat_entity; { - if (! associate_gnat_to_gnu [gnat_entity]) + if (! associate_gnat_to_gnu[gnat_entity - First_Node_Id]) gigi_abort (402); - return associate_gnat_to_gnu [gnat_entity]; + return associate_gnat_to_gnu[gnat_entity - First_Node_Id]; } /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */ @@ -214,7 +214,7 @@ int present_gnu_tree (gnat_entity) Entity_Id gnat_entity; { - return (associate_gnat_to_gnu [gnat_entity] != NULL_TREE); + return (associate_gnat_to_gnu[gnat_entity - First_Node_Id] != NULL_TREE); } @@ -523,7 +523,8 @@ void init_gigi_decls (long_long_float_type, exception_type) tree long_long_float_type, exception_type; { - tree endlink; + tree endlink, decl; + unsigned int i; /* Set the types that GCC and Gigi use from the front end. We would like to do this for char_type_node, but it needs to correspond to the C @@ -607,7 +608,7 @@ init_gigi_decls (long_long_float_type, exception_type) build_function_type (build_pointer_type (except_type_node), NULL_TREE), NULL_TREE, 0, 1, 1, 0); - /* Function that raise exceptions. */ + /* Functions that raise exceptions. */ raise_nodefer_decl = create_subprog_decl (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE, @@ -617,68 +618,61 @@ init_gigi_decls (long_long_float_type, exception_type) endlink)), NULL_TREE, 0, 1, 1, 0); - - /* __gnat_raise_constraint_error takes a string, an integer and never - returns. */ - raise_constraint_error_decl - = create_subprog_decl - (get_identifier ("__gnat_raise_constraint_error"), NULL_TREE, - build_function_type (void_type_node, - tree_cons (NULL_TREE, - build_pointer_type (char_type_node), - tree_cons (NULL_TREE, - integer_type_node, - endlink))), - NULL_TREE, 0, 1, 1, 0); - - /* Likewise for __gnat_raise_program_error. */ - raise_program_error_decl - = create_subprog_decl - (get_identifier ("__gnat_raise_program_error"), NULL_TREE, - build_function_type (void_type_node, - tree_cons (NULL_TREE, - build_pointer_type (char_type_node), - tree_cons (NULL_TREE, - integer_type_node, - endlink))), - NULL_TREE, 0, 1, 1, 0); - - /* Likewise for __gnat_raise_storage_error. */ - raise_storage_error_decl - = create_subprog_decl - (get_identifier ("__gnat_raise_storage_error"), NULL_TREE, - build_function_type (void_type_node, - tree_cons (NULL_TREE, - build_pointer_type (char_type_node), - tree_cons (NULL_TREE, - integer_type_node, - endlink))), - NULL_TREE, 0, 1, 1, 0); + /* If in no exception handlers mode, all raise statements are redirected to + __gnat_last_chance_handler. No need to redefine raise_nodefer_decl, since + this procedure will never be called in this mode. */ + if (No_Exception_Handlers_Set ()) + { + decl + = create_subprog_decl + (get_identifier ("__gnat_last_chance_handler"), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, + build_pointer_type (char_type_node), + tree_cons (NULL_TREE, + integer_type_node, + endlink))), + NULL_TREE, 0, 1, 1, 0); + + for (i = 0; i < sizeof gnat_raise_decls / sizeof gnat_raise_decls[0]; + i++) + gnat_raise_decls[i] = decl; + } + else + /* Otherwise, make one decl for each exception reason. */ + for (i = 0; i < sizeof gnat_raise_decls / sizeof gnat_raise_decls[0]; i++) + { + char name[17]; + + sprintf (name, "__gnat_rcheck_%.2d", i); + gnat_raise_decls[i] + = create_subprog_decl + (get_identifier (name), NULL_TREE, + build_function_type (void_type_node, + tree_cons (NULL_TREE, + build_pointer_type + (char_type_node), + tree_cons (NULL_TREE, + integer_type_node, + endlink))), + NULL_TREE, 0, 1, 1, 0); + } /* Indicate that these never return. */ - TREE_THIS_VOLATILE (raise_nodefer_decl) = 1; - TREE_THIS_VOLATILE (raise_constraint_error_decl) = 1; - TREE_THIS_VOLATILE (raise_program_error_decl) = 1; - TREE_THIS_VOLATILE (raise_storage_error_decl) = 1; - TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1; - TREE_SIDE_EFFECTS (raise_constraint_error_decl) = 1; - TREE_SIDE_EFFECTS (raise_program_error_decl) = 1; - TREE_SIDE_EFFECTS (raise_storage_error_decl) = 1; - TREE_TYPE (raise_nodefer_decl) = build_qualified_type (TREE_TYPE (raise_nodefer_decl), TYPE_QUAL_VOLATILE); - TREE_TYPE (raise_constraint_error_decl) - = build_qualified_type (TREE_TYPE (raise_constraint_error_decl), - TYPE_QUAL_VOLATILE); - TREE_TYPE (raise_program_error_decl) - = build_qualified_type (TREE_TYPE (raise_program_error_decl), - TYPE_QUAL_VOLATILE); - TREE_TYPE (raise_storage_error_decl) - = build_qualified_type (TREE_TYPE (raise_storage_error_decl), - TYPE_QUAL_VOLATILE); + + for (i = 0; i < sizeof gnat_raise_decls / sizeof gnat_raise_decls[0]; i++) + { + TREE_THIS_VOLATILE (gnat_raise_decls[i]) = 1; + TREE_SIDE_EFFECTS (gnat_raise_decls[i]) = 1; + TREE_TYPE (gnat_raise_decls[i]) + = build_qualified_type (TREE_TYPE (gnat_raise_decls[i]), + TYPE_QUAL_VOLATILE); + } /* setjmp returns an integer and has one operand, which is a pointer to a jmpbuf. */ @@ -692,7 +686,10 @@ init_gigi_decls (long_long_float_type, exception_type) DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL; DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP; + main_identifier_node = get_identifier ("main"); + ggc_add_tree_root (gnat_std_decls, ARRAY_SIZE (gnat_std_decls)); + ggc_add_tree_root (gnat_raise_decls, ARRAY_SIZE (gnat_raise_decls)); } /* This routine is called in tree.c to print an error message for invalid use @@ -737,6 +734,7 @@ finish_record_type (record_type, fieldlist, has_rep, defer_debug) tree ada_size = bitsize_zero_node; tree size = bitsize_zero_node; tree size_unit = size_zero_node; + int var_size = 0; tree field; TYPE_FIELDS (record_type) = fieldlist; @@ -792,6 +790,15 @@ finish_record_type (record_type, fieldlist, has_rep, defer_debug) tree this_size_unit = DECL_SIZE_UNIT (field); tree this_ada_size = DECL_SIZE (field); + /* We need to make an XVE/XVU record if any field has variable size, + whether or not the record does. For example, if we have an union, + it may be that all fields, rounded up to the alignment, have the + same size, in which case we'll use that size. But the debug + output routines (except Dwarf2) won't be able to output the fields, + so we need to make the special record. */ + if (TREE_CODE (this_size) != INTEGER_CST) + var_size = 1; + if ((TREE_CODE (type) == RECORD_TYPE || TREE_CODE (type) == UNION_TYPE || TREE_CODE (type) == QUAL_UNION_TYPE) && ! TYPE_IS_FAT_POINTER_P (type) @@ -890,7 +897,7 @@ finish_record_type (record_type, fieldlist, has_rep, defer_debug) debugger knows it is and make a new, parallel, record that tells the debugger how the record is laid out. See exp_dbug.ads. */ - if (TREE_CODE (TYPE_SIZE (record_type)) != INTEGER_CST) + if (var_size) { tree new_record_type = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE @@ -972,7 +979,7 @@ finish_record_type (record_type, fieldlist, has_rep, defer_debug) /* See if this type is variable-size and make a new type and indicate the indirection if so. */ - if (TREE_CODE (TYPE_SIZE (field_type)) != INTEGER_CST) + if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST) { field_type = build_pointer_type (field_type); var = 1; @@ -994,7 +1001,7 @@ finish_record_type (record_type, fieldlist, has_rep, defer_debug) new_field = create_field_decl (field_name, field_type, new_record_type, 0, - TYPE_SIZE (field_type), pos, 0); + DECL_SIZE (old_field), pos, 0); TREE_CHAIN (new_field) = TYPE_FIELDS (new_record_type); TYPE_FIELDS (new_record_type) = new_field; @@ -1007,7 +1014,7 @@ finish_record_type (record_type, fieldlist, has_rep, defer_debug) (TREE_CODE (TREE_TYPE (old_field)) == QUAL_UNION_TYPE) ? bitsize_zero_node - : TYPE_SIZE (TREE_TYPE (old_field))); + : DECL_SIZE (old_field)); } TYPE_FIELDS (new_record_type) @@ -1484,14 +1491,21 @@ create_field_decl (field_name, field_type, record_type, packed, size, pos, known_align = TYPE_ALIGN (record_type); layout_decl (field_decl, known_align); - SET_DECL_OFFSET_ALIGN (field_decl, BIGGEST_ALIGNMENT); + SET_DECL_OFFSET_ALIGN (field_decl, + host_integerp (pos, 1) ? BIGGEST_ALIGNMENT + : BITS_PER_UNIT); pos_from_bit (&DECL_FIELD_OFFSET (field_decl), &DECL_FIELD_BIT_OFFSET (field_decl), - BIGGEST_ALIGNMENT, pos); + DECL_OFFSET_ALIGN (field_decl), pos); DECL_HAS_REP_P (field_decl) = 1; } + /* If the field type is passed by reference, we will have pointers to the + field, so it is addressable. */ + if (must_pass_by_ref (field_type) || default_pass_by_ref (field_type)) + addressable = 1; + /* Mark the decl as nonaddressable if it either is indicated so semantically or if it is a bit field. */ DECL_NONADDRESSABLE_P (field_decl) @@ -1714,8 +1728,8 @@ create_label_decl (label_name) node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of PARM_DECL nodes chained through the TREE_CHAIN field). - INLINE_FLAG, PUBLIC_FLAG, and EXTERN_FLAG are used to set the appropriate - fields in the FUNCTION_DECL. */ + INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the + appropriate fields in the FUNCTION_DECL. */ tree create_subprog_decl (subprog_name, asm_name, subprog_type, param_decl_list, @@ -1821,10 +1835,16 @@ begin_subprog_body (subprog_decl) /* Store back the PARM_DECL nodes. They appear in the right order. */ DECL_ARGUMENTS (subprog_decl) = getdecls (); - init_function_start (subprog_decl, input_filename, lineno); + init_function_start (subprog_decl, input_filename, lineno); expand_function_start (subprog_decl, 0); -} + /* If this function is `main', emit a call to `__main' + to run global initializers, etc. */ + if (DECL_ASSEMBLER_NAME (subprog_decl) != 0 + && MAIN_NAME_P (DECL_ASSEMBLER_NAME (subprog_decl)) + && DECL_CONTEXT (subprog_decl) == NULL_TREE) + expand_main_function (); +} /* Finish the definition of the current subprogram and compile it all the way to assembler language output. */ @@ -2823,7 +2843,7 @@ convert (type, expr) /* If we previously converted from another type and our type is of variable size, remove the conversion to avoid the need for variable-size temporaries. */ - if (TREE_CODE (expr) == UNCHECKED_CONVERT_EXPR + if (TREE_CODE (expr) == VIEW_CONVERT_EXPR && ! TREE_CONSTANT (TYPE_SIZE (type))) expr = TREE_OPERAND (expr, 0); @@ -2946,7 +2966,7 @@ convert (type, expr) ecode = TREE_CODE (etype); break; - case UNCHECKED_CONVERT_EXPR: + case VIEW_CONVERT_EXPR: if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype) && ! TYPE_FAT_POINTER_P (type) && ! TYPE_FAT_POINTER_P (etype)) return convert (type, TREE_OPERAND (expr, 0)); @@ -3104,29 +3124,33 @@ convert (type, expr) } /* Remove all conversions that are done in EXP. This includes converting - from a padded type or converting to a left-justified modular type. */ + from a padded type or to a left-justified modular type. If TRUE_ADDRESS + is nonzero, always return the address of the containing object even if + the address is not bit-aligned. */ tree -remove_conversions (exp) +remove_conversions (exp, true_address) tree exp; + int true_address; { switch (TREE_CODE (exp)) { case CONSTRUCTOR: - if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE + if (true_address + && TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE && TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (exp))) - return remove_conversions (TREE_VALUE (CONSTRUCTOR_ELTS (exp))); + return remove_conversions (TREE_VALUE (CONSTRUCTOR_ELTS (exp)), 1); break; case COMPONENT_REF: if (TREE_CODE (TREE_TYPE (TREE_OPERAND (exp, 0))) == RECORD_TYPE && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0)))) - return remove_conversions (TREE_OPERAND (exp, 0)); + return remove_conversions (TREE_OPERAND (exp, 0), true_address); break; - case UNCHECKED_CONVERT_EXPR: - case NOP_EXPR: case CONVERT_EXPR: - return remove_conversions (TREE_OPERAND (exp, 0)); + case VIEW_CONVERT_EXPR: case NON_LVALUE_EXPR: + case NOP_EXPR: case CONVERT_EXPR: case GNAT_NOP_EXPR: + return remove_conversions (TREE_OPERAND (exp, 0), true_address); default: break; @@ -3297,26 +3321,16 @@ unchecked_convert (type, expr) else if (TREE_CODE (etype) == UNCONSTRAINED_ARRAY_TYPE && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) expr = build_unary_op (INDIRECT_REF, NULL_TREE, - build1 (UNCHECKED_CONVERT_EXPR, TREE_TYPE (type), + build1 (VIEW_CONVERT_EXPR, TREE_TYPE (type), build_unary_op (ADDR_EXPR, NULL_TREE, expr))); - - /* If both types are aggregates with the same mode and alignment (except - if the result is a UNION_TYPE), we can do this as a normal conversion. */ - else if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype) - && TREE_CODE (type) != UNION_TYPE - && TYPE_ALIGN (type) == TYPE_ALIGN (etype) - && TYPE_MODE (type) == TYPE_MODE (etype)) - expr = build1 (CONVERT_EXPR, type, expr); - else { expr = maybe_unconstrained_array (expr); etype = TREE_TYPE (expr); - expr = build1 (UNCHECKED_CONVERT_EXPR, type, expr); + expr = build1 (VIEW_CONVERT_EXPR, type, expr); } - /* If the result is an integral type whose size is not equal to the size of the underlying machine type, sign- or zero-extend the result. We need not do this in the case where the input is @@ -3352,16 +3366,16 @@ unchecked_convert (type, expr) } /* An unchecked conversion should never raise Constraint_Error. The code - below assumes that GCC's conversion routines overflow the same - way that the underlying hardware does. This is probably true. In - the rare case when it isn't, we can rely on the fact that such - conversions are erroneous anyway. */ + below assumes that GCC's conversion routines overflow the same way that + the underlying hardware does. This is probably true. In the rare case + when it is false, we can rely on the fact that such conversions are + erroneous anyway. */ if (TREE_CODE (expr) == INTEGER_CST) TREE_OVERFLOW (expr) = TREE_CONSTANT_OVERFLOW (expr) = 0; - /* If the sizes of the types differ and this is an UNCHECKED_CONVERT_EXPR, + /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR, show no longer constant. */ - if (TREE_CODE (expr) == UNCHECKED_CONVERT_EXPR + if (TREE_CODE (expr) == VIEW_CONVERT_EXPR && ! operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype), 1)) TREE_CONSTANT (expr) = 0; diff --git a/gcc/ada/utils2.c b/gcc/ada/utils2.c index e9b5429520b..f681f1c2508 100644 --- a/gcc/ada/utils2.c +++ b/gcc/ada/utils2.c @@ -6,9 +6,9 @@ * * * C Implementation File * * * - * $Revision: 1.3 $ + * $Revision$ * * - * Copyright (C) 1992-2001, 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- * @@ -233,7 +233,7 @@ contains_save_expr_p (exp) case ADDR_EXPR: case INDIRECT_REF: case COMPONENT_REF: - case NOP_EXPR: case CONVERT_EXPR: case UNCHECKED_CONVERT_EXPR: + case NOP_EXPR: case CONVERT_EXPR: case VIEW_CONVERT_EXPR: return contains_save_expr_p (TREE_OPERAND (exp, 0)); case CONSTRUCTOR: @@ -446,7 +446,7 @@ compare_arrays (result_type, a1, a2) result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result, - build (EQ_EXPR, result_type, a1, a2)); + fold (build (EQ_EXPR, result_type, a1, a2))); } @@ -647,7 +647,7 @@ build_binary_op (op_code, result_type, left_operand, right_operand) unless we are not changing the mode. */ while ((TREE_CODE (left_operand) == CONVERT_EXPR || TREE_CODE (left_operand) == NOP_EXPR - || TREE_CODE (left_operand) == UNCHECKED_CONVERT_EXPR) + || TREE_CODE (left_operand) == VIEW_CONVERT_EXPR) && (((INTEGRAL_TYPE_P (left_type) || POINTER_TYPE_P (left_type)) && (INTEGRAL_TYPE_P (TREE_TYPE @@ -680,20 +680,20 @@ build_binary_op (op_code, result_type, left_operand, right_operand) /* If the RHS has a conversion between record and array types and an inner type is no worse, use it. Note we cannot do this for - modular types or types with TYPE_ALIGN_OK_P, since the latter + modular types or types with TYPE_ALIGN_OK, since the latter might indicate a conversion between a root type and a class-wide type, which we must not remove. */ - while (TREE_CODE (right_operand) == UNCHECKED_CONVERT_EXPR + while (TREE_CODE (right_operand) == VIEW_CONVERT_EXPR && ((TREE_CODE (right_type) == RECORD_TYPE && ! TYPE_LEFT_JUSTIFIED_MODULAR_P (right_type) - && ! TYPE_ALIGN_OK_P (right_type) + && ! TYPE_ALIGN_OK (right_type) && ! TYPE_IS_FAT_POINTER_P (right_type)) || TREE_CODE (right_type) == ARRAY_TYPE) && (((TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0))) == RECORD_TYPE) && ! (TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (TREE_OPERAND (right_operand, 0)))) - && ! (TYPE_ALIGN_OK_P + && ! (TYPE_ALIGN_OK (TREE_TYPE (TREE_OPERAND (right_operand, 0)))) && ! (TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (right_operand, 0))))) @@ -719,32 +719,45 @@ build_binary_op (op_code, result_type, left_operand, right_operand) operation_type = best_type; /* If a class-wide type may be involved, force use of the RHS type. */ - if (TREE_CODE (right_type) == RECORD_TYPE - && TYPE_ALIGN_OK_P (right_type)) + if (TREE_CODE (right_type) == RECORD_TYPE && TYPE_ALIGN_OK (right_type)) operation_type = right_type; - /* After we strip off any COMPONENT_REF, ARRAY_REF, or ARRAY_RANGE_REF - from the lhs, we must have either an INDIRECT_REF or a decl. Allow - UNCHECKED_CONVERT_EXPRs, but set TREE_ADDRESSABLE to show they are - in an LHS. Finally, allow NOP_EXPR if both types are the same tree - code and mode because we know these will be nops. */ - for (result = left_operand; - TREE_CODE (result) == COMPONENT_REF - || TREE_CODE (result) == ARRAY_REF - || TREE_CODE (result) == ARRAY_RANGE_REF - || TREE_CODE (result) == REALPART_EXPR - || TREE_CODE (result) == IMAGPART_EXPR - || TREE_CODE (result) == WITH_RECORD_EXPR - || TREE_CODE (result) == UNCHECKED_CONVERT_EXPR - || ((TREE_CODE (result) == NOP_EXPR - || TREE_CODE (result) == CONVERT_EXPR) - && (TREE_CODE (TREE_TYPE (result)) - == TREE_CODE (TREE_TYPE (TREE_OPERAND (result, 0)))) - && (TYPE_MODE (TREE_TYPE (TREE_OPERAND (result, 0))) - == TYPE_MODE (TREE_TYPE (result)))); - result = TREE_OPERAND (result, 0)) - if (TREE_CODE (result) == UNCHECKED_CONVERT_EXPR) - TREE_ADDRESSABLE (result) = 1; + /* Ensure everything on the LHS is valid. If we have a field reference, + strip anything that get_inner_reference can handle. Then remove any + conversions with type types having the same code and mode. Mark + VIEW_CONVERT_EXPRs with TREE_ADDRESSABLE. When done, we must have + either an INDIRECT_REF or a decl. */ + result = left_operand; + while (1) + { + tree restype = TREE_TYPE (result); + + if (TREE_CODE (result) == COMPONENT_REF + || TREE_CODE (result) == ARRAY_REF + || TREE_CODE (result) == ARRAY_RANGE_REF) + while (handled_component_p (result)) + result = TREE_OPERAND (result, 0); + else if (TREE_CODE (result) == REALPART_EXPR + || TREE_CODE (result) == IMAGPART_EXPR + || TREE_CODE (result) == WITH_RECORD_EXPR + || ((TREE_CODE (result) == NOP_EXPR + || TREE_CODE (result) == CONVERT_EXPR) + && (((TREE_CODE (restype) + == TREE_CODE (TREE_TYPE + (TREE_OPERAND (result, 0)))) + && (TYPE_MODE (TREE_TYPE + (TREE_OPERAND (result, 0))) + == TYPE_MODE (restype))) + || TYPE_ALIGN_OK (restype)))) + result = TREE_OPERAND (result, 0); + else if (TREE_CODE (result) == VIEW_CONVERT_EXPR) + { + TREE_ADDRESSABLE (result) = 1; + result = TREE_OPERAND (result, 0); + } + else + break; + } if (TREE_CODE (result) != INDIRECT_REF && TREE_CODE (result) != NULL_EXPR && ! DECL_P (result)) @@ -807,17 +820,6 @@ build_binary_op (op_code, result_type, left_operand, right_operand) || op_code == ARRAY_RANGE_REF) mark_addressable (left_operand); - /* If the array is an UNCHECKED_CONVERT_EXPR from and to BLKmode - types, convert it to a normal conversion since GCC can deal - with any mis-alignment as part of the handling of compponent - references. */ - - if (TREE_CODE (left_operand) == UNCHECKED_CONVERT_EXPR - && TYPE_MODE (TREE_TYPE (left_operand)) == BLKmode - && TYPE_MODE (TREE_TYPE (TREE_OPERAND (left_operand, 0))) == BLKmode) - left_operand = build1 (CONVERT_EXPR, TREE_TYPE (left_operand), - TREE_OPERAND (left_operand, 0)); - modulus = 0; break; @@ -865,20 +867,6 @@ build_binary_op (op_code, result_type, left_operand, right_operand) right_base_type = get_base_type (right_type); } - /* If either object if an UNCHECKED_CONVERT_EXPR between two BLKmode - objects, change it to a CONVERT_EXPR. */ - if (TREE_CODE (left_operand) == UNCHECKED_CONVERT_EXPR - && TYPE_MODE (left_type) == BLKmode - && TYPE_MODE (TREE_TYPE (TREE_OPERAND (left_operand, 0))) == BLKmode) - left_operand = build1 (CONVERT_EXPR, left_type, - TREE_OPERAND (left_operand, 0)); - if (TREE_CODE (right_operand) == UNCHECKED_CONVERT_EXPR - && TYPE_MODE (right_type) == BLKmode - && (TYPE_MODE (TREE_TYPE (TREE_OPERAND (right_operand, 0))) - == BLKmode)) - right_operand = build1 (CONVERT_EXPR, right_type, - TREE_OPERAND (right_operand, 0)); - /* If both objects are arrays, compare them specially. */ if ((TREE_CODE (left_type) == ARRAY_TYPE || (TREE_CODE (left_type) == INTEGER_TYPE @@ -1058,8 +1046,8 @@ build_binary_op (op_code, result_type, left_operand, right_operand) TREE_SIDE_EFFECTS (result) |= has_side_effects; TREE_CONSTANT (result) - = (TREE_CONSTANT (left_operand) & TREE_CONSTANT (right_operand) - && op_code != ARRAY_REF && op_code != ARRAY_RANGE_REF); + |= (TREE_CONSTANT (left_operand) & TREE_CONSTANT (right_operand) + && op_code != ARRAY_REF && op_code != ARRAY_RANGE_REF); if ((op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF) && TYPE_VOLATILE (operation_type)) @@ -1183,6 +1171,11 @@ build_unary_op (op_code, result_type, operand) if (offset == 0) offset = size_zero_node; + if (bitpos % BITS_PER_UNIT != 0) + post_error + ("taking address of object not aligned on storage unit?", + error_gnat_node); + offset = size_binop (PLUS_EXPR, offset, size_int (bitpos / BITS_PER_UNIT)); @@ -1415,7 +1408,25 @@ build_cond_expr (result_type, condition_operand, true_operand, false_operand) result = fold (build (COND_EXPR, result_type, condition_operand, true_operand, false_operand)); - if (addr_p) + + /* If either operand is a SAVE_EXPR (possibly surrounded by + arithmetic, make sure it gets done. */ + while (TREE_CODE_CLASS (TREE_CODE (true_operand)) == '1' + || (TREE_CODE_CLASS (TREE_CODE (true_operand)) == '2' + && TREE_CONSTANT (TREE_OPERAND (true_operand, 1)))) + true_operand = TREE_OPERAND (true_operand, 0); + + while (TREE_CODE_CLASS (TREE_CODE (false_operand)) == '1' + || (TREE_CODE_CLASS (TREE_CODE (false_operand)) == '2' + && TREE_CONSTANT (TREE_OPERAND (false_operand, 1)))) + false_operand = TREE_OPERAND (false_operand, 0); + + if (TREE_CODE (true_operand) == SAVE_EXPR) + result = build (COMPOUND_EXPR, result_type, true_operand, result); + if (TREE_CODE (false_operand) == SAVE_EXPR) + result = build (COMPOUND_EXPR, result_type, false_operand, result); + + if (addr_p) result = build_unary_op (INDIRECT_REF, NULL_TREE, result); return result; @@ -1475,13 +1486,14 @@ build_call_0_expr (fundecl) return call; } -/* Call a function FCN that raises an exception and pass the line - number and file name, if requested. */ +/* Call a function that raises an exception and pass the line number and file + name, if requested. MSG says which exception function to call. */ tree -build_call_raise (fndecl) - tree fndecl; +build_call_raise (msg) + int msg; { + tree fndecl = gnat_raise_decls[msg]; const char *str = discard_file_names ? "" : ref_filename; int len = strlen (str) + 1; tree filename = build_string (len, str); @@ -1641,15 +1653,6 @@ build_simple_component_ref (record_variable, component, field) if (field == 0) return 0; - /* If the record variable is an UNCHECKED_CONVERT_EXPR from and to BLKmode - types, convert it to a normal conversion since GCC can deal with any - mis-alignment as part of the handling of compponent references. */ - if (TREE_CODE (record_variable) == UNCHECKED_CONVERT_EXPR - && TYPE_MODE (TREE_TYPE (record_variable)) == BLKmode - && TYPE_MODE (TREE_TYPE (TREE_OPERAND (record_variable, 0))) == BLKmode) - record_variable = build1 (CONVERT_EXPR, TREE_TYPE (record_variable), - TREE_OPERAND (record_variable, 0)); - /* It would be nice to call "fold" here, but that can lose a type we need to tag a PLACEHOLDER_EXPR with, so we can't do it. */ ref = build (COMPONENT_REF, TREE_TYPE (field), record_variable, field); @@ -1683,7 +1686,7 @@ build_component_ref (record_variable, component, field) else if (field != 0) return build1 (NULL_EXPR, TREE_TYPE (field), - build_call_raise (raise_constraint_error_decl)); + build_call_raise (CE_Discriminant_Check_Failed)); else gigi_abort (512); } @@ -1861,7 +1864,7 @@ build_allocator (type, init, result_type, gnat_proc, gnat_pool) storage = build_call_alloc_dealloc (NULL_TREE, size, TYPE_ALIGN (storage_type), gnat_proc, gnat_pool); - storage = convert (storage_ptr_type, make_save_expr (storage)); + storage = convert (storage_ptr_type, protect_multiple_eval (storage)); if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) { diff --git a/gcc/ada/validsw.adb b/gcc/ada/validsw.adb index 5c2cbd82a7d..22730dc7690 100644 --- a/gcc/ada/validsw.adb +++ b/gcc/ada/validsw.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -128,7 +128,12 @@ package body Validsw is C := Options (J); J := J + 1; + -- Turn on validity checking (gets turned off by Vn) + + Validity_Checks_On := True; + case C is + when 'c' => Validity_Check_Copies := True; @@ -204,6 +209,7 @@ package body Validsw is Validity_Check_Returns := False; Validity_Check_Subscripts := False; Validity_Check_Tests := False; + Validity_Checks_On := False; when ' ' => null; @@ -215,7 +221,6 @@ package body Validsw is end case; end loop; - Validity_Checks_On := True; OK := True; Err_Col := Options'Last + 1; end Set_Validity_Check_Options; diff --git a/gcc/ada/xnmake.adb b/gcc/ada/xnmake.adb index 9a1f835f237..d57f681fd40 100644 --- a/gcc/ada/xnmake.adb +++ b/gcc/ada/xnmake.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision$ +-- $Revision: 1.29 $ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -207,7 +207,7 @@ procedure XNmake is begin -- Capture our revision (following line updated by RCS) - Match ("$Revision$", "$Rev" & "ision: " & Break (' ') * XNmake_Rev); + Match ("$Revision: 1.29 $", "$Rev" & "ision: " & Break (' ') * XNmake_Rev); Lineno := 0; NWidth := 28; diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb index 02af07e75ec..48557b706f4 100644 --- a/gcc/ada/xr_tabls.adb +++ b/gcc/ada/xr_tabls.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.36 $ +-- $Revision$ -- -- --- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -25,24 +25,21 @@ -- -- ------------------------------------------------------------------------------ +with Osint; +with Unchecked_Deallocation; + with Ada.IO_Exceptions; with Ada.Strings.Fixed; with Ada.Strings; with Ada.Text_IO; -with Hostparm; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; + with GNAT.IO_Aux; -with Unchecked_Deallocation; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with Osint; - -with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; package body Xr_Tabls is - subtype Line_String is String (1 .. Hostparm.Max_Line_Length); - subtype File_Name_String is String (1 .. Hostparm.Max_Name_Length); - function Base_File_Name (File : String) return String; -- Return the base file name for File (ie not including the directory) @@ -94,28 +91,30 @@ package body Xr_Tabls is -- Insert the Declaration in the table - New_Decl := new Declaration_Record' - (Symbol_Length => Symbol'Length, - Symbol => Symbol, - Decl => (File => File_Ref, - Line => Line, - Column => Column, - Source_Line => Null_Unbounded_String, - Next => null), - Decl_Type => Decl_Type, - Body_Ref => null, - Ref_Ref => null, - Modif_Ref => null, - Match => Default_Match or else Match (File_Ref, Line, Column), - Par_Symbol => null, - Next => null); + New_Decl := + new Declaration_Record' + (Symbol_Length => Symbol'Length, + Symbol => Symbol, + Decl => (File => File_Ref, + Line => Line, + Column => Column, + Source_Line => Null_Unbounded_String, + Next => null), + Decl_Type => Decl_Type, + Body_Ref => null, + Ref_Ref => null, + Modif_Ref => null, + Match => Default_Match + or else Match (File_Ref, Line, Column), + Par_Symbol => null, + Next => null); if Prev = null then - New_Decl.Next := Entities.Table; + New_Decl.Next := Entities.Table; Entities.Table := New_Decl; else - New_Decl.Next := Prev.Next; - Prev.Next := New_Decl; + New_Decl.Next := Prev.Next; + Prev.Next := New_Decl; end if; if New_Decl.Match then @@ -126,26 +125,27 @@ package body Xr_Tabls is return New_Decl; end Add_Declaration; - -------------- - -- Add_File -- - -------------- + ---------------------- + -- Add_To_Xref_File -- + ---------------------- - procedure Add_File - (File_Name : String; - File_Existed : out Boolean; - Ref : out File_Reference; - Visited : Boolean := True; - Emit_Warning : Boolean := False; - Gnatchop_File : String := ""; + procedure Add_To_Xref_File + (File_Name : String; + File_Existed : out Boolean; + Ref : out File_Reference; + Visited : Boolean := True; + Emit_Warning : Boolean := False; + Gnatchop_File : String := ""; Gnatchop_Offset : Integer := 0) is - The_Files : File_Reference := Files.Table; + The_Files : File_Reference := Files.Table; Base : constant String := Base_File_Name (File_Name); Dir : constant String := Xr_Tabls.Dir_Name (File_Name); - Dir_Acc : String_Access := null; + Dir_Acc : String_Access := null; begin - -- Do we have a directory name as well ? + -- Do we have a directory name as well? + if Dir /= "" then Dir_Acc := new String' (Dir); end if; @@ -175,7 +175,7 @@ package body Xr_Tabls is Next => Files.Table); Files.Table := Ref; File_Existed := False; - end Add_File; + end Add_To_Xref_File; -------------- -- Add_Line -- @@ -247,10 +247,21 @@ package body Xr_Tabls is begin case Ref_Type is - when 'b' | 'c' => Ref := Declaration.Body_Ref; - when 'r' | 'i' => Ref := Declaration.Ref_Ref; - when 'm' => Ref := Declaration.Modif_Ref; - when others => return; + when 'b' | 'c' => + Ref := Declaration.Body_Ref; + + when 'r' | 'i' | 'l' | ' ' | 'x' => + Ref := Declaration.Ref_Ref; + + when 'm' => + Ref := Declaration.Modif_Ref; + + when 'e' | 't' | 'p' => + return; + + when others => + Ada.Text_IO.Put_Line ("Unknown reference type: " & Ref_Type); + return; end case; -- Check if the reference already exists @@ -277,15 +288,19 @@ package body Xr_Tabls is else case Ref_Type is when 'b' | 'c' => - New_Ref.Next := Declaration.Body_Ref; - Declaration.Body_Ref := New_Ref; - when 'r' | 'i' => - New_Ref.Next := Declaration.Ref_Ref; - Declaration.Ref_Ref := New_Ref; + New_Ref.Next := Declaration.Body_Ref; + Declaration.Body_Ref := New_Ref; + + when 'r' | 'i' | 'l' | ' ' | 'x' => + New_Ref.Next := Declaration.Ref_Ref; + Declaration.Ref_Ref := New_Ref; + when 'm' => - New_Ref.Next := Declaration.Modif_Ref; + New_Ref.Next := Declaration.Modif_Ref; Declaration.Modif_Ref := New_Ref; - when others => null; + + when others => + null; end case; end if; @@ -327,6 +342,7 @@ package body Xr_Tabls is return File (J + 1 .. File'Last); end if; end loop; + return File; end Base_File_Name; @@ -973,16 +989,15 @@ package body Xr_Tabls is type Simple_Ref; type Simple_Ref_Access is access Simple_Ref; - type Simple_Ref is - record - Ref : Reference; - Next : Simple_Ref_Access; - end record; + type Simple_Ref is record + Ref : Reference; + Next : Simple_Ref_Access; + end record; List : Simple_Ref_Access := null; -- This structure is used to speed up the parsing of Ada sources: -- Every reference found by parsing the .ali files is inserted in this - -- list, sorted by filename and line numbers. - -- This allows use not to parse a same ada file multiple times + -- list, sorted by filename and line numbers. This allows avoiding + -- parsing a same ada file multiple times procedure Free is new Unchecked_Deallocation (Simple_Ref, Simple_Ref_Access); @@ -1121,6 +1136,7 @@ package body Xr_Tabls is else Prev.Next := new Simple_Ref'(Ref, Iter); end if; + return; end if; diff --git a/gcc/ada/xr_tabls.ads b/gcc/ada/xr_tabls.ads index 960b35def8e..9e122e00526 100644 --- a/gcc/ada/xr_tabls.ads +++ b/gcc/ada/xr_tabls.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.18 $ +-- $Revision$ -- -- --- Copyright (C) 1998-2000 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -112,25 +112,24 @@ package Xr_Tabls is -- The parent declaration (Symbol in file File_Ref at position Line and -- Column) information is added to Declaration. - procedure Add_File - (File_Name : String; - File_Existed : out Boolean; - Ref : out File_Reference; - Visited : Boolean := True; - Emit_Warning : Boolean := False; - Gnatchop_File : String := ""; + procedure Add_To_Xref_File + (File_Name : String; + File_Existed : out Boolean; + Ref : out File_Reference; + Visited : Boolean := True; + Emit_Warning : Boolean := False; + Gnatchop_File : String := ""; Gnatchop_Offset : Integer := 0); - -- Add a new reference to a file in the table. Ref is used to return - -- the index in the table where this file is stored On exit, - -- File_Existed is True if the file was already in the table Visited is - -- the value which will be used in the table (if True, the file will - -- not be returned by Next_Unvisited_File). If Emit_Warning is True and - -- the ali file does not exist or does not have cross-referencing - -- informations, then a warning will be emitted. - -- Gnatchop_File is the name of the file that File_Name was extracted from - -- through a call to "gnatchop -r" (with pragma Source_Reference). - -- Gnatchop_Offset should be the index of the first line of File_Name - -- withing Gnatchop_File. + -- Add a new reference to a file in the table. Ref is used to return the + -- index in the table where this file is stored On exit, File_Existed is + -- True if the file was already in the table Visited is the value which + -- will be used in the table (if True, the file will not be returned by + -- Next_Unvisited_File). If Emit_Warning is True and the ali file does + -- not exist or does not have cross-referencing information, then a + -- warning will be emitted. Gnatchop_File is the name of the file that + -- File_Name was extracted from through a call to "gnatchop -r" (using + -- pragma Source_Reference). Gnatchop_Offset should be the index of the + -- first line of File_Name within the Gnatchop_File. procedure Add_Line (File : File_Reference; @@ -162,7 +161,7 @@ package Xr_Tabls is function First_Body (Decl : Declaration_Reference) return Reference; function First_Declaration return Declaration_Reference; - function First_Modif (Decl : Declaration_Reference) return Reference; + function First_Modif (Decl : Declaration_Reference) return Reference; function First_Reference (Decl : Declaration_Reference) return Reference; -- Initialize the iterators @@ -186,16 +185,21 @@ package Xr_Tabls is -- Returns the Emit_Warning field of the structure function Get_Gnatchop_File - (File : File_Reference; With_Dir : Boolean := False) return String; + (File : File_Reference; + With_Dir : Boolean := False) + return String; function Get_Gnatchop_File - (Ref : Reference; With_Dir : Boolean := False) return String; + (Ref : Reference; + With_Dir : Boolean := False) + return String; function Get_Gnatchop_File - (Decl : Declaration_Reference; With_Dir : Boolean := False) return String; + (Decl : Declaration_Reference; + With_Dir : Boolean := False) + return String; -- Return the name of the file that File was extracted from through a - -- call to "gnatchop -r". - -- The file name for File is returned if File wasn't extracted from such a - -- file. The directory will be given only if With_Dir is True. - + -- call to "gnatchop -r". The file name for File is returned if File + -- was not extracted from such a file. The directory will be given only + -- if With_Dir is True. function Get_File (Decl : Declaration_Reference; @@ -213,25 +217,24 @@ package Xr_Tabls is (File : File_Reference; With_Dir : Boolean := False; Strip : Natural := 0) - return String; - -- Returns the file name (and its directory if With_Dir is True or - -- the user as used the -f switch on the command line. - -- If Strip is not 0, then the last Strip-th "-..." substrings are - -- removed first. For instance, with Strip=2, a file name - -- "parent-child1-child2-child3.ali" would be returned as - -- "parent-child1.ali". This is used when looking for the ALI file to use - -- for a package, since for separates with have to use the parent's ALI. - -- - -- "" is returned if there is no such parent unit - - function Get_File_Ref (Ref : Reference) return File_Reference; - function Get_Line (Decl : Declaration_Reference) return String; - function Get_Line (Ref : Reference) return String; - function Get_Symbol (Decl : Declaration_Reference) return String; - function Get_Type (Decl : Declaration_Reference) return Character; + return String; + -- Returns the file name (and its directory if With_Dir is True or the + -- user has used the -f switch on the command line. If Strip is not 0, + -- then the last Strip-th "-..." substrings are removed first. For + -- instance, with Strip=2, a file name "parent-child1-child2-child3.ali" + -- would be returned as "parent-child1.ali". This is used when looking + -- for the ALI file to use for a package, since for separates with have + -- to use the parent's ALI. The null string is returned if there is no + -- such parent unit + + function Get_File_Ref (Ref : Reference) return File_Reference; + function Get_Line (Decl : Declaration_Reference) return String; + function Get_Line (Ref : Reference) return String; + function Get_Symbol (Decl : Declaration_Reference) return String; + function Get_Type (Decl : Declaration_Reference) return Character; -- Functions that return the content of a declaration - function Get_Source_Line (Ref : Reference) return String; + function Get_Source_Line (Ref : Reference) return String; function Get_Source_Line (Decl : Declaration_Reference) return String; -- Return the source line associated with the reference @@ -256,7 +259,7 @@ package Xr_Tabls is -- by the user function Next (Decl : Declaration_Reference) return Declaration_Reference; - function Next (Ref : Reference) return Reference; + function Next (Ref : Reference) return Reference; -- Returns the next declaration, or Empty_Declaration function Next_Unvisited_File return File_Reference; @@ -276,7 +279,6 @@ package Xr_Tabls is procedure Set_Unvisited (File_Ref : in File_Reference); -- Set File_Ref as unvisited. So Next_Unvisited_File will return it. - private type Project_File (Src_Dir_Length, Obj_Dir_Length : Natural) is record Src_Dir : String (1 .. Src_Dir_Length); @@ -308,23 +310,21 @@ private Empty_File : constant File_Reference := null; type File_Record (File_Length : Natural) is record - File : String (1 .. File_Length); - Dir : String_Access := null; - Lines : Ref_In_File_Ptr := null; - Visited : Boolean := False; - Emit_Warning : Boolean := False; - Gnatchop_File : String_Access := null; - Gnatchop_Offset : Integer := 0; - Next : File_Reference := null; + File : String (1 .. File_Length); + Dir : String_Access := null; + Lines : Ref_In_File_Ptr := null; + Visited : Boolean := False; + Emit_Warning : Boolean := False; + Gnatchop_File : String_Access := null; + Gnatchop_Offset : Integer := 0; + Next : File_Reference := null; end record; -- Holds a reference to a source file, that was referenced in at least one - -- ALI file. - -- Gnatchop_File will contain the name of the file that File was extracted - -- From. Gnatchop_Offset contains the index of the first line of File - -- within Gnatchop_File. These two fields are used to properly support + -- ALI file. Gnatchop_File will contain the name of the file that File was + -- extracted From. Gnatchop_Offset contains the index of the first line of + -- File within Gnatchop_File. These two fields are used to properly support -- gnatchop files and pragma Source_Reference. - type Reference_Record; type Reference is access all Reference_Record; diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb index d3dfe37859a..ca3e26a4f96 100644 --- a/gcc/ada/xref_lib.adb +++ b/gcc/ada/xref_lib.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.55 $ +-- $Revision$ -- -- --- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -25,14 +25,16 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Strings.Fixed; use Ada.Strings.Fixed; -with GNAT.Command_Line; use GNAT.Command_Line; -with GNAT.IO_Aux; use GNAT.IO_Aux; with Osint; with Output; use Output; with Types; use Types; with Unchecked_Deallocation; +with Ada.Strings.Fixed; use Ada.Strings.Fixed; + +with GNAT.Command_Line; use GNAT.Command_Line; +with GNAT.IO_Aux; use GNAT.IO_Aux; + package body Xref_Lib is Type_Position : constant := 50; @@ -42,11 +44,6 @@ package body Xref_Lib is -- Local Variables -- --------------------- - D : constant Character := 'D'; - X : constant Character := 'X'; - W : constant Character := 'W'; - Dot : constant Character := '.'; - Pipe : constant Character := '|'; -- First character on xref lines in the .ali file @@ -60,9 +57,6 @@ package body Xref_Lib is subtype File_Offset is Natural; - function End_Of_Line_Index (File : ALI_File) return Integer; - -- Returns the index of the last character of the current_line - procedure Read_File (FD : File_Descriptor; Contents : out String_Access; @@ -259,41 +253,41 @@ package body Xref_Lib is end if; end if; - Add_File (Entity (File_Start .. Line_Start - 1), + Add_To_Xref_File (Entity (File_Start .. Line_Start - 1), File_Existed, File_Ref, Visited => True); Add_Line (File_Ref, Line_Num, Col_Num); - Add_File + Add_To_Xref_File (ALI_File_Name (Entity (File_Start .. Line_Start - 1)), File_Existed, File_Ref, Visited => False, Emit_Warning => True); end Add_Entity; - -------------- - -- Add_File -- - -------------- + ------------------- + -- Add_Xref_File -- + ------------------- - procedure Add_File (File : String) is + procedure Add_Xref_File (File : String) is File_Ref : File_Reference := Empty_File; File_Existed : Boolean; Iterator : Expansion_Iterator; - procedure Add_File_Internal (File : String); + procedure Add_Xref_File_Internal (File : String); -- Do the actual addition of the file - ----------------------- - -- Add_File_Internal -- - ----------------------- + ---------------------------- + -- Add_Xref_File_Internal -- + ---------------------------- - procedure Add_File_Internal (File : String) is + procedure Add_Xref_File_Internal (File : String) is begin -- Case where we have an ALI file, accept it even though this is -- not official usage, since the intention is obvious if Tail (File, 4) = ".ali" then - Add_File + Add_To_Xref_File (File, File_Existed, File_Ref, @@ -303,22 +297,22 @@ package body Xref_Lib is -- Normal non-ali file case else - Add_File + Add_To_Xref_File (File, File_Existed, File_Ref, Visited => True); - Add_File + Add_To_Xref_File (ALI_File_Name (File), File_Existed, File_Ref, Visited => False, Emit_Warning => True); end if; - end Add_File_Internal; + end Add_Xref_File_Internal; - -- Start of processing for Add_File + -- Start of processing for Add_Xref_File begin -- Check if we need to do the expansion @@ -334,14 +328,14 @@ package body Xref_Lib is begin exit when S'Length = 0; - Add_File_Internal (S); + Add_Xref_File_Internal (S); end; end loop; else - Add_File_Internal (File); + Add_Xref_File_Internal (File); end if; - end Add_File; + end Add_Xref_File; ----------------------- -- Current_Xref_File -- @@ -387,22 +381,6 @@ package body Xref_Lib is when Directory_Error => return String'(1 .. 0 => ' '); end Default_Project_File; - ----------------------- - -- End_Of_Line_Index -- - ----------------------- - - function End_Of_Line_Index (File : ALI_File) return Integer is - Index : Integer := File.Current_Line; - begin - while Index <= File.Buffer'Last - and then File.Buffer (Index) /= ASCII.LF - loop - Index := Index + 1; - end loop; - - return Index; - end End_Of_Line_Index; - --------------- -- File_Name -- --------------- @@ -478,7 +456,10 @@ package body Xref_Lib is end if; elsif Last > 4 and then Dir_Ent (Last - 3 .. Last) = ".ali" then - Add_File (Dir_Ent (1 .. Last), File_Existed, File_Ref, + Add_To_Xref_File + (Dir_Ent (1 .. Last), + File_Existed, + File_Ref, Visited => False); Set_Directory (File_Ref, Current_Obj_Dir); end if; @@ -609,7 +590,7 @@ package body Xref_Lib is while Ali (Ptr) /= EOF loop - if Ali (Ptr) = D then + if Ali (Ptr) = 'D' then -- Found dependency information. Format looks like: -- D source-name time-stamp checksum [subunit-name] \ -- [line:file-name] @@ -645,14 +626,14 @@ package body Xref_Lib is Token := Gnatchop_Name + 1; end if; - Add_File + Add_To_Xref_File (Ali (File_Start .. File_End), File_Existed, File.Dep.Table (Num_Dependencies), Gnatchop_File => Ali (Token .. Ptr - 1), Gnatchop_Offset => Gnatchop_Offset); - elsif Dependencies and then Ali (Ptr) = W then + elsif Dependencies and then Ali (Ptr) = 'W' then -- Found with-clause information. Format looks like: -- "W debug%s debug.adb debug.ali" @@ -662,12 +643,13 @@ package body Xref_Lib is Parse_Token (Ali, Ptr, Token); Parse_Token (Ali, Ptr, Token); - Add_File + Add_To_Xref_File (Ali (Token .. Ptr - 1), - File_Existed, File_Ref, + File_Existed, + File_Ref, Visited => False); - elsif Ali (Ptr) = X then + elsif Ali (Ptr) = 'X' then -- Found a cross-referencing line - stop processing File.Current_Line := Ptr; @@ -852,7 +834,10 @@ package body Xref_Lib is Decl_Ref := Add_Declaration (File.X_File, Ali (E_Name .. Ptr - 1), E_Line, E_Col, E_Type); - if Ali (Ptr) = '<' then + if Ali (Ptr) = '<' + or else Ali (Ptr) = '(' + or else Ali (Ptr) = '{' + then -- Here we have a type derivation information. The format is -- <3|12I45> which means that the current entity is derived from the @@ -860,115 +845,137 @@ package body Xref_Lib is -- unit number is optional. It is specified only if the parent type -- is not defined in the current unit. + -- We could also have something like + -- 16I9*I<integer> + -- that indicates that I derives from the predefined type integer. + Ptr := Ptr + 1; - Parse_Derived_Info : declare - P_Line : Natural; -- parent entity line - P_Column : Natural; -- parent entity column - P_Type : Character; -- parent entity type - P_Eun : Positive; -- parent entity file number + if Ali (Ptr) in '0' .. '9' then + Parse_Derived_Info : declare + P_Line : Natural; -- parent entity line + P_Column : Natural; -- parent entity column + P_Type : Character; -- parent entity type + P_Eun : Positive; -- parent entity file number - begin - Parse_Number (Ali, Ptr, P_Line); + begin + Parse_Number (Ali, Ptr, P_Line); - -- If we have a pipe then the first number was the unit number + -- If we have a pipe then the first number was the unit number - if Ali (Ptr) = '|' then - P_Eun := P_Line; - Ptr := Ptr + 1; + if Ali (Ptr) = '|' then + P_Eun := P_Line; + Ptr := Ptr + 1; - -- Now we have the line number + -- Now we have the line number - Parse_Number (Ali, Ptr, P_Line); + Parse_Number (Ali, Ptr, P_Line); - else - -- We don't have a unit number specified, so we set P_Eun to - -- the current unit. + else + -- We don't have a unit number specified, so we set P_Eun to + -- the current unit. - for K in Dependencies_Tables.First .. Last (File.Dep) loop - P_Eun := K; - exit when File.Dep.Table (K) = File_Ref; - end loop; - end if; + for K in Dependencies_Tables.First .. Last (File.Dep) loop + P_Eun := K; + exit when File.Dep.Table (K) = File_Ref; + end loop; + end if; - -- Then parse the type and column number + -- Then parse the type and column number - P_Type := Ali (Ptr); - Ptr := Ptr + 1; - Parse_Number (Ali, Ptr, P_Column); - - -- Skip '>' + P_Type := Ali (Ptr); + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, P_Column); - Ptr := Ptr + 1; + -- Skip '>', or ')' or '>' - -- The derived info is needed only is the derived info mode is on - -- or if we want to output the type hierarchy + Ptr := Ptr + 1; - if Der_Info or else Type_Tree then - Add_Parent - (Decl_Ref, - Get_Symbol_Name (P_Eun, P_Line, P_Column), - P_Line, - P_Column, - File.Dep.Table (P_Eun)); - end if; + -- The derived info is needed only is the derived info mode is + -- on or if we want to output the type hierarchy - if Type_Tree then - Search_Parent_Tree : declare - Pattern : Search_Pattern; -- Parent type pattern - File_Pos_Backup : Positive; + if Der_Info or else Type_Tree then + Add_Parent + (Decl_Ref, + Get_Symbol_Name (P_Eun, P_Line, P_Column), + P_Line, + P_Column, + File.Dep.Table (P_Eun)); + end if; - begin - Add_Entity - (Pattern, - Get_Symbol_Name (P_Eun, P_Line, P_Column) - & ':' & Get_Gnatchop_File (File.Dep.Table (P_Eun)) - & ':' & Get_Line (Get_Parent (Decl_Ref)) - & ':' & Get_Column (Get_Parent (Decl_Ref)), + if Type_Tree then + Search_Parent_Tree : declare + Pattern : Search_Pattern; -- Parent type pattern + File_Pos_Backup : Positive; + + begin + Add_Entity + (Pattern, + Get_Symbol_Name (P_Eun, P_Line, P_Column) + & ':' & Get_Gnatchop_File (File.Dep.Table (P_Eun)) + & ':' & Get_Line (Get_Parent (Decl_Ref)) + & ':' & Get_Column (Get_Parent (Decl_Ref)), False); - -- No default match is needed to look for the parent type - -- since we are using the fully qualified symbol name: - -- symbol:file:line:column + -- No default match is needed to look for the parent type + -- since we are using the fully qualified symbol name: + -- symbol:file:line:column - Set_Default_Match (False); + Set_Default_Match (False); - -- The parent type is defined in the same unit as the - -- derived type. So we want to revisit the unit. + -- The parent type is defined in the same unit as the + -- derived type. So we want to revisit the unit. - File_Pos_Backup := File.Current_Line; + File_Pos_Backup := File.Current_Line; - if File.Dep.Table (P_Eun) = File_Ref then + if File.Dep.Table (P_Eun) = File_Ref then - -- set file pointer at the start of the xref lines + -- set file pointer at the start of the xref lines - File.Current_Line := File.Xref_Line; + File.Current_Line := File.Xref_Line; - Revisit_ALI_File : declare - File_Existed : Boolean; - File_Ref : File_Reference; - begin - Add_File - (ALI_File_Name (Get_File (File.Dep.Table (P_Eun))), - File_Existed, - File_Ref, - Visited => False); - Set_Unvisited (File_Ref); - end Revisit_ALI_File; - end if; + Revisit_ALI_File : declare + File_Existed : Boolean; + File_Ref : File_Reference; - Search (Pattern, - Local_Symbols, False, False, Der_Info, Type_Tree); + begin + Add_To_Xref_File + (ALI_File_Name + (Get_File (File.Dep.Table (P_Eun))), + File_Existed, + File_Ref, + Visited => False); + Set_Unvisited (File_Ref); + end Revisit_ALI_File; + end if; - File.Current_Line := File_Pos_Backup; + Search (Pattern, + Local_Symbols, False, False, Der_Info, Type_Tree); - -- in this mode there is no need to parse the remaining of - -- the lines. + File.Current_Line := File_Pos_Backup; + end Search_Parent_Tree; + end if; + end Parse_Derived_Info; - return; - end Search_Parent_Tree; - end if; - end Parse_Derived_Info; + else + while Ali (Ptr) /= '>' + and then Ali (Ptr) /= ')' + and then Ali (Ptr) /= '}' + loop + Ptr := Ptr + 1; + end loop; + Ptr := Ptr + 1; + end if; + + elsif Ali (Ptr) = '=' then + declare + P_Line, P_Column : Natural; + begin + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, P_Line); + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, P_Column); + end; end if; -- To find the body, we will have to parse the file too @@ -981,8 +988,8 @@ package body Xref_Lib is Get_Gnatchop_File (File.X_File); begin - Add_File (ALI_File_Name (File_Name), - File_Existed, File_Ref, False); + Add_To_Xref_File + (ALI_File_Name (File_Name), File_Existed, File_Ref, False); end; end if; @@ -1017,6 +1024,24 @@ package body Xref_Lib is Add_Reference (Decl_Ref, File_Ref, R_Line, R_Col, R_Type); + -- Skip generic information, if any + + if Ali (Ptr) = '[' then + declare + Num_Nested : Integer := 1; + begin + Ptr := Ptr + 1; + while Num_Nested /= 0 loop + if Ali (Ptr) = ']' then + Num_Nested := Num_Nested - 1; + elsif Ali (Ptr) = '[' then + Num_Nested := Num_Nested + 1; + end if; + Ptr := Ptr + 1; + end loop; + end; + end if; + end loop; Parse_EOL (Ali, Ptr); @@ -1076,8 +1101,11 @@ package body Xref_Lib is while (In_Quotes or else not (Source (Ptr) = ' ' - or else Source (Ptr) = ASCII.HT - or else Source (Ptr) = '<')) + or else Source (Ptr) = ASCII.HT + or else Source (Ptr) = '<' + or else Source (Ptr) = '{' + or else Source (Ptr) = '=' + or else Source (Ptr) = '(')) and then Source (Ptr) >= ' ' loop if Source (Ptr) = '"' then @@ -1098,7 +1126,7 @@ package body Xref_Lib is File_Nr : Natural; begin - while Ali (Ptr) = X loop + while Ali (Ptr) = 'X' loop -- The current line is the start of a new Xref file section, -- whose format looks like: diff --git a/gcc/ada/xref_lib.ads b/gcc/ada/xref_lib.ads index 1282ad142dc..a6903105687 100644 --- a/gcc/ada/xref_lib.ads +++ b/gcc/ada/xref_lib.ads @@ -6,9 +6,9 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.20 $ +-- $Revision$ -- -- --- Copyright (C) 1998-1999 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -68,10 +68,9 @@ package Xref_Lib is -- this procedure. Glob indicates if we should use the 'globbing -- patterns' (True) or the full regular expressions (False) - procedure Add_File (File : String); - -- Add a new file in the list of files to search for references. - -- File is considered to be a globbing regular expression, which is thus - -- expanded + procedure Add_Xref_File (File : String); + -- Add a new file in the list of files to search for references. File + -- is interpreted as a globbing regular expression, which is expanded. Invalid_Argument : exception; -- Exception raised when there is a syntax error in the command line @@ -155,7 +154,6 @@ package Xref_Lib is -- if Dependencies is True, the insert every library file 'with'ed in -- the files database (used for gnatxref) - private type Rec_DIR is limited record Dir : GNAT.Directory_Operations.Dir_Type; |
