diff options
-rw-r--r-- | gcc/ada/5lintman.adb | 401 | ||||
-rw-r--r-- | gcc/ada/ChangeLog | 76 | ||||
-rw-r--r-- | gcc/ada/Makefile.in | 41 | ||||
-rw-r--r-- | gcc/ada/adaint.c | 6 | ||||
-rw-r--r-- | gcc/ada/adaint.h | 1 | ||||
-rw-r--r-- | gcc/ada/back_end.adb | 8 | ||||
-rw-r--r-- | gcc/ada/exp_attr.adb | 5 | ||||
-rw-r--r-- | gcc/ada/exp_ch5.adb | 85 | ||||
-rw-r--r-- | gcc/ada/g-awk.adb | 10 | ||||
-rw-r--r-- | gcc/ada/g-debpoo.adb | 3 | ||||
-rw-r--r-- | gcc/ada/g-memdum.adb | 2 | ||||
-rw-r--r-- | gcc/ada/g-os_lib.ads | 2 | ||||
-rw-r--r-- | gcc/ada/g-spipat.adb | 48 | ||||
-rw-r--r-- | gcc/ada/g-thread.adb | 12 | ||||
-rw-r--r-- | gcc/ada/gnatlbr.adb | 3 | ||||
-rw-r--r-- | gcc/ada/gnatvsn.ads | 5 | ||||
-rw-r--r-- | gcc/ada/lang-specs.h | 1 | ||||
-rw-r--r-- | gcc/ada/lib-writ.adb | 2 | ||||
-rw-r--r-- | gcc/ada/make.adb | 2 | ||||
-rw-r--r-- | gcc/ada/s-geveop.adb | 6 | ||||
-rw-r--r-- | gcc/ada/s-interr.adb | 4 | ||||
-rw-r--r-- | gcc/ada/s-taskin.adb | 4 | ||||
-rw-r--r-- | gcc/ada/s-tassta.adb | 3 | ||||
-rw-r--r-- | gcc/ada/sem_attr.adb | 3 | ||||
-rw-r--r-- | gcc/ada/sem_prag.adb | 6 | ||||
-rw-r--r-- | gcc/ada/sem_warn.adb | 8 | ||||
-rw-r--r-- | gcc/ada/tb-alvms.c | 285 |
27 files changed, 442 insertions, 590 deletions
diff --git a/gcc/ada/5lintman.adb b/gcc/ada/5lintman.adb deleted file mode 100644 index 56871f3..0000000 --- a/gcc/ada/5lintman.adb +++ /dev/null @@ -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; diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index dbcf21f..e0c8857 100644 --- a/gcc/ada/ChangeLog +++ b/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, diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 4983adc..4b7148b 100644 --- a/gcc/ada/Makefile.in +++ b/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 diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 921e1d8..b7130d8 100644 --- a/gcc/ada/adaint.c +++ b/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); +} diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 5ce5d68..33c2bdc 100644 --- a/gcc/ada/adaint.h +++ b/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); diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb index 5725f9e..ede3f8b 100644 --- a/gcc/ada/back_end.adb +++ b/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); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 7a5d773..f296a6f6 100644 --- a/gcc/ada/exp_attr.adb +++ b/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)); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 8105de3..a257b27 100644 --- a/gcc/ada/exp_ch5.adb +++ b/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 Esize (Comp) <= 64 then + -- 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 + 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; diff --git a/gcc/ada/g-awk.adb b/gcc/ada/g-awk.adb index 3396daa..cece7e6 100644 --- a/gcc/ada/g-awk.adb +++ b/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 diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index ef853da..4eeae1a 100644 --- a/gcc/ada/g-debpoo.adb +++ b/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; diff --git a/gcc/ada/g-memdum.adb b/gcc/ada/g-memdum.adb index fd2167c..92f0839 100644 --- a/gcc/ada/g-memdum.adb +++ b/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; diff --git a/gcc/ada/g-os_lib.ads b/gcc/ada/g-os_lib.ads index 0e1af2a..63ed32f 100644 --- a/gcc/ada/g-os_lib.ads +++ b/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). diff --git a/gcc/ada/g-spipat.adb b/gcc/ada/g-spipat.adb index 3832a76..2f499b8 100644 --- a/gcc/ada/g-spipat.adb +++ b/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 -- diff --git a/gcc/ada/g-thread.adb b/gcc/ada/g-thread.adb index 3036730..1d71f37 100644 --- a/gcc/ada/g-thread.adb +++ b/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); diff --git a/gcc/ada/gnatlbr.adb b/gcc/ada/gnatlbr.adb index 40d5434..917f064 100644 --- a/gcc/ada/gnatlbr.adb +++ b/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"); diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads index 9cbb871..3b2c5e8 100644 --- a/gcc/ada/gnatvsn.ads +++ b/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 diff --git a/gcc/ada/lang-specs.h b/gcc/ada/lang-specs.h index 0ab33ff..b68e78d 100644 --- a/gcc/ada/lang-specs.h +++ b/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}} \ diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index fcb5f19..055f53a 100644 --- a/gcc/ada/lib-writ.adb +++ b/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; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index a304f10..b566c6b 100644 --- a/gcc/ada/make.adb +++ b/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; diff --git a/gcc/ada/s-geveop.adb b/gcc/ada/s-geveop.adb index f183a21..1820bdf 100644 --- a/gcc/ada/s-geveop.adb +++ b/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 diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb index dc578bc..0145610 100644 --- a/gcc/ada/s-interr.adb +++ b/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; diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index 84dafe7..63d527d 100644 --- a/gcc/ada/s-taskin.adb +++ b/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; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 8fc0103..1482633 100644 --- a/gcc/ada/s-tassta.adb +++ b/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 diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 400b162..8629c4d 100644 --- a/gcc/ada/sem_attr.adb +++ b/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; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 037650f..c626a1b 100644 --- a/gcc/ada/sem_prag.adb +++ b/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", diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index b77d49b..0d57ac0 100644 --- a/gcc/ada/sem_warn.adb +++ b/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; diff --git a/gcc/ada/tb-alvms.c b/gcc/ada/tb-alvms.c index 80cacbc..60effcc 100644 --- a/gcc/ada/tb-alvms.c +++ b/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(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 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. */ + + 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 || 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 ++; } |