Skip to content

R
riscv-gcc-1
Commit efdfd311 by Arnaud Charlet
Options

[multiple changes] 

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
parent 1fcc57f1
Showing with 442 additions and 590 deletions
gcc/ada/5lintman.adb deleted 100644 → 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;
gcc/ada/ChangeLog
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> 2003-12-01 Nicolas Setton <setton@act-europe.fr>
* a-except.adb (Raise_Current_Excep): Add a pragma Inspection_Point, * a-except.adb (Raise_Current_Excep): Add a pragma Inspection_Point,
......
gcc/ada/Makefile.in
...@@ -375,6 +375,8 @@ PREFIX_REAL_OBJS = ../prefix.o \ ...@@ -375,6 +375,8 @@ PREFIX_REAL_OBJS = ../prefix.o \
../../libiberty/xstrdup.o \ ../../libiberty/xstrdup.o \
../../libiberty/xexit.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. # $(filter-out PATTERN...,TEXT) removes all PATTERN words from TEXT.
# $(strip STRING) removes leading and trailing spaces from STRING. # $(strip STRING) removes leading and trailing spaces from STRING.
# If what's left is null then it's a match. # If what's left is null then it's a match.
...@@ -450,7 +452,7 @@ ifeq ($(strip $(filter-out %86 sysv5uw%,$(arch) $(osys))),) ...@@ -450,7 +452,7 @@ ifeq ($(strip $(filter-out %86 sysv5uw%,$(arch) $(osys))),)
PREFIX_OBJS=$(PREFIX_REAL_OBJS) PREFIX_OBJS=$(PREFIX_REAL_OBJS)
SO_OPTS = -Wl,-h, SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual 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 endif
ifeq ($(strip $(filter-out alpha% dec vx%,$(targ))),) ifeq ($(strip $(filter-out alpha% dec vx%,$(targ))),)
...@@ -692,8 +694,7 @@ ifeq ($(strip $(filter-out powerpc% unknown elf,$(targ))),) ...@@ -692,8 +694,7 @@ ifeq ($(strip $(filter-out powerpc% unknown elf,$(targ))),)
system.ads<59system.ads system.ads<59system.ads
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
$(HIE_NONE_TARGET_PAIRS) \ $(HIE_NONE_TARGET_PAIRS)
$(EXTRA_HIE_NONE_TARGET_PAIRS)
endif endif
ifeq ($(strip $(filter-out sparc% unknown elf,$(targ))),) ifeq ($(strip $(filter-out sparc% unknown elf,$(targ))),)
...@@ -701,8 +702,7 @@ ifeq ($(strip $(filter-out sparc% unknown elf,$(targ))),) ...@@ -701,8 +702,7 @@ ifeq ($(strip $(filter-out sparc% unknown elf,$(targ))),)
system.ads<5rsystem.ads system.ads<5rsystem.ads
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
$(HIE_NONE_TARGET_PAIRS) \ $(HIE_NONE_TARGET_PAIRS)
$(EXTRA_HIE_NONE_TARGET_PAIRS)
endif endif
ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),) ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),)
...@@ -819,7 +819,7 @@ ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),) ...@@ -819,7 +819,7 @@ ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),)
GNATLIB_SHARED = gnatlib-shared-dual GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS) 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))),) ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
...@@ -903,7 +903,7 @@ ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),) ...@@ -903,7 +903,7 @@ ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),)
SO_OPTS = -Wl,-h, SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual GNATLIB_SHARED = gnatlib-shared-dual
PREFIX_OBJS = $(PREFIX_REAL_OBJS) 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 endif
ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
...@@ -912,7 +912,7 @@ 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.adb<86numaux.adb \
a-numaux.ads<86numaux.ads \ a-numaux.ads<86numaux.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<7sinmaop.adb \
s-intman.adb<5lintman.adb \ s-intman.adb<7sintman.adb \
s-mastop.adb<5omastop.adb \ s-mastop.adb<5omastop.adb \
s-osinte.adb<5iosinte.adb \ s-osinte.adb<5iosinte.adb \
s-osinte.ads<5iosinte.ads \ s-osinte.ads<5iosinte.ads \
...@@ -929,7 +929,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) ...@@ -929,7 +929,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
GNATLIB_SHARED = gnatlib-shared-dual GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS) 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))),) ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
...@@ -937,7 +937,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) ...@@ -937,7 +937,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
a-numaux.adb<86numaux.adb \ a-numaux.adb<86numaux.adb \
a-numaux.ads<86numaux.ads \ a-numaux.ads<86numaux.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<7sinmaop.adb \
s-intman.adb<5lintman.adb \ s-intman.adb<7sintman.adb \
s-mastop.adb<5omastop.adb \ s-mastop.adb<5omastop.adb \
s-osinte.adb<7sosinte.adb \ s-osinte.adb<7sosinte.adb \
s-osinte.ads<5losinte.ads \ s-osinte.ads<5losinte.ads \
...@@ -967,7 +967,7 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),) ...@@ -967,7 +967,7 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
system.ads<56system.ads system.ads<56system.ads
THREADSLIB= THREADSLIB=
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/')) LIBRARY_VERSION := $(LIB_VERSION)
endif endif
ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),) ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
...@@ -1021,7 +1021,7 @@ ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),) ...@@ -1021,7 +1021,7 @@ ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
MISCLIB = -lexc MISCLIB = -lexc
SO_OPTS = -Wl,-all,-set_version,sgi1.0,-update_registry,../so_locations,-soname, SO_OPTS = -Wl,-all,-set_version,sgi1.0,-update_registry,../so_locations,-soname,
PREFIX_OBJS = $(PREFIX_REAL_OBJS) 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 endif
ifeq ($(strip $(filter-out hppa% hp hpux10%,$(targ))),) ifeq ($(strip $(filter-out hppa% hp hpux10%,$(targ))),)
...@@ -1069,7 +1069,7 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),) ...@@ -1069,7 +1069,7 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),)
SO_OPTS = -Wl,+h, SO_OPTS = -Wl,+h,
PREFIX_OBJS = $(PREFIX_REAL_OBJS) PREFIX_OBJS = $(PREFIX_REAL_OBJS)
GNATLIB_SHARED = gnatlib-shared-dual 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))),) ifeq ($(strip $(filter-out dce DCE,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
...@@ -1220,7 +1220,7 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),) ...@@ -1220,7 +1220,7 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),)
THREADSLIB = -lpthread -lmach -lexc -lrt THREADSLIB = -lpthread -lmach -lexc -lrt
PREFIX_OBJS = $(PREFIX_REAL_OBJS) PREFIX_OBJS = $(PREFIX_REAL_OBJS)
GNATLIB_SHARED = gnatlib-shared-default 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 endif
ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(host))),) ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(host))),)
...@@ -1290,8 +1290,7 @@ endif ...@@ -1290,8 +1290,7 @@ endif
../../gnatlbr$(exeext) \ ../../gnatlbr$(exeext) \
,,/../gnatsym$(exeext) ,,/../gnatsym$(exeext)
# This command transforms (YYYYMMDD) into YY,MMDD # 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/') GSMATCH_VERSION := $(shell grep "^ *Gnat_Static_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'))
TOOLS_LIBS_LO := --for-linker=sys\\$$\$$library:trace.exe TOOLS_LIBS_LO := --for-linker=sys\\$$\$$library:trace.exe
endif endif
...@@ -1328,14 +1327,14 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) ...@@ -1328,14 +1327,14 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
EXTRA_GNATRTL_NONTASKING_OBJS = g-regist.o EXTRA_GNATRTL_NONTASKING_OBJS = g-regist.o
soext = .dll soext = .dll
GNATLIB_SHARED = gnatlib-shared-win32 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 endif
ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),) ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \ a-intnam.ads<4lintnam.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<7sinmaop.adb \
s-intman.adb<5lintman.adb \ s-intman.adb<7sintman.adb \
s-osinte.ads<5iosinte.ads \ s-osinte.ads<5iosinte.ads \
s-osinte.adb<5iosinte.adb \ s-osinte.adb<5iosinte.adb \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<7sosprim.adb \
...@@ -1349,14 +1348,14 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),) ...@@ -1349,14 +1348,14 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
THREADSLIB=-lpthread THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual GNATLIB_SHARED=gnatlib-shared-dual
PREFIX_OBJS=$(PREFIX_REAL_OBJS) 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 endif
ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),) ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \ a-intnam.ads<4lintnam.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<7sinmaop.adb \
s-intman.adb<5lintman.adb \ s-intman.adb<7sintman.adb \
s-osinte.ads<5iosinte.ads \ s-osinte.ads<5iosinte.ads \
s-osinte.adb<5iosinte.adb \ s-osinte.adb<5iosinte.adb \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<7sosprim.adb \
...@@ -1370,7 +1369,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),) ...@@ -1370,7 +1369,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),)
THREADSLIB=-lpthread THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual GNATLIB_SHARED=gnatlib-shared-dual
PREFIX_OBJS=$(PREFIX_REAL_OBJS) 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 endif
# The runtime library for gnat comprises two directories. One contains the # The runtime library for gnat comprises two directories. One contains the
......
gcc/ada/adaint.c
...@@ -2481,3 +2481,9 @@ __gnatlib_install_locks (void (*lock) (void) ATTRIBUTE_UNUSED, ...@@ -2481,3 +2481,9 @@ __gnatlib_install_locks (void (*lock) (void) ATTRIBUTE_UNUSED,
a no-op in this case. */ a no-op in this case. */
#endif #endif
} }
int
__gnat_lseek (int fd, long offset, int whence)
{
return (int) lseek (fd, offset, whence);
}
gcc/ada/adaint.h
...@@ -140,6 +140,7 @@ extern int __gnat_expect_poll (int *, int, int, int *); ...@@ -140,6 +140,7 @@ extern int __gnat_expect_poll (int *, int, int, int *);
extern void __gnat_set_binary_mode (int); extern void __gnat_set_binary_mode (int);
extern void __gnat_set_text_mode (int); extern void __gnat_set_text_mode (int);
extern char *__gnat_ttyname (int); extern char *__gnat_ttyname (int);
extern int __gnat_lseek (int, long, int);
#ifdef __MINGW32__ #ifdef __MINGW32__
extern void __gnat_plist_init (void); extern void __gnat_plist_init (void);
......
gcc/ada/back_end.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -270,6 +270,12 @@ package body Back_End is ...@@ -270,6 +270,12 @@ package body Back_End is
Opt.No_Stdinc := True; Opt.No_Stdinc := True;
Scan_Back_End_Switches (Argv); 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 elsif Is_Front_End_Switch (Argv) then
Scan_Front_End_Switches (Argv); Scan_Front_End_Switches (Argv);
......
gcc/ada/exp_attr.adb
...@@ -907,8 +907,9 @@ package body Exp_Attr is ...@@ -907,8 +907,9 @@ package body Exp_Attr is
if Pent = Standard_Standard if Pent = Standard_Standard
or else Pent = Standard_ASCII or else Pent = Standard_ASCII
then then
Name_Buffer (1 .. Library_Version'Length) := Library_Version; Name_Buffer (1 .. Verbose_Library_Version'Length) :=
Name_Len := Library_Version'Length; Verbose_Library_Version;
Name_Len := Verbose_Library_Version'Length;
Rewrite (N, Rewrite (N,
Make_String_Literal (Loc, Make_String_Literal (Loc,
Strval => String_From_Name_Buffer)); Strval => String_From_Name_Buffer));
......
gcc/ada/exp_ch5.adb
...@@ -95,24 +95,6 @@ package body Exp_Ch5 is ...@@ -95,24 +95,6 @@ package body Exp_Ch5 is
-- either because the target is not byte aligned, or there is a change -- either because the target is not byte aligned, or there is a change
-- of representation. -- 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; function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
-- Generate the necessary code for controlled and Tagged assignment, -- Generate the necessary code for controlled and Tagged assignment,
-- that is to say, finalization of the target before, adjustement of -- that is to say, finalization of the target before, adjustement of
...@@ -120,13 +102,41 @@ package body Exp_Ch5 is ...@@ -120,13 +102,41 @@ package body Exp_Ch5 is
-- pointers which are not 'part of the value' and must not be changed -- pointers which are not 'part of the value' and must not be changed
-- upon assignment. N is the original Assignment node. -- 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 -- -- Change_Of_Representation --
------------------------------ ------------------------------
function Change_Of_Representation (N : Node_Id) return Boolean is function Change_Of_Representation (N : Node_Id) return Boolean is
Rhs : constant Node_Id := Expression (N); Rhs : constant Node_Id := Expression (N);
begin begin
return return
Nkind (Rhs) = N_Type_Conversion Nkind (Rhs) = N_Type_Conversion
...@@ -372,9 +382,9 @@ package body Exp_Ch5 is ...@@ -372,9 +382,9 @@ package body Exp_Ch5 is
-- We require a loop if the left side is possibly bit unaligned -- 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 or else
Maybe_Bit_Aligned_Large_Component (Rhs) Possible_Bit_Aligned_Component (Rhs)
then then
Loop_Required := True; Loop_Required := True;
...@@ -1026,9 +1036,9 @@ package body Exp_Ch5 is ...@@ -1026,9 +1036,9 @@ package body Exp_Ch5 is
-- clobbering of other components sharing bits in the first or -- clobbering of other components sharing bits in the first or
-- last byte of the component to be assigned. -- last byte of the component to be assigned.
elsif Maybe_Bit_Aligned_Large_Component (Lhs) elsif Possible_Bit_Aligned_Component (Lhs)
or or
Maybe_Bit_Aligned_Large_Component (Rhs) Possible_Bit_Aligned_Component (Rhs)
then then
null; null;
...@@ -3221,11 +3231,11 @@ package body Exp_Ch5 is ...@@ -3221,11 +3231,11 @@ package body Exp_Ch5 is
return Empty_List; return Empty_List;
end Make_Tag_Ctrl_Assignment; 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 begin
case Nkind (N) is case Nkind (N) is
...@@ -3250,7 +3260,7 @@ package body Exp_Ch5 is ...@@ -3250,7 +3260,7 @@ package body Exp_Ch5 is
-- indexing from a possibly unaligned component. -- indexing from a possibly unaligned component.
else else
return Maybe_Bit_Aligned_Large_Component (P); return Possible_Bit_Aligned_Component (P);
end if; end if;
end; end;
...@@ -3268,17 +3278,22 @@ package body Exp_Ch5 is ...@@ -3268,17 +3278,22 @@ package body Exp_Ch5 is
-- only the recursive test on the prefix. -- only the recursive test on the prefix.
if No (Component_Clause (Comp)) then 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 -- Otherwise we have a component clause, which means that
-- the Esize and Normalized_First_Bit fields are set and -- the Esize and Normalized_First_Bit fields are set and
-- contain static values known at compile time. -- contain static values known at compile time.
else else
-- If we know the size is 64 bits or less we are fine -- If we know that we have a small (64 bits or less) record
-- since the back end always handles small fields right. -- 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; return False;
-- Otherwise if the component is not byte aligned, we -- Otherwise if the component is not byte aligned, we
...@@ -3293,7 +3308,7 @@ package body Exp_Ch5 is ...@@ -3293,7 +3308,7 @@ package body Exp_Ch5 is
-- but we still need to test our prefix recursively. -- but we still need to test our prefix recursively.
else else
return Maybe_Bit_Aligned_Large_Component (P); return Possible_Bit_Aligned_Component (P);
end if; end if;
end if; end if;
end; end;
...@@ -3306,6 +3321,6 @@ package body Exp_Ch5 is ...@@ -3306,6 +3321,6 @@ package body Exp_Ch5 is
return False; return False;
end case; end case;
end Maybe_Bit_Aligned_Large_Component; end Possible_Bit_Aligned_Component;
end Exp_Ch5; end Exp_Ch5;
gcc/ada/g-awk.adb
...@@ -873,8 +873,7 @@ package body GNAT.AWK is ...@@ -873,8 +873,7 @@ package body GNAT.AWK is
Callbacks : Callback_Mode := None; Callbacks : Callback_Mode := None;
Session : Session_Type := Current_Session) Session : Session_Type := Current_Session)
is is
Filter_Active : Boolean; Quit : Boolean;
Quit : Boolean;
begin begin
Open (Separators, Filename, Session); Open (Separators, Filename, Session);
...@@ -884,7 +883,12 @@ package body GNAT.AWK is ...@@ -884,7 +883,12 @@ package body GNAT.AWK is
Split_Line (Session); Split_Line (Session);
if Callbacks in Only .. Pass_Through then 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; end if;
if Callbacks /= Only then if Callbacks /= Only then
......
gcc/ada/g-debpoo.adb
...@@ -116,7 +116,7 @@ package body GNAT.Debug_Pools is ...@@ -116,7 +116,7 @@ package body GNAT.Debug_Pools is
return Tracebacks_Array_Access; return Tracebacks_Array_Access;
function Hash (T : Tracebacks_Array_Access) return Header; function Hash (T : Tracebacks_Array_Access) return Header;
function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean; 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. -- Subprograms required for instantiation of the htable. See GNAT.HTable.
package Backtrace_Htable is new GNAT.HTable.Static_HTable package Backtrace_Htable is new GNAT.HTable.Static_HTable
...@@ -374,7 +374,6 @@ package body GNAT.Debug_Pools is ...@@ -374,7 +374,6 @@ package body GNAT.Debug_Pools is
function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is
use Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
begin begin
return K1.all = K2.all; return K1.all = K2.all;
end Equal; end Equal;
......
gcc/ada/g-memdum.adb
...@@ -66,7 +66,7 @@ package body GNAT.Memory_Dump is ...@@ -66,7 +66,7 @@ package body GNAT.Memory_Dump is
Line_Buf : String (1 .. Line_Len); 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; type Char_Ptr is access all Character;
......
gcc/ada/g-os_lib.ads
...@@ -359,7 +359,7 @@ pragma Elaborate_Body (OS_Lib); ...@@ -359,7 +359,7 @@ pragma Elaborate_Body (OS_Lib);
(FD : File_Descriptor; (FD : File_Descriptor;
offset : Long_Integer; offset : Long_Integer;
origin : Integer); origin : Integer);
pragma Import (C, Lseek, "lseek"); pragma Import (C, Lseek, "__gnat_lseek");
-- Sets the current file pointer to the indicated offset value, -- Sets the current file pointer to the indicated offset value,
-- relative to the current position (origin = SEEK_CUR), end of -- relative to the current position (origin = SEEK_CUR), end of
-- file (origin = SEEK_END), or start of file (origin = SEEK_SET). -- file (origin = SEEK_END), or start of file (origin = SEEK_SET).
......
gcc/ada/g-spipat.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -343,30 +343,28 @@ package body GNAT.Spitbol.Patterns is ...@@ -343,30 +343,28 @@ package body GNAT.Spitbol.Patterns is
-- structure (i.e. it is a pattern that is guaranteed to match at least -- 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. -- one character on success, and not to make any entries on the stack.
OK_For_Simple_Arbno : OK_For_Simple_Arbno : constant array (Pattern_Code) of Boolean :=
array (Pattern_Code) of Boolean := ( (PC_Any_CS |
PC_Any_CS | PC_Any_CH |
PC_Any_CH | PC_Any_VF |
PC_Any_VF | PC_Any_VP |
PC_Any_VP | PC_Char |
PC_Char | PC_Len_Nat |
PC_Len_Nat | PC_NotAny_CS |
PC_NotAny_CS | PC_NotAny_CH |
PC_NotAny_CH | PC_NotAny_VF |
PC_NotAny_VF | PC_NotAny_VP |
PC_NotAny_VP | PC_Span_CS |
PC_Span_CS | PC_Span_CH |
PC_Span_CH | PC_Span_VF |
PC_Span_VF | PC_Span_VP |
PC_Span_VP | PC_String |
PC_String | PC_String_2 |
PC_String_2 | PC_String_3 |
PC_String_3 | PC_String_4 |
PC_String_4 | PC_String_5 |
PC_String_5 | PC_String_6 => True,
PC_String_6 => True, others => False);
others => False);
------------------------------- -------------------------------
-- The Pattern History Stack -- -- The Pattern History Stack --
......
gcc/ada/g-thread.adb
...@@ -81,8 +81,7 @@ package body GNAT.Threads is ...@@ -81,8 +81,7 @@ package body GNAT.Threads is
(Code : Address; (Code : Address;
Parm : Void_Ptr; Parm : Void_Ptr;
Size : Natural; Size : Natural;
Prio : Integer) Prio : Integer) return System.Address
return System.Address
is is
TP : Tptr; TP : Tptr;
...@@ -108,7 +107,6 @@ package body GNAT.Threads is ...@@ -108,7 +107,6 @@ package body GNAT.Threads is
procedure Unregister_Thread is procedure Unregister_Thread is
Self_Id : constant Tasking.Task_ID := Task_Primitives.Operations.Self; Self_Id : constant Tasking.Task_ID := Task_Primitives.Operations.Self;
begin begin
Self_Id.Common.State := Tasking.Terminated; Self_Id.Common.State := Tasking.Terminated;
Destroy_TSD (Self_Id.Common.Compiler_Data); Destroy_TSD (Self_Id.Common.Compiler_Data);
...@@ -150,7 +148,6 @@ package body GNAT.Threads is ...@@ -150,7 +148,6 @@ package body GNAT.Threads is
procedure Destroy_Thread (Id : Address) is procedure Destroy_Thread (Id : Address) is
Tid : constant Task_Id := To_Id (Id); Tid : constant Task_Id := To_Id (Id);
begin begin
Abort_Task (Tid); Abort_Task (Tid);
end Destroy_Thread; end Destroy_Thread;
...@@ -161,9 +158,7 @@ package body GNAT.Threads is ...@@ -161,9 +158,7 @@ package body GNAT.Threads is
procedure Get_Thread (Id : Address; Thread : Address) is procedure Get_Thread (Id : Address; Thread : Address) is
use System.OS_Interface; use System.OS_Interface;
Thr : constant Thread_Id_Ptr := To_Thread (Thread);
Thr : Thread_Id_Ptr := To_Thread (Thread);
begin begin
Thr.all := Task_Primitives.Operations.Get_Thread_Id (To_Id (Id)); Thr.all := Task_Primitives.Operations.Get_Thread_Id (To_Id (Id));
end Get_Thread; end Get_Thread;
...@@ -173,8 +168,7 @@ package body GNAT.Threads is ...@@ -173,8 +168,7 @@ package body GNAT.Threads is
---------------- ----------------
function To_Task_Id function To_Task_Id
(Id : System.Address) (Id : System.Address) return Ada.Task_Identification.Task_Id
return Ada.Task_Identification.Task_Id
is is
begin begin
return To_Tid (Id); return To_Tid (Id);
......
gcc/ada/gnatlbr.adb
...@@ -254,7 +254,8 @@ begin ...@@ -254,7 +254,8 @@ begin
& F_ADC_File (1 .. F_ADC_File_Len)); & F_ADC_File (1 .. F_ADC_File_Len));
Make_Args (6) := Make_Args (6) :=
new String'("LIBRARY_VERSION=" & '"' & Library_Version & '"'); new String'("LIBRARY_VERSION=" & '"' &
Verbose_Library_Version & '"');
Make_Args (7) := Make_Args (7) :=
new String'("-f"); new String'("-f");
......
gcc/ada/gnatvsn.ads
...@@ -71,7 +71,7 @@ package Gnatvsn is ...@@ -71,7 +71,7 @@ package Gnatvsn is
-- value should never be decreased in the future, but it would be -- value should never be decreased in the future, but it would be
-- OK to increase it if absolutely necessary. -- 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 -- Library version. This value must be updated whenever any change to the
-- compiler affects the library formats in such a way as to obsolete -- compiler affects the library formats in such a way as to obsolete
-- previously compiled library modules. -- previously compiled library modules.
...@@ -79,6 +79,9 @@ package Gnatvsn is ...@@ -79,6 +79,9 @@ package Gnatvsn is
-- Note: Makefile.in relies on the precise format of the library version -- Note: Makefile.in relies on the precise format of the library version
-- string in order to correctly construct the soname value. -- 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_Number : constant := 2;
-- ASIS Version. This is used to check for consistency between the compiler -- ASIS Version. This is used to check for consistency between the compiler
-- used to generate trees, and an ASIS application that is reading the -- used to generate trees, and an ASIS application that is reading the
......
gcc/ada/lang-specs.h
...@@ -35,6 +35,7 @@ ...@@ -35,6 +35,7 @@
%{!gnatc*:%{!gnatz*:%{!gnats*:%{!S:%{!c:\ %{!gnatc*:%{!gnatz*:%{!gnats*:%{!S:%{!c:\
%eone of -c, -S, -gnatc, -gnatz, or -gnats is required for Ada}}}}}\ %eone of -c, -S, -gnatc, -gnatz, or -gnats is required for Ada}}}}}\
gnat1 %{I*} %{k8:-gnatk8} %{w:-gnatws} %1 %{!Q:-quiet} %{nostdinc*}\ gnat1 %{I*} %{k8:-gnatk8} %{w:-gnatws} %1 %{!Q:-quiet} %{nostdinc*}\
%{nostdlib*}\
-dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\ -dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\
%{g*} %{O*} %{W*} %{w} %{p} %{pg:-p} %{m*} %{a} %{f*} %{d*}\ %{g*} %{O*} %{W*} %{w} %{p} %{pg:-p} %{m*} %{a} %{f*} %{d*}\
%{!S:%{o*:%w%*-gnatO}} \ %{!S:%{o*:%w%*-gnatO}} \
......
gcc/ada/lib-writ.adb
...@@ -729,7 +729,7 @@ package body Lib.Writ is ...@@ -729,7 +729,7 @@ package body Lib.Writ is
Write_Info_Initiate ('V'); Write_Info_Initiate ('V');
Write_Info_Str (" """); Write_Info_Str (" """);
Write_Info_Str (Library_Version); Write_Info_Str (Verbose_Library_Version);
Write_Info_Char ('"'); Write_Info_Char ('"');
Write_Info_EOL; Write_Info_EOL;
......
gcc/ada/make.adb
...@@ -1356,7 +1356,7 @@ package body Make is ...@@ -1356,7 +1356,7 @@ package body Make is
return; return;
elsif ALIs.Table (ALI).Ver (1 .. ALIs.Table (ALI).Ver_Len) /= elsif ALIs.Table (ALI).Ver (1 .. ALIs.Table (ALI).Ver_Len) /=
Library_Version Verbose_Library_Version
then then
Verbose_Msg (Full_Lib_File, "compiled with old GNAT version"); Verbose_Msg (Full_Lib_File, "compiled with old GNAT version");
ALI := No_ALI_Id; ALI := No_ALI_Id;
......
gcc/ada/s-geveop.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -61,7 +61,7 @@ package body System.Generic_Vector_Operations is ...@@ -61,7 +61,7 @@ package body System.Generic_Vector_Operations is
function VP is new Unchecked_Conversion (Address, Vector_Ptr); function VP is new Unchecked_Conversion (Address, Vector_Ptr);
function EP is new Unchecked_Conversion (Address, Element_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))); and (Boolean'Pos (Unaligned) - Address'(1)));
-- First address of argument X to start serial processing -- First address of argument X to start serial processing
...@@ -102,7 +102,7 @@ package body System.Generic_Vector_Operations is ...@@ -102,7 +102,7 @@ package body System.Generic_Vector_Operations is
function VP is new Unchecked_Conversion (Address, Vector_Ptr); function VP is new Unchecked_Conversion (Address, Vector_Ptr);
function EP is new Unchecked_Conversion (Address, Element_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))); and (Boolean'Pos (Unaligned) - Address'(1)));
-- First address of argument X to start serial processing -- First address of argument X to start serial processing
......
gcc/ada/s-interr.adb
...@@ -598,7 +598,7 @@ package body System.Interrupts is ...@@ -598,7 +598,7 @@ package body System.Interrupts is
Ptr := Registered_Handler_Head; Ptr := Registered_Handler_Head;
while (Ptr /= null) loop while Ptr /= null loop
if Ptr.H = Fat.Handler_Addr then if Ptr.H = Fat.Handler_Addr then
return True; return True;
end if; end if;
...@@ -946,7 +946,7 @@ package body System.Interrupts is ...@@ -946,7 +946,7 @@ package body System.Interrupts is
Server_ID (Interrupt) := To_System (Access_Hold.all'Identity); Server_ID (Interrupt) := To_System (Access_Hold.all'Identity);
end if; end if;
if (New_Handler = null) then if New_Handler = null then
if Old_Handler /= null then if Old_Handler /= null then
Unbind_Handler (Interrupt); Unbind_Handler (Interrupt);
end if; end if;
......
gcc/ada/s-taskin.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -122,7 +122,7 @@ package body System.Tasking is ...@@ -122,7 +122,7 @@ package body System.Tasking is
All_Tasks_List := T; All_Tasks_List := T;
end Initialize_ATCB; end Initialize_ATCB;
Main_Task_Image : String := "main_task"; Main_Task_Image : constant String := "main_task";
-- Image of environment task. -- Image of environment task.
Main_Priority : Integer; Main_Priority : Integer;
......
gcc/ada/s-tassta.adb
...@@ -1089,7 +1089,8 @@ package body System.Tasking.Stages is ...@@ -1089,7 +1089,8 @@ package body System.Tasking.Stages is
(Ada, Tailored_Exception_Information, (Ada, Tailored_Exception_Information,
"__gnat_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 begin
-- This procedure is called by the task outermost handler in -- This procedure is called by the task outermost handler in
......
gcc/ada/sem_attr.adb
...@@ -1364,7 +1364,8 @@ package body Sem_Attr is ...@@ -1364,7 +1364,8 @@ package body Sem_Attr is
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)) elsif Is_Generic_Actual_Type (Entity (P))
or In_Instance or else In_Instance
or else In_Inlined_Body
then then
null; null;
......
gcc/ada/sem_prag.adb
...@@ -9631,6 +9631,12 @@ package body Sem_Prag is ...@@ -9631,6 +9631,12 @@ package body Sem_Prag is
E_Id := Expression (Arg2); E_Id := Expression (Arg2);
Analyze (E_Id); 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 if not Is_Entity_Name (E_Id) then
Error_Pragma_Arg Error_Pragma_Arg
("second argument of pragma% must be entity name", ("second argument of pragma% must be entity name",
......
gcc/ada/sem_warn.adb
...@@ -1440,14 +1440,16 @@ package body Sem_Warn is ...@@ -1440,14 +1440,16 @@ package body Sem_Warn is
when E_Variable => when E_Variable =>
-- Case of variable that is assigned but not read. We -- Case of variable that is assigned but not read. We
-- suppress the message if the variable is volatile or -- suppress the message if the variable is volatile,
-- has an address clause. -- has an address clause, or is imported.
if Referenced_As_LHS (E) if Referenced_As_LHS (E)
and then No (Address_Clause (E)) and then No (Address_Clause (E))
and then not Is_Volatile (E) and then not Is_Volatile (E)
then then
if Warn_On_Modified_Unread then if Warn_On_Modified_Unread
and then not Is_Imported (E)
then
Error_Msg_N Error_Msg_N
("variable & is assigned but never read?", E); ("variable & is assigned but never read?", E);
end if; end if;
......
gcc/ada/tb-alvms.c
...@@ -40,33 +40,38 @@ ...@@ -40,33 +40,38 @@
document, sections of which we will refer to as ABI-<section_number>. */ document, sections of which we will refer to as ABI-<section_number>. */
#include <pdscdef.h> #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 /* A couple of items missing from the header file included above. */
__gnat_backtrace implementation. */ extern void * SYS$GL_CALL_HANDL;
#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. */
#define PDSC$M_BASE_FRAME (1 << 10) #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(addr) (*(REG *)(addr))
#define REG_AT(address) (*(REG *)(address)) #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 /* The following structure defines the state maintained during the
unwinding process. */ unwinding process. */
typedef struct typedef struct
{ {
void * pc; /* Address of the call insn involved in the chain. */ ADDR pc; /* Address of the call insn involved in the chain. */
void * sp; /* Stack Pointer at the time of this call. */ ADDR sp; /* Stack Pointer at the time of this call. */
void * fp; /* Frame 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, /* Values of the registers saved by the functions in the chain,
incrementally updated through consecutive calls to the "unwind" incrementally updated through consecutive calls to the "unwind" function
function below. */ below. */
REG saved_regs [32]; REG saved_regs [32];
} frame_state_t; } frame_state_t;
...@@ -79,69 +84,111 @@ typedef struct ...@@ -79,69 +84,111 @@ typedef struct
This is from ABI-3.1.1 [Integer Registers]. */ This is from ABI-3.1.1 [Integer Registers]. */
#define saved_fp saved_regs[29] #define saved_fpr saved_regs[29]
#define saved_sp saved_regs[30] #define saved_spr saved_regs[30]
#define saved_ra saved_regs[26] #define saved_rar saved_regs[26]
#define saved_pv saved_regs[27] #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. */ process. */
#define RA_UNKNOWN ((REG)~0) #define RA_UNKNOWN ((REG)~0)
#define RA_STOP ((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) \ #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 * * unwind *
**********/ **********/
/* Helper for __gnat_backtrace. Update FS->pc/sp/fp to represent the /* Helper for __gnat_backtrace.
state computed in FS->saved_regs during the previous call, and update
FS->saved_regs in preparation of the next call. */ 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 void
unwind (frame_state_t * fs) unwind (frame_state_t * fs)
{ {
REG frame_base;
PDSCDEF * pv;
/* Don't do anything if requested so. */ /* Don't do anything if requested so. */
if (fs->saved_ra == RA_STOP) if (fs->saved_rar == RA_STOP)
return; return;
/* Retrieve the values of interest computed during the previous /* Retrieve the values of interest computed during the previous
call. PC_ADJUST gets us from the return address to the call insn call. PC_ADJUST gets us from the return address to the call insn
address. */ address. */
fs->pc = (void *) fs->saved_ra + PC_ADJUST; fs->pc = ADDR_IN (fs->saved_rar) - PC_ADJUST;
fs->sp = (void *) fs->saved_sp; fs->sp = ADDR_IN (fs->saved_spr);
fs->fp = (void *) fs->saved_fp; fs->fp = ADDR_IN (fs->saved_fpr);
/* Unless we are able to determine otherwise, set the frame state's /* Unless we are able to determine otherwise, set the frame state's
saved return address such that the unwinding process will stop. */ 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 /* Now we want to update fs->saved_regs to reflect the state of the caller
described by pc/fp/sp has done. */ of the procedure described by pc/fp.
/* Compute the corresponding "procedure value", following the rules in The condition to check for a special kernel frame which has called a
ABI-3.6.1 [Current Procedure]. Return immediatly if this value mandates signal handler is stated in ABI-6.7.1 [Signaler's Registers] : "The frame
us to stop. */ of the call to the handler can be identified by the return address of
if (fs->fp == 0) SYS$CALL_HANDL+4". We use the equivalent procedure value identification
return; here because SYS$CALL_HANDL appears to be undefined. */
if (K_HANDLER_FRAME (fs))
unwind_kernel_handler (fs);
else
unwind_regular_code (fs);
}
pv = PV_FOR (fs->fp); /***********************
* 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 if (pv == 0
|| pv->pdsc$w_flags & PDSC$M_BASE_FRAME) || pv->pdsc$w_flags & PDSC$M_BASE_FRAME)
return; 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 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) switch (pv->pdsc$w_flags & 0xf)
{ {
...@@ -149,21 +196,21 @@ unwind (frame_state_t * fs) ...@@ -149,21 +196,21 @@ unwind (frame_state_t * fs)
/* Stack Frame Procedure (ABI-3.4.1). Retrieve the necessary registers /* Stack Frame Procedure (ABI-3.4.1). Retrieve the necessary registers
from the Register Save Area in the frame. */ 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; int i, j;
fs->saved_ra = REG_AT (rsa_base); fs->saved_rar = REG_AT (rsa_base);
fs->saved_pv = REG_AT (frame_base); fs->saved_pvr = REG_AT (frame_base);
for (i = 0, j = 0; i < 32; i++) for (i = 0, j = 0; i < 32; i++)
if (pv->pdsc$l_ireg_mask & (1 << i)) if (pv->pdsc$l_ireg_mask & (1 << i))
fs->saved_regs[i] = REG_AT (rsa_base + 8 * ++j); fs->saved_regs[i] = REG_AT (rsa_base + 8 * ++j);
/* Note that the loop above is guaranteed to set fs->saved_fp, because /* Note that the loop above is guaranteed to set fs->saved_fpr,
"The preserved register set must always include R29(FP) since it because "The preserved register set must always include R29(FP)
will always be used." (ABI-3.4.3.4 [Register Save Area for All since it will always be used." (ABI-3.4.3.4 [Register Save Area for
Stack Frames]). All Stack Frames]).
Also note that we need to run through all the registers to ensure Also note that we need to run through all the registers to ensure
that unwinding through register procedures (see below) gets the that unwinding through register procedures (see below) gets the
right values out of the saved_regs array. */ right values out of the saved_regs array. */
...@@ -174,8 +221,8 @@ unwind (frame_state_t * fs) ...@@ -174,8 +221,8 @@ unwind (frame_state_t * fs)
/* Register Procedure (ABI-3.4.4). Retrieve the necessary registers from /* Register Procedure (ABI-3.4.4). Retrieve the necessary registers from
the registers where they have been saved. */ the registers where they have been saved. */
{ {
fs->saved_ra = fs->saved_regs[pv->pdsc$b_save_ra]; fs->saved_rar = fs->saved_regs[pv->pdsc$b_save_ra];
fs->saved_fp = fs->saved_regs[pv->pdsc$b_save_fp]; fs->saved_fpr = fs->saved_regs[pv->pdsc$b_save_fp];
} }
break; break;
...@@ -187,19 +234,111 @@ unwind (frame_state_t * fs) ...@@ -187,19 +234,111 @@ unwind (frame_state_t * fs)
/* SP is actually never part of the saved registers area, so we use the /* 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 corresponding entry in the saved_regs array to manually keep track of
it's evolution. */ 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 /* Structure representing a traceback entry in the tracebacks array to be
filled by __gnat_backtrace below. 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 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 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 system functions need more than just a mere PC to compute info on a frame
(e.g. for non-symbolic->symbolic translation purposes). */ (e.g. for non-symbolic->symbolic translation purposes). */
typedef struct { typedef struct {
void * pc; ADDR pc;
void * pv; ADDR pv;
} tb_entry_t; } tb_entry_t;
/******************** /********************
...@@ -207,11 +346,8 @@ typedef struct { ...@@ -207,11 +346,8 @@ typedef struct {
********************/ ********************/
int int
__gnat_backtrace (void **array, __gnat_backtrace (void **array, int size,
int size, void *exclude_min, void *exclude_max, int skip_frames)
void *exclude_min,
void *exclude_max,
int skip_frames)
{ {
int cnt; int cnt;
...@@ -223,9 +359,9 @@ __gnat_backtrace (void **array, ...@@ -223,9 +359,9 @@ __gnat_backtrace (void **array,
register REG this_FP __asm__("$29"); register REG this_FP __asm__("$29");
register REG this_SP __asm__("$30"); register REG this_SP __asm__("$30");
frame_state.saved_fp = this_FP; frame_state.saved_fpr = this_FP;
frame_state.saved_sp = this_SP; frame_state.saved_spr = this_SP;
frame_state.saved_ra = RA_UNKNOWN; frame_state.saved_rar = RA_UNKNOWN;
unwind (&frame_state); unwind (&frame_state);
...@@ -239,15 +375,18 @@ __gnat_backtrace (void **array, ...@@ -239,15 +375,18 @@ __gnat_backtrace (void **array,
cnt = 0; cnt = 0;
while (cnt < size) while (cnt < size)
{ {
PDSCDEF * pv = PV_FOR (frame_state.fp);
/* Stop if either the frame contents or the unwinder say so. */
if (STOP_FRAME) if (STOP_FRAME)
break; break;
if (frame_state.pc < exclude_min if (! K_HANDLER_FRAME (&frame_state)
|| frame_state.pc > exclude_max) && (frame_state.pc < exclude_min || frame_state.pc > exclude_max))
{ {
tbe->pc = frame_state.pc; tbe->pc = (ADDR) frame_state.pc;
tbe->pv = PV_FOR (frame_state.fp); tbe->pv = (ADDR) PV_FOR (frame_state.fp);
cnt ++; cnt ++;
tbe ++; tbe ++;
} }
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment