mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-18 01:20:48 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2003-12-03  Thomas Quinot  <quinot@act-europe.fr>

	PR ada/11724

	* adaint.h, adaint.c, g-os_lib.ads:
	Do not assume that the offset argument to lseek(2) is a 32 bit integer,
	on some platforms (including FreeBSD), it is a 64 bit value.
	Introduce a __gnat_lseek wrapper in adaint.c to allow for portability.

2003-12-03  Arnaud Charlet  <charlet@act-europe.fr>

	* gnatvsn.ads (Library_Version): Now contain only the relevant
	version info.
	(Verbose_Library_Version): New constant.

	* g-spipat.adb, g-awk.adb, g-debpoo.adb,
	g-memdum.adb, g-thread.adb, s-geveop.adb, s-interr.adb,
	s-taskin.adb, s-tassta.adb: Make code compile with -gnatwa.

	* gnatlbr.adb: Clean up: replace Library_Version by
	Verbose_Library_Version.

	* make.adb, lib-writ.adb, exp_attr.adb:
	Clean up: replace Library_Version by Verbose_Library_Version.

	* 5lintman.adb: Removed.

	* Makefile.in:
	Update and simplify computation of LIBRARY_VERSION.
	Fix computation of GSMATCH_VERSION.
	5lintman.adb is no longer used: replaced by 7sintman.adb.

2003-12-03  Robert Dewar  <dewar@gnat.com>

	* exp_ch5.adb:
	(Possible_Bit_Aligned_Component): Maybe_Bit_Aligned_Large_Component new
	name. Modified to consider small non-bit-packed arrays as troublesome
	and in need of component-by-component assigment expansion.

2003-12-03  Vincent Celier  <celier@gnat.com>

	* lang-specs.h: Process nostdlib as nostdinc

	* back_end.adb: Update Copyright notice
	(Scan_Compiler_Arguments): Process -nostdlib directly.

2003-12-03  Jose Ruiz  <ruiz@act-europe.fr>

	* Makefile.in:
	When defining LIBGNAT_TARGET_PAIRS for bare board targets, remove the
	redundant inclusion of EXTRA_HIE_NONE_TARGET_PAIRS, which is always
	included in HIE_NONE_TARGET_PAIRS.

2003-12-03  Ed Schonberg  <schonberg@gnat.com>

	* sem_attr.adb:
	(Legal_Formal_Attribute): Attribute is legal in an inlined body, as it
	is legal in an instance, because legality is cheched in the template.

	* sem_prag.adb:
	(Analyze_Pragma, case Warnings): In an inlined body, the pragma may be
	appplied to an unchecked conversion of a formal parameter.

	* sem_warn.adb:
	(Output_Unreferenced_Messages): Suppress "not read" warnings on imported
	variables.

2003-12-03  Olivier Hainque  <hainque@act-europe.fr>

	* tb-alvms.c (unwind_regular_code, unwind_kernel_handler): New
	routines. The second one is new functionality to deal with backtracing
	through signal handlers.
	(unwind): Split into the two separate subroutines above.
	Update the documentation, and deal properly with sizeof (REG) different
	from sizeof (void*).

From-SVN: r74226
This commit is contained in:
Arnaud Charlet 2003-12-03 12:47:53 +01:00
parent 1fcc57f195
commit efdfd311d6
27 changed files with 441 additions and 589 deletions

401
gcc/ada/5lintman.adb

@ -1,401 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
-- --
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNARL; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the GNU/Linux version of this package
-- This file performs the system-dependent translation between machine
-- exceptions and the Ada exceptions, if any, that should be raised when they
-- occur. This version works for the x86 running linux.
-- This is a Sun OS (FSU THREADS) version of this package
-- PLEASE DO NOT add any dependences on other packages. ??? why not ???
-- This package is designed to work with or without tasking support.
-- Make a careful study of all signals available under the OS, to see which
-- need to be reserved, kept always unmasked, or kept always unmasked. Be on
-- the lookout for special signals that may be used by the thread library.
-- The definitions of "reserved" differ slightly between the ARM and POSIX.
-- Here is the ARM definition of reserved interrupt:
-- The set of reserved interrupts is implementation defined. A reserved
-- interrupt is either an interrupt for which user-defined handlers are not
-- supported, or one which already has an attached handler by some other
-- implementation-defined means. Program units can be connected to
-- non-reserved interrupts.
-- POSIX.5b/.5c specifies further:
-- Signals which the application cannot accept, and for which the application
-- cannot modify the signal action or masking, because the signals are
-- reserved for use by the Ada language implementation. The reserved signals
-- defined by this standard are Signal_Abort, Signal_Alarm,
-- Signal_Floating_Point_Error, Signal_Illegal_Instruction,
-- Signal_Segmentation_Violation, Signal_Bus_Error. If the implementation
-- supports any signals besides those defined by this standard, the
-- implementation may also reserve some of those.
-- The signals defined by POSIX.5b/.5c that are not specified as being
-- reserved are SIGHUP, SIGINT, SIGPIPE, SIGQUIT, SIGTERM, SIGUSR1, SIGUSR2,
-- SIGCHLD, SIGCONT, SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGIO SIGURG, and all
-- the real-time signals.
-- Beware of reserving signals that POSIX.5b/.5c require to be available for
-- users. POSIX.5b/.5c say:
-- An implementation shall not impose restrictions on the ability of an
-- application to send, accept, block, or ignore the signals defined by this
-- standard, except as specified in this standard.
-- Here are some other relevant requirements from POSIX.5b/.5c:
-- For the environment task, the initial signal mask is that specified for
-- the process...
-- It is anticipated that the paragraph above may be modified by a future
-- revision of this standard, to require that the realtime signals always be
-- initially masked for a process that is an Ada active partition.
-- For all other tasks, the initial signal mask shall include all the signals
-- that are not reserved signals and are not bound to entries of the task.
with Interfaces.C;
-- used for int and other types
with System.Error_Reporting;
-- used for Shutdown
with System.OS_Interface;
-- used for various Constants, Signal and types
with Ada.Exceptions;
-- used for Exception_Id
-- Raise_From_Signal_Handler
with System.Soft_Links;
-- used for Get_Machine_State_Addr
with Unchecked_Conversion;
package body System.Interrupt_Management is
use Interfaces.C;
use System.Error_Reporting;
use System.OS_Interface;
package TSL renames System.Soft_Links;
type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
Exception_Interrupts : constant Interrupt_List :=
(SIGFPE, SIGILL, SIGSEGV);
Unreserve_All_Interrupts : Interfaces.C.int;
pragma Import
(C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
subtype int is Interfaces.C.int;
subtype unsigned_short is Interfaces.C.unsigned_short;
subtype unsigned_long is Interfaces.C.unsigned_long;
----------------------
-- Notify_Exception --
----------------------
pragma Warnings (Off);
-- Because many unaccessed arguments
Signal_Mask : aliased sigset_t;
-- The set of signals handled by Notify_Exception
-- This function identifies the Ada exception to be raised using
-- the information when the system received a synchronous signal.
-- Since this function is machine and OS dependent, different code
-- has to be provided for different target.
procedure Notify_Exception
(signo : Signal;
gs : unsigned_short;
fs : unsigned_short;
es : unsigned_short;
ds : unsigned_short;
edi : unsigned_long;
esi : unsigned_long;
ebp : unsigned_long;
esp : unsigned_long;
ebx : unsigned_long;
edx : unsigned_long;
ecx : unsigned_long;
eax : unsigned_long;
trapno : unsigned_long;
err : unsigned_long;
eip : unsigned_long;
cs : unsigned_short;
eflags : unsigned_long;
esp_at_signal : unsigned_long;
ss : unsigned_short;
fpstate : System.Address;
oldmask : unsigned_long;
cr2 : unsigned_long);
procedure Notify_Exception
(signo : Signal;
gs : unsigned_short;
fs : unsigned_short;
es : unsigned_short;
ds : unsigned_short;
edi : unsigned_long;
esi : unsigned_long;
ebp : unsigned_long;
esp : unsigned_long;
ebx : unsigned_long;
edx : unsigned_long;
ecx : unsigned_long;
eax : unsigned_long;
trapno : unsigned_long;
err : unsigned_long;
eip : unsigned_long;
cs : unsigned_short;
eflags : unsigned_long;
esp_at_signal : unsigned_long;
ss : unsigned_short;
fpstate : System.Address;
oldmask : unsigned_long;
cr2 : unsigned_long)
is
pragma Warnings (On);
function To_Machine_State_Ptr is new
Unchecked_Conversion (Address, Machine_State_Ptr);
-- These are not directly visible
procedure Raise_From_Signal_Handler
(E : Ada.Exceptions.Exception_Id;
M : System.Address);
pragma Import
(Ada, Raise_From_Signal_Handler,
"ada__exceptions__raise_from_signal_handler");
pragma No_Return (Raise_From_Signal_Handler);
mstate : Machine_State_Ptr;
message : aliased constant String := "" & ASCII.Nul;
-- A null terminated String.
Result : int;
begin
-- Raise_From_Signal_Handler makes sure that the exception is raised
-- safely from this signal handler.
-- ??? The original signal mask (the one we had before coming into this
-- signal catching function) should be restored by
-- Raise_From_Signal_Handler. For now, restore it explicitely
Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
pragma Assert (Result = 0);
-- Check that treatment of exception propagation here
-- is consistent with treatment of the abort signal in
-- System.Task_Primitives.Operations.
mstate := To_Machine_State_Ptr (TSL.Get_Machine_State_Addr.all);
mstate.eip := eip;
mstate.ebx := ebx;
mstate.esp := esp_at_signal;
mstate.ebp := ebp;
mstate.esi := esi;
mstate.edi := edi;
case signo is
when SIGFPE =>
Raise_From_Signal_Handler
(Constraint_Error'Identity, message'Address);
when SIGILL =>
Raise_From_Signal_Handler
(Constraint_Error'Identity, message'Address);
when SIGSEGV =>
Raise_From_Signal_Handler
(Storage_Error'Identity, message'Address);
when others =>
if Shutdown ("Unexpected signal") then
null;
end if;
end case;
end Notify_Exception;
---------------------------
-- Initialize_Interrupts --
---------------------------
-- Nothing needs to be done on this platform.
procedure Initialize_Interrupts is
begin
null;
end Initialize_Interrupts;
begin
declare
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
Result : int;
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
User : constant Character := 'u';
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
-- 'u' Interrupt_State pragma set state to User
-- 'r' Interrupt_State pragma set state to Runtime
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
begin
-- Need to call pthread_init very early because it is doing signal
-- initializations.
pthread_init;
Abort_Task_Interrupt := SIGADAABORT;
act.sa_handler := Notify_Exception'Address;
act.sa_flags := 0;
-- On some targets, we set sa_flags to SA_NODEFER so that during the
-- handler execution we do not change the Signal_Mask to be masked for
-- the Signal.
-- This is a temporary fix to the problem that the Signal_Mask is
-- not restored after the exception (longjmp) from the handler.
-- The right fix should be made in sigsetjmp so that we save
-- the Signal_Set and restore it after a longjmp.
-- Since SA_NODEFER is obsolete, instead we reset explicitely
-- the mask in the exception handler.
Result := sigemptyset (Signal_Mask'Access);
pragma Assert (Result = 0);
-- Add signals that map to Ada exceptions to the mask.
for J in Exception_Interrupts'Range loop
if State (Exception_Interrupts (J)) /= Default then
Result :=
sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
pragma Assert (Result = 0);
end if;
end loop;
act.sa_mask := Signal_Mask;
pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
pragma Assert (Reserve = (Interrupt_ID'Range => False));
-- Process state of exception signals
for J in Exception_Interrupts'Range loop
if State (Exception_Interrupts (J)) /= User then
Keep_Unmasked (Exception_Interrupts (J)) := True;
Reserve (Exception_Interrupts (J)) := True;
if State (Exception_Interrupts (J)) /= Default then
Result :=
sigaction
(Signal (Exception_Interrupts (J)), act'Unchecked_Access,
old_act'Unchecked_Access);
pragma Assert (Result = 0);
end if;
end if;
end loop;
if State (Abort_Task_Interrupt) /= User then
Keep_Unmasked (Abort_Task_Interrupt) := True;
Reserve (Abort_Task_Interrupt) := True;
end if;
-- Set SIGINT to unmasked state as long as it's
-- not in "User" state. Check for Unreserve_All_Interrupts last
if State (SIGINT) /= User then
Keep_Unmasked (SIGINT) := True;
Reserve (SIGINT) := True;
end if;
-- Check all signals for state that requires keeping them
-- unmasked and reserved
for J in Interrupt_ID'Range loop
if State (J) = Default or else State (J) = Runtime then
Keep_Unmasked (J) := True;
Reserve (J) := True;
end if;
end loop;
-- Add the set of signals that must always be unmasked for this target
for J in Unmasked'Range loop
Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
Reserve (Interrupt_ID (Unmasked (J))) := True;
end loop;
-- Add target-specific reserved signals
for J in Reserved'Range loop
Reserve (Interrupt_ID (Reserved (J))) := True;
end loop;
-- Process pragma Unreserve_All_Interrupts. This overrides any
-- settings due to pragma Interrupt_State:
if Unreserve_All_Interrupts /= 0 then
Keep_Unmasked (SIGINT) := False;
Reserve (SIGINT) := False;
end if;
-- We do not have Signal 0 in reality. We just use this value
-- to identify non-existent signals (see s-intnam.ads). Therefore,
-- Signal 0 should not be used in all signal related operations hence
-- mark it as reserved.
Reserve (0) := True;
end;
end System.Interrupt_Management;

76
gcc/ada/ChangeLog

@ -1,3 +1,79 @@
2003-12-03 Thomas Quinot <quinot@act-europe.fr>
PR ada/11724
* adaint.h, adaint.c, g-os_lib.ads:
Do not assume that the offset argument to lseek(2) is a 32 bit integer,
on some platforms (including FreeBSD), it is a 64 bit value.
Introduce a __gnat_lseek wrapper in adaint.c to allow for portability.
2003-12-03 Arnaud Charlet <charlet@act-europe.fr>
* gnatvsn.ads (Library_Version): Now contain only the relevant
version info.
(Verbose_Library_Version): New constant.
* g-spipat.adb, g-awk.adb, g-debpoo.adb,
g-memdum.adb, g-thread.adb, s-geveop.adb, s-interr.adb,
s-taskin.adb, s-tassta.adb: Make code compile with -gnatwa.
* gnatlbr.adb: Clean up: replace Library_Version by
Verbose_Library_Version.
* make.adb, lib-writ.adb, exp_attr.adb:
Clean up: replace Library_Version by Verbose_Library_Version.
* 5lintman.adb: Removed.
* Makefile.in:
Update and simplify computation of LIBRARY_VERSION.
Fix computation of GSMATCH_VERSION.
5lintman.adb is no longer used: replaced by 7sintman.adb.
2003-12-03 Robert Dewar <dewar@gnat.com>
* exp_ch5.adb:
(Possible_Bit_Aligned_Component): Maybe_Bit_Aligned_Large_Component new
name. Modified to consider small non-bit-packed arrays as troublesome
and in need of component-by-component assigment expansion.
2003-12-03 Vincent Celier <celier@gnat.com>
* lang-specs.h: Process nostdlib as nostdinc
* back_end.adb: Update Copyright notice
(Scan_Compiler_Arguments): Process -nostdlib directly.
2003-12-03 Jose Ruiz <ruiz@act-europe.fr>
* Makefile.in:
When defining LIBGNAT_TARGET_PAIRS for bare board targets, remove the
redundant inclusion of EXTRA_HIE_NONE_TARGET_PAIRS, which is always
included in HIE_NONE_TARGET_PAIRS.
2003-12-03 Ed Schonberg <schonberg@gnat.com>
* sem_attr.adb:
(Legal_Formal_Attribute): Attribute is legal in an inlined body, as it
is legal in an instance, because legality is cheched in the template.
* sem_prag.adb:
(Analyze_Pragma, case Warnings): In an inlined body, the pragma may be
appplied to an unchecked conversion of a formal parameter.
* sem_warn.adb:
(Output_Unreferenced_Messages): Suppress "not read" warnings on imported
variables.
2003-12-03 Olivier Hainque <hainque@act-europe.fr>
* tb-alvms.c (unwind_regular_code, unwind_kernel_handler): New
routines. The second one is new functionality to deal with backtracing
through signal handlers.
(unwind): Split into the two separate subroutines above.
Update the documentation, and deal properly with sizeof (REG) different
from sizeof (void*).
2003-12-01 Nicolas Setton <setton@act-europe.fr>
* a-except.adb (Raise_Current_Excep): Add a pragma Inspection_Point,

41
gcc/ada/Makefile.in

@ -375,6 +375,8 @@ PREFIX_REAL_OBJS = ../prefix.o \
../../libiberty/xstrdup.o \
../../libiberty/xexit.o
LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/'))
# $(filter-out PATTERN...,TEXT) removes all PATTERN words from TEXT.
# $(strip STRING) removes leading and trailing spaces from STRING.
# If what's left is null then it's a match.
@ -450,7 +452,7 @@ ifeq ($(strip $(filter-out %86 sysv5uw%,$(arch) $(osys))),)
PREFIX_OBJS=$(PREFIX_REAL_OBJS)
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/'))
LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out alpha% dec vx%,$(targ))),)
@ -692,8 +694,7 @@ ifeq ($(strip $(filter-out powerpc% unknown elf,$(targ))),)
system.ads<59system.ads
LIBGNAT_TARGET_PAIRS = \
$(HIE_NONE_TARGET_PAIRS) \
$(EXTRA_HIE_NONE_TARGET_PAIRS)
$(HIE_NONE_TARGET_PAIRS)
endif
ifeq ($(strip $(filter-out sparc% unknown elf,$(targ))),)
@ -701,8 +702,7 @@ ifeq ($(strip $(filter-out sparc% unknown elf,$(targ))),)
system.ads<5rsystem.ads
LIBGNAT_TARGET_PAIRS = \
$(HIE_NONE_TARGET_PAIRS) \
$(EXTRA_HIE_NONE_TARGET_PAIRS)
$(HIE_NONE_TARGET_PAIRS)
endif
ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),)
@ -819,7 +819,7 @@ ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),)
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
LIBRARY_VERSION := $(LIB_VERSION)
ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \
@ -903,7 +903,7 @@ ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),)
SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
@ -912,7 +912,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
a-numaux.adb<86numaux.adb \
a-numaux.ads<86numaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-intman.adb<5lintman.adb \
s-intman.adb<7sintman.adb \
s-mastop.adb<5omastop.adb \
s-osinte.adb<5iosinte.adb \
s-osinte.ads<5iosinte.ads \
@ -929,7 +929,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
LIBRARY_VERSION := $(LIB_VERSION)
ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \
@ -937,7 +937,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
a-numaux.adb<86numaux.adb \
a-numaux.ads<86numaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-intman.adb<5lintman.adb \
s-intman.adb<7sintman.adb \
s-mastop.adb<5omastop.adb \
s-osinte.adb<7sosinte.adb \
s-osinte.ads<5losinte.ads \
@ -967,7 +967,7 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
system.ads<56system.ads
THREADSLIB=
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
@ -1021,7 +1021,7 @@ ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
MISCLIB = -lexc
SO_OPTS = -Wl,-all,-set_version,sgi1.0,-update_registry,../so_locations,-soname,
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out hppa% hp hpux10%,$(targ))),)
@ -1069,7 +1069,7 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),)
SO_OPTS = -Wl,+h,
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
GNATLIB_SHARED = gnatlib-shared-dual
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
LIBRARY_VERSION := $(LIB_VERSION)
ifeq ($(strip $(filter-out dce DCE,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \
@ -1220,7 +1220,7 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),)
THREADSLIB = -lpthread -lmach -lexc -lrt
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
GNATLIB_SHARED = gnatlib-shared-default
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(host))),)
@ -1290,8 +1290,7 @@ endif
../../gnatlbr$(exeext) \
,,/../gnatsym$(exeext)
# This command transforms (YYYYMMDD) into YY,MMDD
GSMATCH_VERSION := $(shell grep "^ *Gnat_Version_String" $(fsrcpfx)gnatvsn.ads | sed -e 's/.*(\(.*\)).*/\1/' -e 's/\(..\)\(..\)\(....\)/\2,\3/')
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/' -e 's/\./_/g'))
GSMATCH_VERSION := $(shell grep "^ *Gnat_Static_Version_String" $(fsrcpfx)gnatvsn.ads | sed -e 's/.*(\(.*\)).*/\1/' -e 's/\(..\)\(..\)\(....\)/\2,\3/')
TOOLS_LIBS_LO := --for-linker=sys\\$$\$$library:trace.exe
endif
@ -1328,14 +1327,14 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
EXTRA_GNATRTL_NONTASKING_OBJS = g-regist.o
soext = .dll
GNATLIB_SHARED = gnatlib-shared-win32
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \
s-inmaop.adb<7sinmaop.adb \
s-intman.adb<5lintman.adb \
s-intman.adb<7sintman.adb \
s-osinte.ads<5iosinte.ads \
s-osinte.adb<5iosinte.adb \
s-osprim.adb<7sosprim.adb \
@ -1349,14 +1348,14 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
PREFIX_OBJS=$(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
LIBRARY_VERSION := $(LIB_VERSION)
endif
ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \
s-inmaop.adb<7sinmaop.adb \
s-intman.adb<5lintman.adb \
s-intman.adb<7sintman.adb \
s-osinte.ads<5iosinte.ads \
s-osinte.adb<5iosinte.adb \
s-osprim.adb<7sosprim.adb \
@ -1370,7 +1369,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),)
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
PREFIX_OBJS=$(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
LIBRARY_VERSION := $(LIB_VERSION)
endif
# The runtime library for gnat comprises two directories. One contains the

6
gcc/ada/adaint.c

@ -2481,3 +2481,9 @@ __gnatlib_install_locks (void (*lock) (void) ATTRIBUTE_UNUSED,
a no-op in this case. */
#endif
}
int
__gnat_lseek (int fd, long offset, int whence)
{
return (int) lseek (fd, offset, whence);
}

1
gcc/ada/adaint.h

@ -140,6 +140,7 @@ extern int __gnat_expect_poll (int *, int, int, int *);
extern void __gnat_set_binary_mode (int);
extern void __gnat_set_text_mode (int);
extern char *__gnat_ttyname (int);
extern int __gnat_lseek (int, long, int);
#ifdef __MINGW32__
extern void __gnat_plist_init (void);

8
gcc/ada/back_end.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -270,6 +270,12 @@ package body Back_End is
Opt.No_Stdinc := True;
Scan_Back_End_Switches (Argv);
-- We must recognize -nostdlib to suppress visibility on the
-- standard GNAT RTL objects.
elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdlib" then
Opt.No_Stdlib := True;
elsif Is_Front_End_Switch (Argv) then
Scan_Front_End_Switches (Argv);

5
gcc/ada/exp_attr.adb

@ -907,8 +907,9 @@ package body Exp_Attr is
if Pent = Standard_Standard
or else Pent = Standard_ASCII
then
Name_Buffer (1 .. Library_Version'Length) := Library_Version;
Name_Len := Library_Version'Length;
Name_Buffer (1 .. Verbose_Library_Version'Length) :=
Verbose_Library_Version;
Name_Len := Verbose_Library_Version'Length;
Rewrite (N,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));

83
gcc/ada/exp_ch5.adb

@ -95,24 +95,6 @@ package body Exp_Ch5 is
-- either because the target is not byte aligned, or there is a change
-- of representation.
function Maybe_Bit_Aligned_Large_Component (N : Node_Id) return Boolean;
-- This function is used in processing the assignment of a record or
-- indexed component. The back end can handle such assignments fine
-- if the objects involved are small (64-bits) or are both aligned on
-- a byte boundary (starts on a byte, and ends on a byte). However,
-- problems arise for large components that are not byte aligned,
-- since the assignment may clobber other components that share bit
-- positions in the starting or ending bytes, and in the case of
-- components not starting on a byte boundary, the back end cannot
-- even manage to extract the value. This function is used to detect
-- such situations, so that the assignment can be handled component-wise.
-- A value of False means that either the object is known to be greater
-- than 64 bits, or that it is known to be byte aligned (and occupy an
-- integral number of bytes. True is returned if the object is known to
-- be greater than 64 bits, and is known to be unaligned. As implied
-- by the name, the result is conservative, in that if the compiler
-- cannot determine these conditions at compile time, True is returned.
function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
-- Generate the necessary code for controlled and Tagged assignment,
-- that is to say, finalization of the target before, adjustement of
@ -120,13 +102,41 @@ package body Exp_Ch5 is
-- pointers which are not 'part of the value' and must not be changed
-- upon assignment. N is the original Assignment node.
function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean;
-- This function is used in processing the assignment of a record or
-- indexed component. The back end can handle such assignments fine
-- if the objects involved are small (64-bits or less) records or
-- scalar items (including bit-packed arrays represented with modular
-- types) or are both aligned on a byte boundary (starting on a byte
-- boundary, and occupying an integral number of bytes).
--
-- However, problems arise for records larger than 64 bits, or for
-- arrays (other than bit-packed arrays represented with a modular
-- type) if the component starts on a non-byte boundary, or does
-- not occupy an integral number of bytes (i.e. there are some bits
-- possibly shared with fields at the start or beginning of the
-- component). The back end cannot handle loading and storing such
-- components in a single operation.
--
-- This function is used to detect the troublesome situation. it is
-- conservative in the sense that it produces True unless it knows
-- for sure that the component is safe (as outlined in the first
-- paragraph above). The code generation for record and array
-- assignment checks for trouble using this function, and if so
-- the assignment is generated component-wise, which the back end
-- is required to handle correctly.
--
-- Note that in GNAT 3, the back end will reject such components
-- anyway, so the hard work in checking for this case is wasted
-- in GNAT 3, but it's harmless, so it is easier to do it in
-- all cases, rather than conditionalize it in GNAT 5 or beyond.
------------------------------
-- Change_Of_Representation --
------------------------------
function Change_Of_Representation (N : Node_Id) return Boolean is
Rhs : constant Node_Id := Expression (N);
begin
return
Nkind (Rhs) = N_Type_Conversion
@ -372,9 +382,9 @@ package body Exp_Ch5 is
-- We require a loop if the left side is possibly bit unaligned
elsif Maybe_Bit_Aligned_Large_Component (Lhs)
elsif Possible_Bit_Aligned_Component (Lhs)
or else
Maybe_Bit_Aligned_Large_Component (Rhs)
Possible_Bit_Aligned_Component (Rhs)
then
Loop_Required := True;
@ -1026,9 +1036,9 @@ package body Exp_Ch5 is
-- clobbering of other components sharing bits in the first or
-- last byte of the component to be assigned.
elsif Maybe_Bit_Aligned_Large_Component (Lhs)
elsif Possible_Bit_Aligned_Component (Lhs)
or
Maybe_Bit_Aligned_Large_Component (Rhs)
Possible_Bit_Aligned_Component (Rhs)
then
null;
@ -3221,11 +3231,11 @@ package body Exp_Ch5 is
return Empty_List;
end Make_Tag_Ctrl_Assignment;
---------------------------------------
-- Maybe_Bit_Aligned_Large_Component --
---------------------------------------
------------------------------------
-- Possible_Bit_Aligned_Component --
------------------------------------
function Maybe_Bit_Aligned_Large_Component (N : Node_Id) return Boolean is
function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
begin
case Nkind (N) is
@ -3250,7 +3260,7 @@ package body Exp_Ch5 is
-- indexing from a possibly unaligned component.
else
return Maybe_Bit_Aligned_Large_Component (P);
return Possible_Bit_Aligned_Component (P);
end if;
end;
@ -3268,17 +3278,22 @@ package body Exp_Ch5 is
-- only the recursive test on the prefix.
if No (Component_Clause (Comp)) then
return Maybe_Bit_Aligned_Large_Component (P);
return Possible_Bit_Aligned_Component (P);
-- Otherwise we have a component clause, which means that
-- the Esize and Normalized_First_Bit fields are set and
-- contain static values known at compile time.
else
-- If we know the size is 64 bits or less we are fine
-- since the back end always handles small fields right.
-- If we know that we have a small (64 bits or less) record
-- or bit-packed array, then everything is fine, since the
-- back end can handle these cases correctly.
if Esize (Comp) <= 64 then
if Esize (Comp) <= 64
and then (Is_Record_Type (Etype (Comp))
or else
Is_Bit_Packed_Array (Etype (Comp)))
then
return False;
-- Otherwise if the component is not byte aligned, we
@ -3293,7 +3308,7 @@ package body Exp_Ch5 is
-- but we still need to test our prefix recursively.
else
return Maybe_Bit_Aligned_Large_Component (P);
return Possible_Bit_Aligned_Component (P);
end if;
end if;
end;
@ -3306,6 +3321,6 @@ package body Exp_Ch5 is
return False;
end case;
end Maybe_Bit_Aligned_Large_Component;
end Possible_Bit_Aligned_Component;
end Exp_Ch5;

10
gcc/ada/g-awk.adb

@ -873,8 +873,7 @@ package body GNAT.AWK is
Callbacks : Callback_Mode := None;
Session : Session_Type := Current_Session)
is
Filter_Active : Boolean;
Quit : Boolean;
Quit : Boolean;
begin
Open (Separators, Filename, Session);
@ -884,7 +883,12 @@ package body GNAT.AWK is
Split_Line (Session);
if Callbacks in Only .. Pass_Through then
Filter_Active := Apply_Filters (Session);
declare
Discard : Boolean;
pragma Unreferenced (Discard);
begin
Discard := Apply_Filters (Session);
end;
end if;
if Callbacks /= Only then

3
gcc/ada/g-debpoo.adb

@ -116,7 +116,7 @@ package body GNAT.Debug_Pools is
return Tracebacks_Array_Access;
function Hash (T : Tracebacks_Array_Access) return Header;
function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean;
pragma Inline (Set_Next, Next, Get_Key, Equal, Hash);
pragma Inline (Set_Next, Next, Get_Key, Hash);
-- Subprograms required for instantiation of the htable. See GNAT.HTable.
package Backtrace_Htable is new GNAT.HTable.Static_HTable
@ -374,7 +374,6 @@ package body GNAT.Debug_Pools is
function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is
use Ada.Exceptions.Traceback;
begin
return K1.all = K2.all;
end Equal;

2
gcc/ada/g-memdum.adb

@ -66,7 +66,7 @@ package body GNAT.Memory_Dump is
Line_Buf : String (1 .. Line_Len);
Hex : array (0 .. 15) of Character := "0123456789ABCDEF";
Hex : constant array (0 .. 15) of Character := "0123456789ABCDEF";
type Char_Ptr is access all Character;

2
gcc/ada/g-os_lib.ads

@ -359,7 +359,7 @@ pragma Elaborate_Body (OS_Lib);
(FD : File_Descriptor;
offset : Long_Integer;
origin : Integer);
pragma Import (C, Lseek, "lseek");
pragma Import (C, Lseek, "__gnat_lseek");
-- Sets the current file pointer to the indicated offset value,
-- relative to the current position (origin = SEEK_CUR), end of
-- file (origin = SEEK_END), or start of file (origin = SEEK_SET).

48
gcc/ada/g-spipat.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2002, Ada Core Technologies, Inc. --
-- Copyright (C) 1998-2003, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -343,30 +343,28 @@ package body GNAT.Spitbol.Patterns is
-- structure (i.e. it is a pattern that is guaranteed to match at least
-- one character on success, and not to make any entries on the stack.
OK_For_Simple_Arbno :
array (Pattern_Code) of Boolean := (
PC_Any_CS |
PC_Any_CH |
PC_Any_VF |
PC_Any_VP |
PC_Char |
PC_Len_Nat |
PC_NotAny_CS |
PC_NotAny_CH |
PC_NotAny_VF |
PC_NotAny_VP |
PC_Span_CS |
PC_Span_CH |
PC_Span_VF |
PC_Span_VP |
PC_String |
PC_String_2 |
PC_String_3 |
PC_String_4 |
PC_String_5 |
PC_String_6 => True,
others => False);
OK_For_Simple_Arbno : constant array (Pattern_Code) of Boolean :=
(PC_Any_CS |
PC_Any_CH |
PC_Any_VF |
PC_Any_VP |
PC_Char |
PC_Len_Nat |
PC_NotAny_CS |
PC_NotAny_CH |
PC_NotAny_VF |
PC_NotAny_VP |
PC_Span_CS |
PC_Span_CH |
PC_Span_VF |
PC_Span_VP |
PC_String |
PC_String_2 |
PC_String_3 |
PC_String_4 |
PC_String_5 |
PC_String_6 => True,
others => False);
-------------------------------
-- The Pattern History Stack --

12
gcc/ada/g-thread.adb

@ -81,8 +81,7 @@ package body GNAT.Threads is
(Code : Address;
Parm : Void_Ptr;
Size : Natural;
Prio : Integer)
return System.Address
Prio : Integer) return System.Address
is
TP : Tptr;
@ -108,7 +107,6 @@ package body GNAT.Threads is
procedure Unregister_Thread is
Self_Id : constant Tasking.Task_ID := Task_Primitives.Operations.Self;
begin
Self_Id.Common.State := Tasking.Terminated;
Destroy_TSD (Self_Id.Common.Compiler_Data);
@ -150,7 +148,6 @@ package body GNAT.Threads is
procedure Destroy_Thread (Id : Address) is
Tid : constant Task_Id := To_Id (Id);
begin
Abort_Task (Tid);
end Destroy_Thread;
@ -161,9 +158,7 @@ package body GNAT.Threads is
procedure Get_Thread (Id : Address; Thread : Address) is
use System.OS_Interface;
Thr : Thread_Id_Ptr := To_Thread (Thread);
Thr : constant Thread_Id_Ptr := To_Thread (Thread);
begin
Thr.all := Task_Primitives.Operations.Get_Thread_Id (To_Id (Id));
end Get_Thread;
@ -173,8 +168,7 @@ package body GNAT.Threads is
----------------
function To_Task_Id
(Id : System.Address)
return Ada.Task_Identification.Task_Id
(Id : System.Address) return Ada.Task_Identification.Task_Id
is
begin
return To_Tid (Id);

3
gcc/ada/gnatlbr.adb

@ -254,7 +254,8 @@ begin
& F_ADC_File (1 .. F_ADC_File_Len));
Make_Args (6) :=
new String'("LIBRARY_VERSION=" & '"' & Library_Version & '"');
new String'("LIBRARY_VERSION=" & '"' &
Verbose_Library_Version & '"');
Make_Args (7) :=
new String'("-f");

5
gcc/ada/gnatvsn.ads

@ -71,7 +71,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.4";
Library_Version : constant String := "3.4";
-- 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.
@ -79,6 +79,9 @@ package Gnatvsn is
-- Note: Makefile.in relies on the precise format of the library version
-- string in order to correctly construct the soname value.
Verbose_Library_Version : constant String := "GNAT Lib v" & Library_Version;
-- Version string stored in e.g. ALI files.
ASIS_Version_Number : constant := 2;
-- ASIS Version. This is used to check for consistency between the compiler
-- used to generate trees, and an ASIS application that is reading the

1
gcc/ada/lang-specs.h

@ -35,6 +35,7 @@
%{!gnatc*:%{!gnatz*:%{!gnats*:%{!S:%{!c:\
%eone of -c, -S, -gnatc, -gnatz, or -gnats is required for Ada}}}}}\
gnat1 %{I*} %{k8:-gnatk8} %{w:-gnatws} %1 %{!Q:-quiet} %{nostdinc*}\
%{nostdlib*}\
-dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\
%{g*} %{O*} %{W*} %{w} %{p} %{pg:-p} %{m*} %{a} %{f*} %{d*}\
%{!S:%{o*:%w%*-gnatO}} \

2
gcc/ada/lib-writ.adb

@ -729,7 +729,7 @@ package body Lib.Writ is
Write_Info_Initiate ('V');
Write_Info_Str (" """);
Write_Info_Str (Library_Version);
Write_Info_Str (Verbose_Library_Version);
Write_Info_Char ('"');
Write_Info_EOL;

2
gcc/ada/make.adb

@ -1356,7 +1356,7 @@ package body Make is
return;
elsif ALIs.Table (ALI).Ver (1 .. ALIs.Table (ALI).Ver_Len) /=
Library_Version
Verbose_Library_Version
then
Verbose_Msg (Full_Lib_File, "compiled with old GNAT version");
ALI := No_ALI_Id;

6
gcc/ada/s-geveop.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -61,7 +61,7 @@ package body System.Generic_Vector_Operations is
function VP is new Unchecked_Conversion (Address, Vector_Ptr);
function EP is new Unchecked_Conversion (Address, Element_Ptr);
SA : Address := XA + ((Length + 0) / VU * VU
SA : constant Address := XA + ((Length + 0) / VU * VU
and (Boolean'Pos (Unaligned) - Address'(1)));
-- First address of argument X to start serial processing
@ -102,7 +102,7 @@ package body System.Generic_Vector_Operations is
function VP is new Unchecked_Conversion (Address, Vector_Ptr);
function EP is new Unchecked_Conversion (Address, Element_Ptr);
SA : Address := XA + ((Length + 0) / VU * VU
SA : constant Address := XA + ((Length + 0) / VU * VU
and (Boolean'Pos (Unaligned) - Address'(1)));
-- First address of argument X to start serial processing

4
gcc/ada/s-interr.adb

@ -598,7 +598,7 @@ package body System.Interrupts is
Ptr := Registered_Handler_Head;
while (Ptr /= null) loop
while Ptr /= null loop
if Ptr.H = Fat.Handler_Addr then
return True;
end if;
@ -946,7 +946,7 @@ package body System.Interrupts is
Server_ID (Interrupt) := To_System (Access_Hold.all'Identity);
end if;
if (New_Handler = null) then
if New_Handler = null then
if Old_Handler /= null then
Unbind_Handler (Interrupt);
end if;

4
gcc/ada/s-taskin.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -122,7 +122,7 @@ package body System.Tasking is
All_Tasks_List := T;
end Initialize_ATCB;
Main_Task_Image : String := "main_task";
Main_Task_Image : constant String := "main_task";
-- Image of environment task.
Main_Priority : Integer;

3
gcc/ada/s-tassta.adb

@ -1089,7 +1089,8 @@ package body System.Tasking.Stages is
(Ada, Tailored_Exception_Information,
"__gnat_tailored_exception_information");
Excep : Exception_Occurrence_Access := SSL.Get_Current_Excep.all;
Excep : constant Exception_Occurrence_Access :=
SSL.Get_Current_Excep.all;
begin
-- This procedure is called by the task outermost handler in

3
gcc/ada/sem_attr.adb

@ -1364,7 +1364,8 @@ package body Sem_Attr is
Error_Attr ("prefix of % attribute must be generic type", N);
elsif Is_Generic_Actual_Type (Entity (P))
or In_Instance
or else In_Instance
or else In_Inlined_Body
then
null;

6
gcc/ada/sem_prag.adb

@ -9631,6 +9631,12 @@ package body Sem_Prag is
E_Id := Expression (Arg2);
Analyze (E_Id);
if In_Instance_Body
and then Nkind (E_Id) = N_Unchecked_Type_Conversion
then
E_Id := Expression (E_Id);
end if;
if not Is_Entity_Name (E_Id) then
Error_Pragma_Arg
("second argument of pragma% must be entity name",

8
gcc/ada/sem_warn.adb

@ -1440,14 +1440,16 @@ package body Sem_Warn is
when E_Variable =>
-- Case of variable that is assigned but not read. We
-- suppress the message if the variable is volatile or
-- has an address clause.
-- suppress the message if the variable is volatile,
-- has an address clause, or is imported.
if Referenced_As_LHS (E)
and then No (Address_Clause (E))
and then not Is_Volatile (E)
then
if Warn_On_Modified_Unread then
if Warn_On_Modified_Unread
and then not Is_Imported (E)
then
Error_Msg_N
("variable & is assigned but never read?", E);
end if;

285
gcc/ada/tb-alvms.c

@ -40,33 +40,38 @@
document, sections of which we will refer to as ABI-<section_number>. */
#include <pdscdef.h>
#include <libicb.h>
#include <chfctxdef.h>
#include <chfdef.h>
/* We still use a number of macros similar to the ones for the generic
__gnat_backtrace implementation. */
#define SKIP_FRAME 1
#define PC_ADJUST -4
#define STOP_FRAME (frame_state.saved_ra == RA_STOP)
/* Mask for PDSC$V_BASE_FRAME in procedure descriptors, missing from the
header file included above. */
/* A couple of items missing from the header file included above. */
extern void * SYS$GL_CALL_HANDL;
#define PDSC$M_BASE_FRAME (1 << 10)
typedef unsigned long REG;
/* Registers are 64bit wide and addresses are 32bit wide on alpha-vms. */
typedef void * ADDR;
typedef unsigned long long REG;
#define REG_AT(address) (*(REG *)(address))
#define REG_AT(addr) (*(REG *)(addr))
#define AS_REG(addr) ((REG)(unsigned long)(addr))
#define AS_ADDR(reg) ((ADDR)(unsigned long)(reg))
#define ADDR_IN(reg) (AS_ADDR(reg))
/* The following structure defines the state maintained during the
unwinding process. */
typedef struct
{
void * pc; /* Address of the call insn involved in the chain. */
void * sp; /* Stack Pointer at the time of this call. */
void * fp; /* Frame Pointer at the time of this call. */
ADDR pc; /* Address of the call insn involved in the chain. */
ADDR sp; /* Stack Pointer at the time of this call. */
ADDR fp; /* Frame Pointer at the time of this call. */
/* The values above are fetched as saved REGisters on the stack. They are
typed ADDR because this is what the values in those registers are. */
/* Values of the registers saved by the functions in the chain,
incrementally updated through consecutive calls to the "unwind"
function below. */
incrementally updated through consecutive calls to the "unwind" function
below. */
REG saved_regs [32];
} frame_state_t;
@ -79,69 +84,111 @@ typedef struct
This is from ABI-3.1.1 [Integer Registers]. */
#define saved_fp saved_regs[29]
#define saved_sp saved_regs[30]
#define saved_ra saved_regs[26]
#define saved_pv saved_regs[27]
#define saved_fpr saved_regs[29]
#define saved_spr saved_regs[30]
#define saved_rar saved_regs[26]
#define saved_pvr saved_regs[27]
/* Special values for saved_ra, used to control the overall unwinding
/* Special values for saved_rar, used to control the overall unwinding
process. */
#define RA_UNKNOWN ((REG)~0)
#define RA_STOP ((REG)0)
/* Compute Procedure Value from a live Frame Pointer value. */
/* We still use a number of macros similar to the ones for the generic
__gnat_backtrace implementation. */
#define PC_ADJUST 4
#define STOP_FRAME (frame_state.saved_rar == RA_STOP)
/* Compute Procedure Value from Frame Pointer value. This follows the rules
in ABI-3.6.1 [Current Procedure]. */
#define PV_FOR(FP) \
((REG_AT (FP) & 0x7) == 0) ? *(PDSCDEF **)(FP) : (PDSCDEF *)(FP);
(((FP) != 0) \
? (((REG_AT (FP) & 0x7) == 0) ? *(PDSCDEF **)(FP) : (PDSCDEF *)(FP)) : 0)
/**********
* unwind *
**********/
/* Helper for __gnat_backtrace. Update FS->pc/sp/fp to represent the
state computed in FS->saved_regs during the previous call, and update
FS->saved_regs in preparation of the next call. */
/* Helper for __gnat_backtrace.
FS represents some call frame, identified by a pc and associated frame
pointer in FS->pc and FS->fp. FS->saved_regs contains the state of the
general registers upon entry in this frame. Of most interest in this set
are the saved return address and frame pointer registers, which actually
allow identifying the caller's frame.
This routine "unwinds" the input frame state by adjusting it to eventually
represent its caller's frame. The basic principle is to shift the fp and pc
saved values into the current state, and then compute the corresponding new
saved registers set.
If the call chain goes through a signal handler, special processing is
required when we process the kernel frame which has called the handler, to
switch it to the interrupted context frame. */
#define K_HANDLER_FRAME(fs) (PV_FOR ((fs)->fp) == SYS$GL_CALL_HANDL)
static void unwind_regular_code (frame_state_t * fs);
static void unwind_kernel_handler (frame_state_t * fs);
void
unwind (frame_state_t * fs)
{
REG frame_base;
PDSCDEF * pv;
/* Don't do anything if requested so. */
if (fs->saved_ra == RA_STOP)
if (fs->saved_rar == RA_STOP)
return;
/* Retrieve the values of interest computed during the previous
call. PC_ADJUST gets us from the return address to the call insn
address. */
fs->pc = (void *) fs->saved_ra + PC_ADJUST;
fs->sp = (void *) fs->saved_sp;
fs->fp = (void *) fs->saved_fp;
fs->pc = ADDR_IN (fs->saved_rar) - PC_ADJUST;
fs->sp = ADDR_IN (fs->saved_spr);
fs->fp = ADDR_IN (fs->saved_fpr);
/* Unless we are able to determine otherwise, set the frame state's
saved return address such that the unwinding process will stop. */
fs->saved_ra = RA_STOP;
fs->saved_rar = RA_STOP;
/* Now we want to update fs->saved_regs to reflect what the procedure
described by pc/fp/sp has done. */
/* Now we want to update fs->saved_regs to reflect the state of the caller
of the procedure described by pc/fp.
/* Compute the corresponding "procedure value", following the rules in
ABI-3.6.1 [Current Procedure]. Return immediatly if this value mandates
us to stop. */
if (fs->fp == 0)
return;
The condition to check for a special kernel frame which has called a
signal handler is stated in ABI-6.7.1 [Signaler's Registers] : "The frame
of the call to the handler can be identified by the return address of
SYS$CALL_HANDL+4". We use the equivalent procedure value identification
here because SYS$CALL_HANDL appears to be undefined. */
pv = PV_FOR (fs->fp);
if (K_HANDLER_FRAME (fs))
unwind_kernel_handler (fs);
else
unwind_regular_code (fs);
}
/***********************
* unwind_regular_code *
***********************/
/* Helper for unwind, for the case of unwinding through regular code which
is not a signal handler. */
static void
unwind_regular_code (frame_state_t * fs)
{
PDSCDEF * pv = PV_FOR (fs->fp);
ADDR frame_base;
/* Use the procedure value to unwind, in a way depending on the kind of
procedure at hand. See ABI-3.3 [Procedure Representation] and ABI-3.4
[Procedure Types]. */
if (pv == 0
|| pv->pdsc$w_flags & PDSC$M_BASE_FRAME)
return;
/* Use the procedure value to unwind, in a way depending on the kind of
procedure at hand. This is based on ABI-3.3 [Procedure Representation]
and ABI-3.4 [Procedure Types]. */
frame_base
= (REG) ((pv->pdsc$w_flags & PDSC$M_BASE_REG_IS_FP) ? fs->fp : fs->sp);
= (pv->pdsc$w_flags & PDSC$M_BASE_REG_IS_FP) ? fs->fp : fs->sp;
switch (pv->pdsc$w_flags & 0xf)
{
@ -149,21 +196,21 @@ unwind (frame_state_t * fs)
/* Stack Frame Procedure (ABI-3.4.1). Retrieve the necessary registers
from the Register Save Area in the frame. */
{
REG rsa_base = frame_base + pv->pdsc$w_rsa_offset;
ADDR rsa_base = frame_base + pv->pdsc$w_rsa_offset;
int i, j;
fs->saved_ra = REG_AT (rsa_base);
fs->saved_pv = REG_AT (frame_base);
fs->saved_rar = REG_AT (rsa_base);
fs->saved_pvr = REG_AT (frame_base);
for (i = 0, j = 0; i < 32; i++)
if (pv->pdsc$l_ireg_mask & (1 << i))
fs->saved_regs[i] = REG_AT (rsa_base + 8 * ++j);
/* Note that the loop above is guaranteed to set fs->saved_fp, because
"The preserved register set must always include R29(FP) since it
will always be used." (ABI-3.4.3.4 [Register Save Area for All
Stack Frames]).
/* Note that the loop above is guaranteed to set fs->saved_fpr,
because "The preserved register set must always include R29(FP)
since it will always be used." (ABI-3.4.3.4 [Register Save Area for
All Stack Frames]).
Also note that we need to run through all the registers to ensure
that unwinding through register procedures (see below) gets the
right values out of the saved_regs array. */
@ -174,8 +221,8 @@ unwind (frame_state_t * fs)
/* Register Procedure (ABI-3.4.4). Retrieve the necessary registers from
the registers where they have been saved. */
{
fs->saved_ra = fs->saved_regs[pv->pdsc$b_save_ra];
fs->saved_fp = fs->saved_regs[pv->pdsc$b_save_fp];
fs->saved_rar = fs->saved_regs[pv->pdsc$b_save_ra];
fs->saved_fpr = fs->saved_regs[pv->pdsc$b_save_fp];
}
break;
@ -187,19 +234,111 @@ unwind (frame_state_t * fs)
/* SP is actually never part of the saved registers area, so we use the
corresponding entry in the saved_regs array to manually keep track of
it's evolution. */
fs->saved_sp = frame_base + pv->pdsc$l_size;
fs->saved_spr = AS_REG (frame_base) + pv->pdsc$l_size;
}
/*************************
* unwind_kernel_handler *
*************************/
/* Helper for unwind, for the specific case of unwinding through a signal
handler.
The input frame state describes the kernel frame which has called a signal
handler. We fill the corresponding saved_regs to have it's "caller" frame
represented as the interrupted context. */
static void
unwind_kernel_handler (frame_state_t * fs)
{
PDSCDEF * pv = PV_FOR (fs->fp);
CHFDEF1 *sigargs;
CHFDEF2 *mechargs;
/* Retrieve the arguments passed to the handler, by way of a VMS service
providing the corresponding "Invocation Context Block". */
{
long handler_ivhandle;
INVO_CONTEXT_BLK handler_ivcb;
CHFCTX *chfctx;
handler_ivcb.libicb$q_ireg [29] = AS_REG (fs->fp);
handler_ivcb.libicb$q_ireg [30] = 0;
handler_ivhandle = LIB$GET_INVO_HANDLE (&handler_ivcb);
if ((LIB$GET_INVO_CONTEXT (handler_ivhandle, &handler_ivcb) & 1) != 1)
return;
chfctx = (CHFCTX *) AS_ADDR (handler_ivcb.libicb$ph_chfctx_addr);
sigargs = (CHFDEF1 *) AS_ADDR (chfctx->chfctx$q_sigarglst);
mechargs = (CHFDEF2 *) AS_ADDR (chfctx->chfctx$q_mcharglst);
}
/* Compute the saved return address as the PC of the instruction causing the
condition, accounting for the fact that it will be adjusted by the next
call to "unwind" as if it was an actual call return address. */
{
/* ABI-6.5.1.1 [Signal Argument Vector]: The signal occurrence address
is available from the sigargs argument to the handler, designed to
support both 32 and 64 bit addresses. The initial reference we get
is a pointer to the 32bit form, from which one may extract a pointer
to the 64bit version if need be. We work directly from the 32bit
form here. */
/* The sigargs vector structure for 32bits addresses is:
<......32bit......>
+-----------------+
| Vsize | :chf$is_sig_args
+-----------------+ -+-
| Condition Value | : [0]
+-----------------+ :
| ... | :
+-----------------+ : vector of Vsize entries
| Signal PC | :
+-----------------+ :
| PS | : [Vsize - 1]
+-----------------+ -+-
*/
unsigned long * sigargs_vector
= ((unsigned long *) (&sigargs->chf$is_sig_args)) + 1;
long sigargs_vsize
= sigargs->chf$is_sig_args;
fs->saved_rar = (REG) sigargs_vector [sigargs_vsize - 2] + PC_ADJUST;
}
fs->saved_spr = RA_UNKNOWN;
fs->saved_fpr = (REG) mechargs->chf$q_mch_frame;
fs->saved_pvr = (REG) mechargs->chf$q_mch_savr27;
fs->saved_regs[16] = (REG) mechargs->chf$q_mch_savr16;
fs->saved_regs[17] = (REG) mechargs->chf$q_mch_savr17;
fs->saved_regs[18] = (REG) mechargs->chf$q_mch_savr18;
fs->saved_regs[19] = (REG) mechargs->chf$q_mch_savr19;
fs->saved_regs[20] = (REG) mechargs->chf$q_mch_savr20;
}
/* Structure representing a traceback entry in the tracebacks array to be
filled by __gnat_backtrace below.
!! This should match what is in System.Traceback_Entries, so beware of
!! the REG/ADDR difference here.
The use of a structure is motivated by the potential necessity of having
several fields to fill for each entry, for instance if later calls to VMS
system functions need more than just a mere PC to compute info on a frame
(e.g. for non-symbolic->symbolic translation purposes). */
typedef struct {
void * pc;
void * pv;
ADDR pc;
ADDR pv;
} tb_entry_t;
/********************
@ -207,11 +346,8 @@ typedef struct {
********************/
int
__gnat_backtrace (void **array,
int size,
void *exclude_min,
void *exclude_max,
int skip_frames)
__gnat_backtrace (void **array, int size,
void *exclude_min, void *exclude_max, int skip_frames)
{
int cnt;
@ -223,9 +359,9 @@ __gnat_backtrace (void **array,
register REG this_FP __asm__("$29");
register REG this_SP __asm__("$30");
frame_state.saved_fp = this_FP;
frame_state.saved_sp = this_SP;
frame_state.saved_ra = RA_UNKNOWN;
frame_state.saved_fpr = this_FP;
frame_state.saved_spr = this_SP;
frame_state.saved_rar = RA_UNKNOWN;
unwind (&frame_state);
@ -239,15 +375,18 @@ __gnat_backtrace (void **array,
cnt = 0;
while (cnt < size)
{
PDSCDEF * pv = PV_FOR (frame_state.fp);
/* Stop if either the frame contents or the unwinder say so. */
if (STOP_FRAME)
break;
if (frame_state.pc < exclude_min
|| frame_state.pc > exclude_max)
if (! K_HANDLER_FRAME (&frame_state)
&& (frame_state.pc < exclude_min || frame_state.pc > exclude_max))
{
tbe->pc = frame_state.pc;
tbe->pv = PV_FOR (frame_state.fp);
tbe->pc = (ADDR) frame_state.pc;
tbe->pv = (ADDR) PV_FOR (frame_state.fp);
cnt ++;
tbe ++;
}