From: charlet Date: Mon, 24 Nov 2003 14:27:57 +0000 (+0000) Subject: 2003-11-24 Jose Ruiz X-Git-Tag: upstream/4.9.2~75151 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=cf428c6cdd5b5d0454a13bca01295dce0eb5b6f3;p=platform%2Fupstream%2Flinaro-gcc.git 2003-11-24 Jose Ruiz * Makefile.in: Use 5zintman.ads for VxWorks targets. This file avoid confusion between signals and interrupts. * 5zintman.ads: New File. * 5zintman.adb: Replace Exception_Interrupts by Exception_Signals, and add exception signals to the set of unmasked signals. * 5ztaprop.adb: Use Abort_Task_Signal instead of Abort_Task_Interrupt to avoid confusion between signals and interrupts. Add to Unblocked_Signal_Mask the set of signals that are in Keep_Unmasked. * 7sinmaop.adb: Adding a check to see whether the Interrupt_ID we want to unmask is in the range of Keep_Unmasked (in procedure Interrupt_Self_Process). The reason is that the index type of the Keep_Unmasked array is not always Interrupt_ID; it may be a subtype of Interrupt_ID. 2003-11-24 Gary Dismukes * exp_util.adb: (Remove_Side_Effects): Condition constantness of object created for a an unchecked type conversion on the constantness of the expression to ensure the correct value for 'Constrained when passing components of view-converted class-wide objects. 2003-11-24 Robert Dewar * par-load.adb (Load): Improve handling of misspelled and missing units Removes several cases of compilation abandoned messages * lib.adb: (Remove_Unit): New procedure * lib.ads: (Remove_Unit): New procedure * lib-load.adb: Minor reformatting 2003-11-24 Vincent Celier * make.adb: (Gnatmake, Initialize): Call Usage instead of Makeusg directly (Marking_Label): Label to mark processed source files. Incremented for each executable. (Gnatmake): Increase Marking_Labet for each executable (Is_Marked): Compare against marking label (Mark): Mark with marking label 2003-11-24 Jerome Guitton * s-thread.ads: Move the declaration of the TSD for System.Threads to System.Soft_Links. Add some comments. * Makefile.in: Added target pair for s-thread.adb for cert runtime. (rts-cert): build a single relocatable object for the run-time lib. Fix perms. 2003-11-24 Vasiliy Fofanov * Make-lang.in: Use gnatls rather than gcc to obtain the location of GNAT RTL for crosstools build. 2003-11-24 Sergey Rybin * opt.adb (Tree_Write): Gnat_Version_String is now a function, so we can not use it as before (that is, as a variable) when dumping it into the tree file. Add a local variable to store the result of this function and to be used as the string to be written into the tree. * scn.adb (Initialize_Scanner): Add comments explaining the recent changes. * sinput.adb (Source_First, Source_Last): In case of Internal_Source_File, replace returning attributes of Internal_Source_Ptr (which is wrong) with returning attributes of Internal_Source. 2003-11-24 Ed Schonberg * sem_ch3.adb: (New_Concatenation_Op): Proper name for New_Binary_Operator, only used for implicit concatenation operators. Code cleanup. * sem_elab.adb: (Check_Elab_Call): Set No_Elaboration_Check appropriately on calls in task bodies that are in the scope of a Suppress pragma. (Check_A Call): Use the flag to prevent spurious elaboration checks. * sinfo.ads, sinfo.adb: New flag No_Elaboration_Check on function/procedure calls, to properly suppress checks on calls in task bodies that are within a local suppress pragma. * exp_ch4.adb: (Expand_Concatenate_Other): Use the proper integer type for the expression for the upper bound, to avoid universal_integer computations when possible. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@73874 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/5zintman.adb b/gcc/ada/5zintman.adb index 2933f24..fd9b86f 100644 --- a/gcc/ada/5zintman.adb +++ b/gcc/ada/5zintman.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- -- @@ -62,22 +62,27 @@ package body System.Interrupt_Management is use System.OS_Interface; use type Interfaces.C.int; - type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; - Exception_Interrupts : constant Interrupt_List (1 .. 4) := - (SIGFPE, SIGILL, SIGSEGV, SIGBUS); + type Signal_List is array (Signal_ID range <>) of Signal_ID; + Exception_Signals : constant Signal_List (1 .. 4) := + (SIGFPE, SIGILL, SIGSEGV, SIGBUS); - -- Keep these variables global so that they are initialized only once. + -- Keep these variables global so that they are initialized only once + -- What are "these variables" ???, I see only one Exception_Action : aliased struct_sigaction; - ---------------------- - -- Notify_Exception -- - ---------------------- + ----------------------- + -- Local Subprograms -- + ----------------------- procedure Notify_Exception (signo : Signal); -- Identify the Ada exception to be raised using -- the information when the system received a synchronous signal. + ---------------------- + -- Notify_Exception -- + ---------------------- + procedure Notify_Exception (signo : Signal) is Mask : aliased sigset_t; Result : int; @@ -126,10 +131,10 @@ package body System.Interrupt_Management is old_act : aliased struct_sigaction; begin - for J in Exception_Interrupts'Range loop + for J in Exception_Signals'Range loop Result := sigaction - (Signal (Exception_Interrupts (J)), Exception_Action'Access, + (Signal (Exception_Signals (J)), Exception_Action'Access, old_act'Unchecked_Access); pragma Assert (Result = 0); end loop; @@ -160,15 +165,15 @@ begin -- Change this if you want to use another signal for task abort. -- SIGTERM might be a good one. - Abort_Task_Interrupt := SIGABRT; + Abort_Task_Signal := SIGABRT; Exception_Action.sa_handler := Notify_Exception'Address; Exception_Action.sa_flags := SA_ONSTACK; Result := sigemptyset (mask'Access); pragma Assert (Result = 0); - for J in Exception_Interrupts'Range loop - Result := sigaddset (mask'Access, Signal (Exception_Interrupts (J))); + for J in Exception_Signals'Range loop + Result := sigaddset (mask'Access, Signal (Exception_Signals (J))); pragma Assert (Result = 0); end loop; @@ -185,5 +190,15 @@ begin Reserve (J) := True; end if; end loop; + + -- Add exception signals to the set of unmasked signals + + for J in Exception_Signals'Range loop + Keep_Unmasked (Exception_Signals (J)) := True; + end loop; + + -- The abort signal must also be unmasked + + Keep_Unmasked (Abort_Task_Signal) := True; end; end System.Interrupt_Management; diff --git a/gcc/ada/5zintman.ads b/gcc/ada/5zintman.ads new file mode 100644 index 0000000..b0a4c3c --- /dev/null +++ b/gcc/ada/5zintman.ads @@ -0,0 +1,123 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- -- +-- S p e c -- +-- -- +-- 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- -- +-- 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 VxWorks version of this package. + +-- This package encapsulates and centralizes information about all +-- uses of interrupts (or signals), including the target-dependent +-- mapping of interrupts (or signals) to exceptions. + +-- Unlike the original design, System.Interrupt_Management can only +-- be used for tasking systems. + +-- PLEASE DO NOT remove the Elaborate_Body pragma from this package. +-- Elaboration of this package should happen early, as most other +-- initializations depend on it. Forcing immediate elaboration of +-- the body also helps to enforce the design assumption that this +-- is a second-level package, just one level above System.OS_Interface +-- with no cross-dependencies. + +-- PLEASE DO NOT put any subprogram declarations with arguments of +-- type Interrupt_ID into the visible part of this package. The type +-- Interrupt_ID is used to derive the type in Ada.Interrupts, and +-- adding more operations to that type would be illegal according +-- to the Ada Reference Manual. This is the reason why the signals +-- sets are implemeneted using visible arrays rather than functions. + +with System.OS_Interface; +-- used for sigset_t + +with Interfaces.C; +-- used for int + +package System.Interrupt_Management is + + pragma Elaborate_Body; + + type Interrupt_Mask is limited private; + + type Interrupt_ID is new Interfaces.C.int + range 0 .. System.OS_Interface.Max_Interrupt; + + type Interrupt_Set is array (Interrupt_ID) of Boolean; + + subtype Signal_ID is Interrupt_ID + range 0 .. Interfaces.C."-" (System.OS_Interface.NSIG, 1); + + type Signal_Set is array (Signal_ID) of Boolean; + + -- The following objects serve as constants, but are initialized + -- in the body to aid portability. This permits us to use more + -- portable names for interrupts, where distinct names may map to + -- the same interrupt ID value. + -- + -- For example, suppose SIGRARE is a signal that is not defined on + -- all systems, but is always reserved when it is defined. If we + -- have the convention that ID zero is not used for any "real" + -- signals, and SIGRARE = 0 when SIGRARE is not one of the locally + -- supported signals, we can write + -- Reserved (SIGRARE) := true; + -- and the initialization code will be portable. + + Abort_Task_Signal : Signal_ID; + -- The signal that is used to implement task abortion if + -- an interrupt is used for that purpose. This is one of the + -- reserved signals. + + Keep_Unmasked : Signal_Set := (others => False); + -- Keep_Unmasked (I) is true iff the signal I is one that must + -- that must be kept unmasked at all times, except (perhaps) for + -- short critical sections. This includes signals that are + -- mapped to exceptions, but may also include interrupts + -- (e.g. timer) that need to be kept unmasked for other + -- reasons. Where signal masking is per-task, the signal should be + -- unmasked in ALL TASKS. + + Reserve : Interrupt_Set := (others => False); + -- Reserve (I) is true iff the interrupt I is one that cannot be + -- permitted to be attached to a user handler. The possible reasons + -- are many. For example, it may be mapped to an exception used to + -- implement task abortion, or used to implement time delays. + + procedure Initialize_Interrupts; + -- On systems where there is no signal inheritance between tasks (e.g + -- VxWorks, GNU/LinuxThreads), this procedure is used to initialize + -- interrupts handling in each task. Otherwise this function should + -- only be called by initialize in this package body. + +private + type Interrupt_Mask is new System.OS_Interface.sigset_t; + -- In some implementation Interrupt_Mask can be represented + -- as a linked list. + +end System.Interrupt_Management; diff --git a/gcc/ada/5ztaprop.adb b/gcc/ada/5ztaprop.adb index 2451e91..6ee3f80 100644 --- a/gcc/ada/5ztaprop.adb +++ b/gcc/ada/5ztaprop.adb @@ -45,8 +45,8 @@ with System.Tasking.Debug; with System.Interrupt_Management; -- used for Keep_Unmasked --- Abort_Task_Interrupt --- Interrupt_ID +-- Abort_Task_Signal +-- Signal_ID -- Initialize_Interrupts with System.Soft_Links; @@ -262,7 +262,7 @@ package body System.Task_Primitives.Operations is Result := sigaction - (Signal (Interrupt_Management.Abort_Task_Interrupt), + (Signal (Interrupt_Management.Abort_Task_Signal), act'Unchecked_Access, old_act'Unchecked_Access); pragma Assert (Result = 0); @@ -1008,7 +1008,7 @@ package body System.Task_Primitives.Operations is begin Result := kill (T.Common.LL.Thread, - Signal (Interrupt_Management.Abort_Task_Interrupt)); + Signal (Interrupt_Management.Abort_Task_Signal)); pragma Assert (Result = 0); end Abort_Task; @@ -1126,6 +1126,13 @@ package body System.Task_Primitives.Operations is Result := sigemptyset (Unblocked_Signal_Mask'Access); pragma Assert (Result = 0); + for J in Interrupt_Management.Signal_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + Environment_Task_ID := Environment_Task; -- Initialize the lock used to synchronize chain of all ATCBs. diff --git a/gcc/ada/7sinmaop.adb b/gcc/ada/7sinmaop.adb index 8c767b2..8fe6b3a 100644 --- a/gcc/ada/7sinmaop.adb +++ b/gcc/ada/7sinmaop.adb @@ -325,11 +325,16 @@ begin Storage_Elements.To_Address (Storage_Elements.Integer_Address (SIG_IGN)); - for I in Interrupt_ID loop - if Keep_Unmasked (I) then - Result := sigaddset (mask'Access, Signal (I)); + for J in Interrupt_ID loop + + -- We need to check whether J is in Keep_Unmasked because + -- the index type of the Keep_Unmasked array is not always + -- Interrupt_ID; it may be a subtype of Interrupt_ID. + + if J in Keep_Unmasked'Range and then Keep_Unmasked (J) then + Result := sigaddset (mask'Access, Signal (J)); pragma Assert (Result = 0); - Result := sigdelset (allmask'Access, Signal (I)); + Result := sigdelset (allmask'Access, Signal (J)); pragma Assert (Result = 0); end if; end loop; diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c526092..e40866c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,108 @@ +2003-11-24 Jose Ruiz + + * Makefile.in: + Use 5zintman.ads for VxWorks targets. This file avoid confusion between + signals and interrupts. + + * 5zintman.ads: New File. + + * 5zintman.adb: Replace Exception_Interrupts by Exception_Signals, and + add exception signals to the set of unmasked signals. + + * 5ztaprop.adb: + Use Abort_Task_Signal instead of Abort_Task_Interrupt to avoid confusion + between signals and interrupts. + Add to Unblocked_Signal_Mask the set of signals that are in + Keep_Unmasked. + + * 7sinmaop.adb: + Adding a check to see whether the Interrupt_ID we want to unmask is in + the range of Keep_Unmasked (in procedure Interrupt_Self_Process). The + reason is that the index type of the Keep_Unmasked array is not always + Interrupt_ID; it may be a subtype of Interrupt_ID. + +2003-11-24 Gary Dismukes + + * exp_util.adb: + (Remove_Side_Effects): Condition constantness of object created for a + an unchecked type conversion on the constantness of the expression + to ensure the correct value for 'Constrained when passing components + of view-converted class-wide objects. + +2003-11-24 Robert Dewar + + * par-load.adb (Load): Improve handling of misspelled and missing units + Removes several cases of compilation abandoned messages + + * lib.adb: (Remove_Unit): New procedure + + * lib.ads: (Remove_Unit): New procedure + + * lib-load.adb: Minor reformatting + +2003-11-24 Vincent Celier + + * make.adb: + (Gnatmake, Initialize): Call Usage instead of Makeusg directly + (Marking_Label): Label to mark processed source files. Incremented for + each executable. + (Gnatmake): Increase Marking_Labet for each executable + (Is_Marked): Compare against marking label + (Mark): Mark with marking label + +2003-11-24 Jerome Guitton + + * s-thread.ads: + Move the declaration of the TSD for System.Threads to System.Soft_Links. + Add some comments. + + * Makefile.in: Added target pair for s-thread.adb for cert runtime. + (rts-cert): build a single relocatable object for the run-time lib. + Fix perms. + +2003-11-24 Vasiliy Fofanov + + * Make-lang.in: + Use gnatls rather than gcc to obtain the location of GNAT RTL for + crosstools build. + +2003-11-24 Sergey Rybin + + * opt.adb (Tree_Write): Gnat_Version_String is now a function, so we + can not use it as before (that is, as a variable) when dumping it into + the tree file. Add a local variable to store the result of this + function and to be used as the string to be written into the tree. + + * scn.adb (Initialize_Scanner): Add comments explaining the recent + changes. + + * sinput.adb (Source_First, Source_Last): In case of + Internal_Source_File, replace returning attributes of + Internal_Source_Ptr (which is wrong) with returning attributes of + Internal_Source. + +2003-11-24 Ed Schonberg + + * sem_ch3.adb: + (New_Concatenation_Op): Proper name for New_Binary_Operator, only + used for implicit concatenation operators. + Code cleanup. + + * sem_elab.adb: + (Check_Elab_Call): Set No_Elaboration_Check appropriately on calls in + task bodies that are in the scope of a Suppress pragma. + (Check_A Call): Use the flag to prevent spurious elaboration checks. + + * sinfo.ads, sinfo.adb: + New flag No_Elaboration_Check on function/procedure calls, to properly + suppress checks on calls in task bodies that are within a local suppress + pragma. + + * exp_ch4.adb: + (Expand_Concatenate_Other): Use the proper integer type for the + expression for the upper bound, to avoid universal_integer computations + when possible. + 2003-11-21 Kelley Cook * .cvsignore: Delete. diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in index 255a2e6..c3e7d18 100644 --- a/gcc/ada/Make-lang.in +++ b/gcc/ada/Make-lang.in @@ -290,10 +290,10 @@ regnattools: # use host-gcc host-gnatmake host-gnatbind host-gnatlink # put the host RTS dir first in the PATH to hide the default runtime # files that are among the sources -RTS_DIR:=$(dir $(subst \,/,$(shell $(CC) -print-libgcc-file-name))) +RTS_DIR:=$(strip $(subst \,/,$(shell gnatls -v | grep adalib ))) cross-gnattools: force $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS)\ - ADA_INCLUDES="-I$(RTS_DIR)adainclude -I$(RTS_DIR)adalib" \ + ADA_INCLUDES="-I$(RTS_DIR)../adainclude -I$(RTS_DIR)" \ GNATMAKE="gnatmake" \ GNATBIND="gnatbind" \ GNATLINK="gnatlink" \ diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 66956a9..6b49607 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -461,6 +461,7 @@ ifeq ($(strip $(filter-out alpha% dec vx%,$(targ))),) a-numaux.ads<4znumaux.ads \ s-inmaop.adb<7sinmaop.adb \ s-interr.adb<5zinterr.adb \ + s-intman.ads<5zintman.ads \ s-intman.adb<5zintman.adb \ s-osinte.adb<5zosinte.adb \ s-osinte.ads<5zosinte.ads \ @@ -487,6 +488,7 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(targ))),) a-numaux.ads<4znumaux.ads \ s-inmaop.adb<7sinmaop.adb \ s-interr.adb<5zinterr.adb \ + s-intman.ads<5zintman.ads \ s-intman.adb<5zintman.adb \ s-osinte.adb<5zosinte.adb \ s-osinte.ads<5zosinte.ads \ @@ -524,6 +526,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) a-numaux.ads<4znumaux.ads \ s-inmaop.adb<7sinmaop.adb \ s-interr.adb<5zinterr.adb \ + s-intman.ads<5zintman.ads \ s-intman.adb<5zintman.adb \ s-osinte.adb<5zosinte.adb \ s-osinte.ads<5zosinte.ads \ @@ -593,6 +596,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) s-soflin.ads<2ssoflin.ads \ s-stalib.adb<1sstalib.adb \ s-stalib.ads<1sstalib.ads \ + s-thread.adb<5zthread.adb \ s-thrini.ads<2sthrini.ads \ s-thrini.adb<5zthrini.adb \ s-tiitho.adb<5ztiitho.adb \ @@ -619,6 +623,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),) a-numaux.ads<4znumaux.ads \ s-inmaop.adb<7sinmaop.adb \ s-interr.adb<5zinterr.adb \ + s-intman.ads<5zintman.ads \ s-intman.adb<5zintman.adb \ s-osinte.adb<5zosinte.adb \ s-osinte.ads<5zosinte.ads \ @@ -692,7 +697,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),) s-soflin.ads<2ssoflin.ads \ s-stalib.adb<1sstalib.adb \ s-stalib.ads<1sstalib.ads \ - s-thrini.adb<5zthrini.adb \ + s-thread.adb<5zthread.adb \ s-thrini.ads<2sthrini.ads \ s-thrini.adb<5zthrini.adb \ s-tiitho.adb<5ytiitho.adb \ @@ -736,6 +741,7 @@ ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),) a-numaux.ads<4znumaux.ads \ s-inmaop.adb<7sinmaop.adb \ s-interr.adb<5zinterr.adb \ + s-intman.ads<5zintman.ads \ s-intman.adb<5zintman.adb \ s-osinte.adb<5zosinte.adb \ s-osinte.ads<5zosinte.ads \ @@ -764,6 +770,7 @@ ifeq ($(strip $(filter-out xscale% coff wrs vx%,$(targ))),) a-numaux.ads<4znumaux.ads \ s-inmaop.adb<7sinmaop.adb \ s-interr.adb<5zinterr.adb \ + s-intman.ads<5zintman.ads \ s-intman.adb<5zintman.adb \ s-osinte.adb<5zosinte.adb \ s-osinte.ads<5zosinte.ads \ @@ -792,6 +799,7 @@ ifeq ($(strip $(filter-out mips% wrs vx%,$(targ))),) a-numaux.ads<4znumaux.ads \ s-inmaop.adb<7sinmaop.adb \ s-interr.adb<5zinterr.adb \ + s-intman.ads<5zintman.ads \ s-intman.adb<5zintman.adb \ s-osinte.adb<5zosinte.adb \ s-osinte.ads<5zosinte.ads \ @@ -2055,8 +2063,10 @@ rts-cert: force ../../../$(GCC_FOR_TARGET) -B../../../ $(TARGET_LIBGCC2_CFLAGS) \ $(ALL_CFLAGS) $(GNATLIBCFLAGS_FOR_C) -c ../adainclude/$(f).c \ -I../adainclude $(INCLUDES_FOR_SUBDIR) -I../../../ ;) \ - $(AR) $(AR_FLAGS) libgnat$(arext) \ - $(addsuffix .o,$(CERT_LEVEL_B_C_FILES)) + ../../../xgcc -B../../../ *.o -o libgnat ; \ + $(CHMOD) a-wx *.ali ; \ + $(RM) *.o ; \ + $(MV) libgnat libgnat.o rts-none: force $(MAKE) $(FLAGS_TO_PASS) prepare-rts \ diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index fd0631a..85de433 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -1472,7 +1472,7 @@ package body Exp_Ch4 is -- their base type, Ind_Typ their index type, and Arr_Typ the original -- array type to which the concatenantion operator applies, then the -- following subprogram is constructed: - -- + -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is -- L : Ind_Typ; -- begin @@ -1489,7 +1489,7 @@ package body Exp_Ch4 is -- else -- return Sn; -- end if; - -- + -- declare -- P : Ind_Typ; -- H : Ind_Typ := @@ -1516,9 +1516,9 @@ package body Exp_Ch4 is -- P := Ind_Typ'Succ (P); -- end loop; -- end if; - -- + -- ... - -- + -- if Sn'Length /= 0 then -- P := Sn'First; -- loop @@ -1528,7 +1528,7 @@ package body Exp_Ch4 is -- P := Ind_Typ'Succ (P); -- end loop; -- end if; - -- + -- return R; -- end; -- end Cnn;] @@ -1598,7 +1598,9 @@ package body Exp_Ch4 is -- Builds reference to identifier L. function L_Pos return Node_Id; - -- Builds expression Ind_Typ'Pos (L). + -- Builds expression Integer_Type'(Ind_Typ'Pos (L)). + -- We qualify the expression to avoid universal_integer computations + -- whenever possible, in the expression for the upper bound H. function L_Succ return Node_Id; -- Builds expression Ind_Typ'Succ (L). @@ -1743,12 +1745,31 @@ package body Exp_Ch4 is ----------- function L_Pos return Node_Id is + Target_Type : Entity_Id; + begin + -- If the index type is an enumeration type, the computation + -- can be done in standard integer. Otherwise, choose a large + -- enough integer type. + + if Is_Enumeration_Type (Ind_Typ) + or else Root_Type (Ind_Typ) = Standard_Integer + or else Root_Type (Ind_Typ) = Standard_Short_Integer + or else Root_Type (Ind_Typ) = Standard_Short_Short_Integer + then + Target_Type := Standard_Integer; + else + Target_Type := Root_Type (Ind_Typ); + end if; + return - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Ind_Typ, Loc), - Attribute_Name => Name_Pos, - Expressions => New_List (L)); + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Reference_To (Target_Type, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ind_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (L))); end L_Pos; ------------ diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 7cc7483..6c3911c 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3510,7 +3510,7 @@ package body Exp_Util is Make_Object_Declaration (Loc, Defining_Identifier => Def_Id, Object_Definition => New_Reference_To (Exp_Type, Loc), - Constant_Present => True, + Constant_Present => not Is_Variable (Exp), Expression => Relocate_Node (Exp)); Set_Assignment_OK (E); diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 015c92e..fbb50af 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -688,14 +688,11 @@ package body Lib.Load is procedure Make_Instance_Unit (N : Node_Id) is Sind : constant Source_File_Index := Source_Index (Main_Unit); - begin Units.Increment_Last; - Units.Table (Units.Last) := Units.Table (Main_Unit); Units.Table (Units.Last).Cunit := Library_Unit (N); Units.Table (Units.Last).Generate_Code := True; - Units.Table (Main_Unit).Cunit := N; Units.Table (Main_Unit).Unit_Name := Get_Body_Name (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N)))); @@ -713,7 +710,6 @@ package body Lib.Load is is Sunit : constant Node_Id := Cunit (Spec_Unit); Bunit : constant Node_Id := Cunit (Body_Unit); - begin -- The spec is irrelevant if the body is a subprogram body, and the -- spec is other than a subprogram spec or generic subprogram spec. @@ -725,7 +721,6 @@ package body Lib.Load is Nkind (Unit (Bunit)) = N_Subprogram_Body and then Nkind (Unit (Sunit)) /= N_Subprogram_Declaration and then Nkind (Unit (Sunit)) /= N_Generic_Subprogram_Declaration; - end Spec_Is_Irrelevant; -------------------- @@ -735,9 +730,7 @@ package body Lib.Load is procedure Version_Update (U : Node_Id; From : Node_Id) is Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (U); Fnum : constant Unit_Number_Type := Get_Cunit_Unit_Number (From); - begin - if Source_Index (Fnum) /= No_Source_File then Units.Table (Unum).Version := Units.Table (Unum).Version diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index 21d299e..5e90930 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -870,6 +870,17 @@ package body Lib is return Int (Units.Last) - Int (Main_Unit) + 1; end Num_Units; + ----------------- + -- Remove_Unit -- + ----------------- + + procedure Remove_Unit (U : Unit_Number_Type) is + begin + if U = Units.Last then + Units.Decrement_Last; + end if; + end Remove_Unit; + ---------------------------------- -- Replace_Linker_Option_String -- ---------------------------------- diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index 836491b..4fe2ff4 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -417,6 +417,10 @@ package Lib is function Num_Units return Nat; -- Number of units currently in unit table + procedure Remove_Unit (U : Unit_Number_Type); + -- Remove unit U from unit table. Currently this is effective only + -- if U is the last unit currently stored in the unit table. + function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean; -- Returns True if the entity E is declared in the main unit, or, in -- its corresponding spec, or one of its subunits. Entities declared diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 5d2a9ce..1a58a82 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -24,12 +24,6 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Exceptions; use Ada.Exceptions; -with Ada.Command_Line; use Ada.Command_Line; - -with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with GNAT.Case_Util; use GNAT.Case_Util; - with ALI; use ALI; with ALI.Util; use ALI.Util; with Csets; @@ -65,6 +59,12 @@ with System.HTable; with Targparm; with Tempdir; +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Command_Line; use Ada.Command_Line; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.Case_Util; use GNAT.Case_Util; + package body Make is use ASCII; @@ -480,6 +480,9 @@ package body Make is -- Marking Routines -- ---------------------- + Marking_Label : Byte := 1; + -- Value to mark the source files + procedure Mark (Source_File : File_Name_Type); -- Mark Source_File. Marking is used to signal that Source_File has -- already been inserted in the Q. @@ -2233,7 +2236,9 @@ package body Make is ------------- function Compile - (S : Name_Id; L : Name_Id; Args : Argument_List) return Process_Id + (S : Name_Id; + L : Name_Id; + Args : Argument_List) return Process_Id is Comp_Args : Argument_List (Args'First .. Args'Last + 8); Comp_Next : Integer := Args'First; @@ -3692,7 +3697,7 @@ package body Make is else -- Output usage information if no files to compile - Makeusg; + Usage; Exit_Program (E_Fatal); end if; end if; @@ -4228,6 +4233,18 @@ package body Make is Multiple_Main_Loop : for N_File in 1 .. Osint.Number_Of_Files loop + -- Increase the marking label to be sure to check sources + -- for all executables. + + Marking_Label := Marking_Label + 1; + + -- Make sure it is not 0, which is the default value for + -- a file that has never been marked. + + if Marking_Label = 0 then + Marking_Label := 1; + end if; + -- First, find the executable name and path Executable := No_File; @@ -5573,7 +5590,7 @@ package body Make is end loop Scan_Args; if Usage_Requested then - Makeusg; + Usage; end if; -- Test for trailing -P switch @@ -5695,6 +5712,10 @@ package body Make is Make_Failed (Exception_Message (Err)); end; end if; + + -- Set the marking label to a value that is not zero + + Marking_Label := 1; end Initialize; ----------------------------------- @@ -5707,10 +5728,11 @@ package body Make is Into_Q : Boolean) is Put_In_Q : Boolean := Into_Q; - Unit : Com.Unit_Data; - Sfile : Name_Id; + Unit : Com.Unit_Data; + Sfile : Name_Id; + Extending : constant Boolean := - Projects.Table (The_Project).Extends /= No_Project; + Projects.Table (The_Project).Extends /= No_Project; function Check_Project (P : Project_Id) return Boolean; -- Returns True if P is The_Project or a project extended by @@ -6044,7 +6066,7 @@ package body Make is function Is_Marked (Source_File : File_Name_Type) return Boolean is begin - return Get_Name_Table_Byte (Source_File) /= 0; + return Get_Name_Table_Byte (Source_File) = Marking_Label; end Is_Marked; ---------- @@ -6228,7 +6250,7 @@ package body Make is procedure Mark (Source_File : File_Name_Type) is begin - Set_Name_Table_Byte (Source_File, 1); + Set_Name_Table_Byte (Source_File, Marking_Label); end Mark; -------------------- diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index cce9b1e..be1eca6 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -186,6 +186,7 @@ package body Opt is ---------------- procedure Tree_Write is + Version_String : String := Gnat_Version_String; begin Tree_Write_Int (ASIS_Version_Number); Tree_Write_Bool (Brief_Output); @@ -202,9 +203,9 @@ package body Opt is Tree_Write_Bool (Assertions_Enabled); Tree_Write_Bool (Enable_Overflow_Checks); Tree_Write_Bool (Full_List); - Tree_Write_Int (Int (Gnat_Version_String'Length)); - Tree_Write_Data (Gnat_Version_String'Address, - Gnat_Version_String'Length); + Tree_Write_Int (Int (Version_String'Length)); + Tree_Write_Data (Version_String'Address, + Version_String'Length); Tree_Write_Data (Distribution_Stub_Mode'Address, Distribution_Stub_Mode_Type'Object_Size / Storage_Unit); Tree_Write_Bool (Immediate_Errors); diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb index fb0f268..163fb0b 100644 --- a/gcc/ada/par-load.adb +++ b/gcc/ada/par-load.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- -- @@ -42,6 +42,8 @@ with Sinput.L; use Sinput.L; with Stylesw; use Stylesw; with Validsw; use Validsw; +with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; + separate (Par) procedure Load is @@ -188,26 +190,45 @@ begin or else Name_Buffer (1) = 'g') then - -- In the predefined file case, we know the user did not construct - -- their own package, but we got the wrong one. This means that the - -- name supplied by the user crunched to something we recognized, - -- but then the file did not contain the unit expected. Most likely - -- this is due to a misspelling, e.g. - - -- with Ada.Calender; - - -- This crunches to a-calend, which indeed contains the unit - -- Ada.Calendar, and we can diagnose the misspelling. This is - -- a simple heuristic, but it catches many common cases of - -- misspelling of predefined unit names without needing a full - -- list of them. - - Error_Msg_Name_1 := Expected_Unit (Cur_Unum); - Error_Msg ("% is not a predefined library unit!", Loc); - Error_Msg_Name_1 := Unit_Name (Cur_Unum); - Error_Msg ("possible misspelling of %!", Loc); + declare + Expect_Name : constant Name_Id := Expected_Unit (Cur_Unum); + Actual_Name : constant Name_Id := Unit_Name (Cur_Unum); + + begin + Error_Msg_Name_1 := Expect_Name; + Error_Msg ("% is not a predefined library unit!", Loc); + + -- In the predefined file case, we know the user did not + -- construct their own package, but we got the wrong one. + -- This means that the name supplied by the user crunched + -- to something we recognized, but then the file did not + -- contain the unit expected. Most likely this is due to + -- a misspelling, e.g. + + -- with Ada.Calender; + + -- This crunches to a-calend, which indeed contains the unit + -- Ada.Calendar, and we can diagnose the misspelling. This + -- is a simple heuristic, but it catches many common cases + -- of misspelling of predefined unit names without needing + -- a full list of them. + + -- Before actually issinying the message, we will check that the + -- unit name is indeed a plausible misspelling of the one we got. + + if Is_Bad_Spelling_Of + (Found => Get_Name_String (Expect_Name), + Expect => Get_Name_String (Actual_Name)) + then + Error_Msg_Name_1 := Actual_Name; + Error_Msg ("possible misspelling of %!", Loc); + end if; + end; - -- Non-predefined file name case + -- Non-predefined file name case. In this case we generate a message + -- and then we quit, because we are in big trouble, and if we try + -- to continue compilation, we get into some nasty situations + -- (for example in some subunit cases). else Error_Msg ("file { does not contain expected unit!", Loc); @@ -217,7 +238,10 @@ begin Error_Msg ("found unit $!", Loc); end if; - raise Unrecoverable_Error; + -- In both cases, remove the unit if it is the last unit (which it + -- normally (always?) will be) so that it is out of the way later. + + Remove_Unit (Cur_Unum); end if; -- If current unit is a body, load its corresponding spec diff --git a/gcc/ada/s-thread.ads b/gcc/ada/s-thread.ads index 6badd16..f1606f1 100644 --- a/gcc/ada/s-thread.ads +++ b/gcc/ada/s-thread.ads @@ -38,6 +38,10 @@ -- VxWorks AE653 with the restricted / cert runtime with Ada.Exceptions; +-- used for Exception_Occurrence + +with System.Soft_Links; +-- used for TSD package System.Threads is @@ -137,27 +141,6 @@ package System.Threads is private - ------------------------ - -- Task Specific Data -- - ------------------------ - - type ATSD is limited record - Jmpbuf_Address : Address := Null_Address; - -- Address of jump buffer used to store the address of the - -- current longjmp/setjmp buffer for exception management. - -- These buffers are threaded into a stack, and the address - -- here is the top of the stack. A null address means that - -- no exception handler is currently active. - - Sec_Stack_Addr : Address := Null_Address; - -- Address of currently allocated secondary stack - - Current_Excep : aliased EO; - -- Exception occurrence that contains the information for the - -- current exception. Note that any exception in the same task - -- destroys this information, so the data in this variable must - -- be copied out before another exception can occur. - - end record; + type ATSD is new System.Soft_Links.TSD; end System.Threads; diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb index 1e829e4..ff0792c 100644 --- a/gcc/ada/scn.adb +++ b/gcc/ada/scn.adb @@ -261,7 +261,9 @@ package body Scn is begin Scanner.Initialize_Scanner (Unit, Index); - -- Set default for Comes_From_Source. All nodes built now until we + -- Set default for Comes_From_Source (except if we are going to process + -- an artificial string internally created within the compiler and + -- placed into internal source duffer). All nodes built now until we -- reenter the analyzer will have Comes_From_Source set to True if Index /= Internal_Source_File then @@ -280,6 +282,16 @@ package body Scn is -- call Scan. Scan initial token (note this initializes Prev_Token, -- Prev_Token_Ptr). + -- There are two reasons not to do the Scan step in case if we + -- initialize the scanner for the internal source buffer: + + -- - The artificial string may not be created by the compiler in this + -- buffer when we call Initialize_Scanner + + -- - For these artificial strings a special way of scanning is used, so + -- the standard step of the scanner may just break the algorithm of + -- processing these strings. + if Index /= Internal_Source_File then Scan; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index afdb50f..b798fd5 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -548,9 +548,9 @@ package body Sem_Ch3 is -- Create new modular type. Verify that modulus is in bounds and is -- a power of two (implementation restriction). - procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id); + procedure New_Concatenation_Op (Typ : Entity_Id); -- Create an abbreviated declaration for an operator in order to - -- materialize minimally operators on derived types. + -- materialize concatenation on array types. procedure Ordinary_Fixed_Point_Type_Declaration (T : Entity_Id; @@ -2865,7 +2865,7 @@ package body Sem_Ch3 is if Number_Dimensions (T) = 1 and then not Is_Packed_Array_Type (T) then - New_Binary_Operator (Name_Op_Concat, T); + New_Concatenation_Op (T); end if; -- In the case of an unconstrained array the parser has already @@ -3068,7 +3068,7 @@ package body Sem_Ch3 is and then not Is_Derived_Type (Parent_Type) and then not Is_Package (Scope (Base_Type (Parent_Type))) then - New_Binary_Operator (Name_Op_Concat, Derived_Type); + New_Concatenation_Op (Derived_Type); end if; end Build_Derived_Array_Type; @@ -10945,11 +10945,11 @@ package body Sem_Ch3 is end Modular_Type_Declaration; - ------------------------- - -- New_Binary_Operator -- - ------------------------- + -------------------------- + -- New_Concatenation_Op -- + -------------------------- - procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id) is + procedure New_Concatenation_Op (Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (Typ); Op : Entity_Id; @@ -10971,26 +10971,26 @@ package body Sem_Ch3 is return Formal; end Make_Op_Formal; - -- Start of processing for New_Binary_Operator + -- Start of processing for New_Concatenation_Op begin - Op := Make_Defining_Operator_Symbol (Loc, Op_Name); + Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat); Set_Ekind (Op, E_Operator); Set_Scope (Op, Current_Scope); Set_Etype (Op, Typ); - Set_Homonym (Op, Get_Name_Entity_Id (Op_Name)); + Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat)); Set_Is_Immediately_Visible (Op); Set_Is_Intrinsic_Subprogram (Op); Set_Has_Completion (Op); Append_Entity (Op, Current_Scope); - Set_Name_Entity_Id (Op_Name, Op); + Set_Name_Entity_Id (Name_Op_Concat, Op); Append_Entity (Make_Op_Formal (Typ, Op), Op); Append_Entity (Make_Op_Formal (Typ, Op), Op); - end New_Binary_Operator; + end New_Concatenation_Op; ------------------------------------------- -- Ordinary_Fixed_Point_Type_Declaration -- diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 8e6e2e1..f189fe1 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -325,6 +325,16 @@ package body Sem_Elab is -- we ignore this flag. begin + -- If the call is known to be within a local Suppress Elaboration + -- pragma, nothing to check. This can happen in task bodies. + + if (Nkind (N) = N_Function_Call + or else Nkind (N) = N_Procedure_Call_Statement) + and then No_Elaboration_Check (N) + then + return; + end if; + -- Go to parent for derived subprogram, or to original subprogram -- in the case of a renaming (Alias covers both these cases) @@ -826,10 +836,41 @@ package body Sem_Elab is (N : Node_Id; Outer_Scope : Entity_Id := Empty) is - Nam : Node_Id; Ent : Entity_Id; P : Node_Id; + function Get_Called_Ent return Entity_Id; + -- Retrieve called entity. If this is a call to a protected subprogram, + -- entity is a selected component. The callable entity may be absent, + -- in which case there is no check to perform. This happens with + -- non-analyzed calls in nested generics. + + -------------------- + -- Get_Called_Ent -- + -------------------- + + function Get_Called_Ent return Entity_Id is + Nam : Node_Id; + + begin + Nam := Name (N); + + if No (Nam) then + return Empty; + + elsif Nkind (Nam) = N_Selected_Component then + return Entity (Selector_Name (Nam)); + + elsif not Is_Entity_Name (Nam) then + return Empty; + + else + return Entity (Nam); + end if; + end Get_Called_Ent; + + -- Start of processing for Check_Elab_Call + begin -- For an entry call, check relevant restriction @@ -1014,6 +1055,26 @@ package body Sem_Elab is exit; + elsif Nkind (P) = N_Task_Body then + + -- The check is deferred until Check_Task_Activation + -- but we need to capture local suppress pragmas + -- that may inhibit checks on this call. + + Ent := Get_Called_Ent; + + if No (Ent) then + return; + + elsif Elaboration_Checks_Suppressed (Current_Scope) + or else Elaboration_Checks_Suppressed (Ent) + or else Elaboration_Checks_Suppressed (Scope (Ent)) + then + Set_No_Elaboration_Check (N); + end if; + + return; + -- Static model, call is not in elaboration code, we -- never need to worry, because in the static model -- the top level caller always takes care of things. @@ -1027,25 +1088,7 @@ package body Sem_Elab is end if; end if; - -- Retrieve called entity. If this is a call to a protected subprogram, - -- the entity is a selected component. - -- The callable entity may be absent, in which case there is nothing - -- to do. This happens with non-analyzed calls in nested generics. - - Nam := Name (N); - - if No (Nam) then - return; - - elsif Nkind (Nam) = N_Selected_Component then - Ent := Entity (Selector_Name (Nam)); - - elsif not Is_Entity_Name (Nam) then - return; - - else - Ent := Entity (Nam); - end if; + Ent := Get_Called_Ent; if No (Ent) then return; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 3f734d7..f8d2278 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1764,6 +1764,15 @@ package body Sinfo is return Flag7 (N); end No_Ctrl_Actions; + function No_Elaboration_Check + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Procedure_Call_Statement); + return Flag14 (N); + end No_Elaboration_Check; + function No_Entities_Ref_In_Spec (N : Node_Id) return Boolean is begin @@ -4187,6 +4196,15 @@ package body Sinfo is Set_Flag7 (N, Val); end Set_No_Ctrl_Actions; + procedure Set_No_Elaboration_Check + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Procedure_Call_Statement); + Set_Flag14 (N, Val); + end Set_No_Elaboration_Check; + procedure Set_No_Entities_Ref_In_Spec (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 8691ab6..f176494 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1266,6 +1266,13 @@ package Sinfo is -- where the generated assignments are more initialisations than real -- assignments. + -- No_Elaboration_Check (Flag14-Sem) + -- Present in N_Function_Call and N_Procedure_Call_Statement. Indicates + -- that no elaboration check is needed on the call, because it appears + -- in the context of a local Suppress pragma. This is used on calls + -- within task bodies, where the actual elaboration checks are applied + -- after analysis, when the local scope stack is not present. + -- No_Entities_Ref_In_Spec (Flag8-Sem) -- Present in N_With_Clause nodes. Set if the with clause is on the -- package or subprogram spec where the main unit is the corresponding @@ -4043,6 +4050,7 @@ package Sinfo is -- First_Named_Actual (Node4-Sem) -- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching) -- Do_Tag_Check (Flag13-Sem) + -- No_Elaboration_Check (Flag14-Sem) -- Parameter_List_Truncated (Flag17-Sem) -- ABE_Is_Certain (Flag18-Sem) -- plus fields for expression @@ -4073,6 +4081,7 @@ package Sinfo is -- First_Named_Actual (Node4-Sem) -- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching) -- Do_Tag_Check (Flag13-Sem) + -- No_Elaboration_Check (Flag14-Sem) -- Parameter_List_Truncated (Flag17-Sem) -- ABE_Is_Certain (Flag18-Sem) -- plus fields for expression @@ -7391,6 +7400,9 @@ package Sinfo is function No_Ctrl_Actions (N : Node_Id) return Boolean; -- Flag7 + function No_Elaboration_Check + (N : Node_Id) return Boolean; -- Flag14 + function No_Entities_Ref_In_Spec (N : Node_Id) return Boolean; -- Flag8 @@ -8165,6 +8177,9 @@ package Sinfo is procedure Set_No_Ctrl_Actions (N : Node_Id; Val : Boolean := True); -- Flag7 + procedure Set_No_Elaboration_Check + (N : Node_Id; Val : Boolean := True); -- Flag14 + procedure Set_No_Entities_Ref_In_Spec (N : Node_Id; Val : Boolean := True); -- Flag8 @@ -8600,6 +8615,7 @@ package Sinfo is pragma Inline (Next_Rep_Item); pragma Inline (Next_Use_Clause); pragma Inline (No_Ctrl_Actions); + pragma Inline (No_Elaboration_Check); pragma Inline (No_Entities_Ref_In_Spec); pragma Inline (No_Initialization); pragma Inline (No_Truncation); @@ -8854,6 +8870,7 @@ package Sinfo is pragma Inline (Set_Next_Named_Actual); pragma Inline (Set_Next_Use_Clause); pragma Inline (Set_No_Ctrl_Actions); + pragma Inline (Set_No_Elaboration_Check); pragma Inline (Set_No_Entities_Ref_In_Spec); pragma Inline (Set_No_Initialization); pragma Inline (Set_No_Truncation); diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index 2ad21be..3ab47c7 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -1111,7 +1111,7 @@ package body Sinput is function Source_First (S : SFI) return Source_Ptr is begin if S = Internal_Source_File then - return Internal_Source_Ptr'First; + return Internal_Source'First; else return Source_File.Table (S).Source_First; end if; @@ -1120,7 +1120,7 @@ package body Sinput is function Source_Last (S : SFI) return Source_Ptr is begin if S = Internal_Source_File then - return Internal_Source_Ptr'Last; + return Internal_Source'Last; else return Source_File.Table (S).Source_Last; end if;