OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2004-06-11  Vincent Celier  <celier@gnat.com>

	* mlib-tgt-vms-alpha.adb (Build_Dynamic_Library): Issue switch -R to
	gnatsym, when symbol policy is Restricted.

	* mlib-tgt-vms-ia64.adb (Build_Dynamic_Library): Issue switch -R to
	gnatsym, when symbol policy is Restricted.

	* symbols-vms-alpha.adb (Initialize): When symbol policy is Restricted,
	read the symbol file.
	(Finalize): Fail in symbol policy Restricted if a symbol in the original
	symbol file is not in the object files. Do not create a new symbol file
	when symbol policy is Restricted.

	* gnatbind.adb (Gnatbind): Initialize Snames, because Snames is used
	in Scng.

	* gnatsym.adb (Parse_Vmd_Line): Process new switch -R for symbol policy
	Restricted.
	(Usage): Line for new switch -R

	* make.adb (Initialize): When the platform is not VMS, add the
	directory where gnatmake is invoked in the front of the path, if
	gnatmake is invoked with directory information.  Change the Scan_Args
	while loop to a for loop.
	(Recursive_Compute_Depth): Remove parameter Visited. Improve efficiency:
	if Depth is equal or greater than the proposed depth, there is nothing
	to do.
	(Initialize): Call Recursive_Compute_Depth with initial Depth equal to 1
	instead of 0.

	* prj.ads: Add new symbol policy Restricted.

	* prj-dect.adb (Parse_Case_Construction): Call End_Case_Construction
	with the new parameters Check_All_Labels and Case_Location.

	* prj-nmsc.adb (Ada_Check): Process new symbol policy Restricted
	(Library_Symbol_File needs to be defined).

	* prj-strt.adb (End_Case_Construction): New parameters Check_All_Labels
	and Case_Location If Check_All_Labels is True, check that all values of
	the string type are used, and output warning(s) if they are not.

	* prj-strt.ads (End_Case_Construction): New parameters Check_All_Labels
	and Case_Location.

	* gnat_ugn.texi: Reorder subclauses in menus "Switches for gcc"

	* gnat_ugn.texi: Update documentation about the library directory in
	Library Projects.

	* makegpr.adb (Display_Command): In verbose mode, also display the
	value of the CPATH env var, when the compiler is gcc.
	(Initialize): Change the Scan_Args while loop to a for loop
	(Compile_Individual_Sources): Change directory to object directory
	before compilations.

	* symbols.ads: New symbol policy Restricted.

2004-06-11  Olivier Hainque  <hainque@act-europe.fr>

	* a-except.adb (Raise_After_Setup family): Remove. The responsibility
	is now taken care of internally in the Exception_Propagation package
	and does not require clients assistance any more.

	* a-exexpr.adb (Is_Setup_And_Not_Propagated,
	Set_Setup_And_Not_Propagated, and Clear_Setup_And_Not_Propagated): New
	functions. Helpers to maintain a predicate required in the handling of
	occurrence transfer between tasks.
	This is now handled internally and does not require clients assistance
	for the setup/propagate separation anymore.
	(Setup_Exception, Propagate_Exception): Simplify the Private_Data
	allocation strategy, handle the Setup_And_Not_Propagated predicate and
	document.

	* s-taenca.adb (Check_Exception): Use raise_with_msg instead of
	raise_after_setup, now that everything is handled internally within the
	setup/propagation engine.

2004-06-11  Hristian Kirtchev  <kirtchev@gnat.com>

	* exp_ch6.adb (Expand_Inlined_Call): Add function Formal_Is_Used_Once.
	Add additional conditions for the case of an actual being a simple
	name or literal. Improve inlining by preventing the generation
	of temporaries with a short lifetime (one use).

2004-06-11  Hristian Kirtchev  <kirtchev@gnat.com>

	PR ada/15587

	* einfo.ads: Minor comment updates for Has_Completion and
	E_Constant list of flags.

	* sem_ch3.adb (Analyze_Object_Declaration): Full constant declarations
	and constant redeclarations now set the Has_Completion flag of their
	defining identifiers.

	* sem_ch7.adb (Analyze_Package_Spec): Add procedure
	Inspect_Deferred_Constant_Completion.
	Used to detect private deferred constants that have not been completed
	either by a constant redeclaration or pragma Import. Emits error message
	"constant declaration requires initialization expression".

	* sem_prag.adb (Process_Import_Or_Interface): An Import pragma now
	completes a deferred constant.

2004-06-11  Geert Bosch  <bosch@gnat.com>

	* eval_fat.adb (Decompose_Int): Fix rounding of negative numbers.

	* s-fatgen.adb (Gradual_Scaling): Correct off-by-one error in
	calculating exponent for scaling denormal numbers.
	(Leading_Part): Properly raise Constraint_Error for zero or negative
	Adjustment.
	(Remainder): Properly raise Constraint_Error for zero divisor.

2004-06-11  Thomas Quinot  <quinot@act-europe.fr>

	* sem_util.adb: Minor reformatting.

	* exp_ch2.adb (Expand_Entry_Parameter): Generate an explicit
	dereference when accessing the entry parameter record.
	(Check_Array_Type): Always check for possible implicit dereference.
	(maybe_implicit_dereference): Rename to check_no_implicit_derefence.
	Abort if a pointer is still present (denoting that an implicit
	dereference was left in the tree by the front-end).

	* sem_attr.adb (Expand_Entry_Parameter): Generate an explicit
	dereference when accessing the entry parameter record.
	(Check_Array_Type): Always check for possible implicit dereference.
	(maybe_implicit_dereference): Rename to check_no_implicit_derefence.
	Abort if a pointer is still present (denoting that an implicit
	dereference was left in the tree by the front-end).

2004-06-11  Emmanuel Briot  <briot@act-europe.fr>

	* g-debpoo.adb (Deallocate, Dereference): Add prefix "error:" to error
	message, like the compiler itself does. Easier to parse the output.

	* g-debpoo.ads: (Allocate, Deallocate, Dereference): Add comments.

	* gnat_ugn.texi (gnatxref, gnatfind): Clarify that source names should
	be base names, and not includes directories.

2004-06-11  Arnaud Charlet  <charlet@act-europe.fr>

	* Makefile.generic ($(EXEC)): Depend on $(OBJECTS), not $(OBJ_FILES),
	so that dependencies are properly taken into account by make.

2004-06-11  Arnaud Charlet  <charlet@act-europe.fr>

	PR ada/15622
	* s-unstyp.ads, s-maccod.ads, sem_ch8.adb, s-auxdec.ads,
	exp_intr.adb, s-auxdec-vms_64.ads: Fix typo: instrinsic -> intrinsic

2004-06-11  Jerome Guitton  <guitton@act-europe.fr>

	* Makefile.in (install-gnatlib): install target-specific run-time files.

	* Make-lang.in: Remove obsolete targets.

2004-06-11  Ed Schonberg  <schonberg@gnat.com>

	* par-ch12.adb (P_Generic): Add scope before analyzing subprogram
	specification, to catch misuses of program unit names.

	* sem_res.adb (Resolve_Type_Conversion): Do not emit warnings on
	superfluous conversions in an instance.

2004-06-11  Ed Schonberg  <schonberg@gnat.com>

	PR ada/15403

	* sem_ch12.adb (Save_References): If operator node has been folded to
	enumeration literal, associated_node must be discarded.

2004-06-11  Jose Ruiz  <ruiz@act-europe.fr>

	* s-stchop-vxworks.adb: Add required pragma Convention to
	Task_Descriptor because it is updated by a C function.

From-SVN: r82973
This commit is contained in:
Arnaud Charlet 2004-06-11 12:47:39 +02:00
parent d1ee83813d
commit 5453d5bde8
43 changed files with 843 additions and 297 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

181
gcc/ada/ChangeLog
View File

@ -1,3 +1,184 @@
2004-06-11 Vincent Celier <celier@gnat.com>
* mlib-tgt-vms-alpha.adb (Build_Dynamic_Library): Issue switch -R to
gnatsym, when symbol policy is Restricted.
* mlib-tgt-vms-ia64.adb (Build_Dynamic_Library): Issue switch -R to
gnatsym, when symbol policy is Restricted.
* symbols-vms-alpha.adb (Initialize): When symbol policy is Restricted,
read the symbol file.
(Finalize): Fail in symbol policy Restricted if a symbol in the original
symbol file is not in the object files. Do not create a new symbol file
when symbol policy is Restricted.
* gnatbind.adb (Gnatbind): Initialize Snames, because Snames is used
in Scng.
* gnatsym.adb (Parse_Vmd_Line): Process new switch -R for symbol policy
Restricted.
(Usage): Line for new switch -R
* make.adb (Initialize): When the platform is not VMS, add the
directory where gnatmake is invoked in the front of the path, if
gnatmake is invoked with directory information. Change the Scan_Args
while loop to a for loop.
(Recursive_Compute_Depth): Remove parameter Visited. Improve efficiency:
if Depth is equal or greater than the proposed depth, there is nothing
to do.
(Initialize): Call Recursive_Compute_Depth with initial Depth equal to 1
instead of 0.
* prj.ads: Add new symbol policy Restricted.
* prj-dect.adb (Parse_Case_Construction): Call End_Case_Construction
with the new parameters Check_All_Labels and Case_Location.
* prj-nmsc.adb (Ada_Check): Process new symbol policy Restricted
(Library_Symbol_File needs to be defined).
* prj-strt.adb (End_Case_Construction): New parameters Check_All_Labels
and Case_Location If Check_All_Labels is True, check that all values of
the string type are used, and output warning(s) if they are not.
* prj-strt.ads (End_Case_Construction): New parameters Check_All_Labels
and Case_Location.
* gnat_ugn.texi: Reorder subclauses in menus "Switches for gcc"
* gnat_ugn.texi: Update documentation about the library directory in
Library Projects.
* makegpr.adb (Display_Command): In verbose mode, also display the
value of the CPATH env var, when the compiler is gcc.
(Initialize): Change the Scan_Args while loop to a for loop
(Compile_Individual_Sources): Change directory to object directory
before compilations.
* symbols.ads: New symbol policy Restricted.
2004-06-11 Olivier Hainque <hainque@act-europe.fr>
* a-except.adb (Raise_After_Setup family): Remove. The responsibility
is now taken care of internally in the Exception_Propagation package
and does not require clients assistance any more.
* a-exexpr.adb (Is_Setup_And_Not_Propagated,
Set_Setup_And_Not_Propagated, and Clear_Setup_And_Not_Propagated): New
functions. Helpers to maintain a predicate required in the handling of
occurrence transfer between tasks.
This is now handled internally and does not require clients assistance
for the setup/propagate separation anymore.
(Setup_Exception, Propagate_Exception): Simplify the Private_Data
allocation strategy, handle the Setup_And_Not_Propagated predicate and
document.
* s-taenca.adb (Check_Exception): Use raise_with_msg instead of
raise_after_setup, now that everything is handled internally within the
setup/propagation engine.
2004-06-11 Hristian Kirtchev <kirtchev@gnat.com>
* exp_ch6.adb (Expand_Inlined_Call): Add function Formal_Is_Used_Once.
Add additional conditions for the case of an actual being a simple
name or literal. Improve inlining by preventing the generation
of temporaries with a short lifetime (one use).
2004-06-11 Hristian Kirtchev <kirtchev@gnat.com>
PR ada/15587
* einfo.ads: Minor comment updates for Has_Completion and
E_Constant list of flags.
* sem_ch3.adb (Analyze_Object_Declaration): Full constant declarations
and constant redeclarations now set the Has_Completion flag of their
defining identifiers.
* sem_ch7.adb (Analyze_Package_Spec): Add procedure
Inspect_Deferred_Constant_Completion.
Used to detect private deferred constants that have not been completed
either by a constant redeclaration or pragma Import. Emits error message
"constant declaration requires initialization expression".
* sem_prag.adb (Process_Import_Or_Interface): An Import pragma now
completes a deferred constant.
2004-06-11 Geert Bosch <bosch@gnat.com>
* eval_fat.adb (Decompose_Int): Fix rounding of negative numbers.
* s-fatgen.adb (Gradual_Scaling): Correct off-by-one error in
calculating exponent for scaling denormal numbers.
(Leading_Part): Properly raise Constraint_Error for zero or negative
Adjustment.
(Remainder): Properly raise Constraint_Error for zero divisor.
2004-06-11 Thomas Quinot <quinot@act-europe.fr>
* sem_util.adb: Minor reformatting.
* exp_ch2.adb (Expand_Entry_Parameter): Generate an explicit
dereference when accessing the entry parameter record.
(Check_Array_Type): Always check for possible implicit dereference.
(maybe_implicit_dereference): Rename to check_no_implicit_derefence.
Abort if a pointer is still present (denoting that an implicit
dereference was left in the tree by the front-end).
* sem_attr.adb (Expand_Entry_Parameter): Generate an explicit
dereference when accessing the entry parameter record.
(Check_Array_Type): Always check for possible implicit dereference.
(maybe_implicit_dereference): Rename to check_no_implicit_derefence.
Abort if a pointer is still present (denoting that an implicit
dereference was left in the tree by the front-end).
2004-06-11 Emmanuel Briot <briot@act-europe.fr>
* g-debpoo.adb (Deallocate, Dereference): Add prefix "error:" to error
message, like the compiler itself does. Easier to parse the output.
* g-debpoo.ads: (Allocate, Deallocate, Dereference): Add comments.
* gnat_ugn.texi (gnatxref, gnatfind): Clarify that source names should
be base names, and not includes directories.
2004-06-11 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.generic ($(EXEC)): Depend on $(OBJECTS), not $(OBJ_FILES),
so that dependencies are properly taken into account by make.
2004-06-11 Arnaud Charlet <charlet@act-europe.fr>
PR ada/15622
* s-unstyp.ads, s-maccod.ads, sem_ch8.adb, s-auxdec.ads,
exp_intr.adb, s-auxdec-vms_64.ads: Fix typo: instrinsic -> intrinsic
2004-06-11 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in (install-gnatlib): install target-specific run-time files.
* Make-lang.in: Remove obsolete targets.
2004-06-11 Ed Schonberg <schonberg@gnat.com>
* par-ch12.adb (P_Generic): Add scope before analyzing subprogram
specification, to catch misuses of program unit names.
* sem_res.adb (Resolve_Type_Conversion): Do not emit warnings on
superfluous conversions in an instance.
2004-06-11 Ed Schonberg <schonberg@gnat.com>
PR ada/15403
* sem_ch12.adb (Save_References): If operator node has been folded to
enumeration literal, associated_node must be discarded.
2004-06-11 Jose Ruiz <ruiz@act-europe.fr>
* s-stchop-vxworks.adb: Add required pragma Convention to
Task_Descriptor because it is updated by a C function.
2004-06-08 Arnaud Charlet <charlet@act-europe.fr>
PR ada/15568

6
gcc/ada/Make-lang.in
View File

@ -279,12 +279,6 @@ gnatbind$(exeext): ada/b_gnatb.o $(CONFIG_H) $(GNATBIND_OBJS)
$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ ada/b_gnatb.o $(GNATBIND_OBJS) \
$(LIBS) $(SYSLIBS)
install-rts-zfp: force
$(MAKE) -C ada $(FLAGS_TO_PASS) install-rts RTS_NAME=zfp
install-rts-ravenscar: force
$(MAKE) -C ada $(FLAGS_TO_PASS) install-rts RTS_NAME=ravenscar
# use cross-gcc
gnat-cross: force
make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp" \

2
gcc/ada/Makefile.generic
View File

@ -344,7 +344,7 @@ link:
else
link: $(EXEC_DIR)/$(EXEC) archive-objects
$(EXEC_DIR)/$(EXEC): $(OBJ_FILES)
$(EXEC_DIR)/$(EXEC): $(OBJECTS)
@$(display) $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS) $(FLDFLAGS)
@$(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS) $(FLDFLAGS)
endif

3
gcc/ada/Makefile.in
View File

@ -1622,6 +1622,9 @@ install-gnatlib: ../stamp-gnatlib
$(INSTALL_DATA) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
$(RANLIB) $(DESTDIR)$(ADA_RTL_OBJ_DIR)/$$file; \
done
-$(foreach file, $(EXTRA_ADALIB_FILES), \
$(INSTALL_DATA_DATE) rts/$(file) $(DESTDIR)$(ADA_RTL_OBJ_DIR) && \
) true
# Install the shared libraries, if any, using $(INSTALL) instead
# of $(INSTALL_DATA). The latter may force a mode inappropriate
# for shared libraries on some targets, e.g. on HP-UX where the x

34
gcc/ada/a-except.adb
View File

@ -331,20 +331,6 @@ package body Ada.Exceptions is
-- exception occurrence referenced by the Current_Excep in the TSD.
-- Abort is deferred before the raise call.
procedure Raise_With_Msg (E : Exception_Id; Setup : Boolean);
pragma No_Return (Raise_With_Msg);
-- Similar to above, with an extra parameter to indicate wether
-- Setup_Exception has been called already.
procedure Raise_After_Setup (E : Exception_Id);
pragma No_Return (Raise_After_Setup);
pragma Export (C, Raise_After_Setup, "__gnat_raise_after_setup");
-- Wrapper to Raise_With_Msg and Setup set to True.
--
-- This is called by System.Tasking.Entry_Calls.Check_Exception when an
-- exception has occured during an entry call. The exception to propagate
-- has been setup and initialized via Transfer_Occurrence in this case.
procedure Raise_With_Location_And_Msg
(E : Exception_Id;
F : Big_String_Ptr;
@ -993,13 +979,11 @@ package body Ada.Exceptions is
-- Raise_With_Msg --
--------------------
procedure Raise_With_Msg (E : Exception_Id; Setup : Boolean) is
procedure Raise_With_Msg (E : Exception_Id) is
Excep : constant EOA := Get_Current_Excep.all;
begin
if not Setup then
Exception_Propagation.Setup_Exception (Excep, Excep);
end if;
Exception_Propagation.Setup_Exception (Excep, Excep);
Excep.Exception_Raised := False;
Excep.Id := E;
@ -1010,20 +994,6 @@ package body Ada.Exceptions is
Raise_Current_Excep (E);
end Raise_With_Msg;
procedure Raise_With_Msg (E : Exception_Id) is
begin
Raise_With_Msg (E, Setup => False);
end Raise_With_Msg;
-----------------------
-- Raise_After_Setup --
-----------------------
procedure Raise_After_Setup (E : Exception_Id) is
begin
Raise_With_Msg (E, Setup => True);
end Raise_After_Setup;
--------------------------------------
-- Calls to Run-Time Check Routines --
--------------------------------------

174
gcc/ada/a-exexpr.adb
View File

@ -36,6 +36,8 @@ with Interfaces;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with System.Storage_Elements; use System.Storage_Elements;
pragma Warnings (Off);
-- Since several constructs give warnings in 3.14a1, including unreferenced
-- variables and pragma Unreferenced itself.
@ -170,22 +172,6 @@ package body Exception_Propagation is
procedure Free is new Unchecked_Deallocation
(Exception_Occurrence, EOA);
function Remove
(Top : EOA;
Excep : GNAT_GCC_Exception_Access) return Boolean;
-- Remove Excep from the stack starting at Top.
-- Return True if Excep was found and removed, false otherwise.
-- Hooks called when entering/leaving an exception handler for a given
-- occurrence, aimed at handling the stack of active occurrences. The
-- calls are generated by gigi in tree_transform/N_Exception_Handler.
procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
pragma Export (C, Begin_Handler, "__gnat_begin_handler");
procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
pragma Export (C, End_Handler, "__gnat_end_handler");
function CleanupUnwind_Handler
(UW_Version : Integer;
UW_Phases : Unwind_Action;
@ -211,6 +197,41 @@ package body Exception_Propagation is
UW_Argument : System.Address);
pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
--------------------------------------------
-- Occurrence stack management facilities --
--------------------------------------------
function Remove
(Top : EOA;
Excep : GNAT_GCC_Exception_Access) return Boolean;
-- Remove Excep from the stack starting at Top.
-- Return True if Excep was found and removed, false otherwise.
-- Hooks called when entering/leaving an exception handler for a given
-- occurrence, aimed at handling the stack of active occurrences. The
-- calls are generated by gigi in tree_transform/N_Exception_Handler.
procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
pragma Export (C, Begin_Handler, "__gnat_begin_handler");
procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
pragma Export (C, End_Handler, "__gnat_end_handler");
-- To handle the case of a task "transferring" an exception occurrence to
-- another task, for instance via Exceptional_Complete_Rendezvous, we need
-- to be able to identify occurrences which have been Setup and not yet
-- Propagated. We hijack one of the common header fields for that purpose,
-- setting it to a special key value during the setup process, clearing it
-- at the very beginning of the propagation phase, and expecting it never
-- to be reset to the special value later on.
Setup_Key : constant := 16#DEAD_BEEF#;
function Is_Setup_And_Not_Propagated (E : EOA) return Boolean;
procedure Set_Setup_And_Not_Propagated (E : EOA);
procedure Clear_Setup_And_Not_Propagated (E : EOA);
------------------------------------------------------------
-- Accessors to basic components of a GNAT exception data --
------------------------------------------------------------
@ -316,11 +337,48 @@ package body Exception_Propagation is
return URC_NO_REASON;
end CleanupUnwind_Handler;
---------------------------------
-- Is_Setup_And_Not_Propagated --
---------------------------------
function Is_Setup_And_Not_Propagated (E : EOA) return Boolean is
GCC_E : GNAT_GCC_Exception_Access :=
To_GNAT_GCC_Exception (E.Private_Data);
begin
return GCC_E /= null and then GCC_E.Header.Private1 = Setup_Key;
end Is_Setup_And_Not_Propagated;
------------------------------------
-- Clear_Setup_And_Not_Propagated --
------------------------------------
procedure Clear_Setup_And_Not_Propagated (E : EOA) is
GCC_E : GNAT_GCC_Exception_Access :=
To_GNAT_GCC_Exception (E.Private_Data);
begin
pragma Assert (GCC_E /= null);
GCC_E.Header.Private1 := 0;
end Clear_Setup_And_Not_Propagated;
----------------------------------
-- Set_Setup_And_Not_Propagated --
----------------------------------
procedure Set_Setup_And_Not_Propagated (E : EOA) is
GCC_E : GNAT_GCC_Exception_Access :=
To_GNAT_GCC_Exception (E.Private_Data);
begin
pragma Assert (GCC_E /= null);
GCC_E.Header.Private1 := Setup_Key;
end Set_Setup_And_Not_Propagated;
---------------------
-- Setup_Exception --
---------------------
-- Push the current exception occurrence on the stack before overriding it.
-- In this implementation of the exception propagation scheme, this
-- subprogram should be understood as: Setup the exception occurrence
-- stack headed at Current for a forthcoming raise of Excep.
procedure Setup_Exception
(Excep : EOA;
@ -331,38 +389,62 @@ package body Exception_Propagation is
Next : EOA;
GCC_Exception : GNAT_GCC_Exception_Access;
-- Note that we make no use of the Reraised indication at this point.
-- The information is still passed around just in case of future needs,
-- since we've already switched between using/not-using it a number of
-- times.
begin
-- If the current exception is not live, the stack is empty and there
-- is nothing to do. Note that the stack always appears empty for
-- mechanisms that do not require one. For the mechanism we implement
-- in this unit, the initial Private_Data allocation for an occurrence
-- is issued by Propagate_Exception.
if Top.Private_Data = System.Null_Address then
-- The exception Excep is soon to be propagated, and the storage used
-- for that will be the occurrence statically allocated for the current
-- thread. This storage might currently be used for a still active
-- occurrence, so we need to push it on the thread's occurrence stack
-- (headed at that static occurrence) before it gets clobbered.
-- What we do here is to trigger this push when need be, and allocate a
-- Private_Data block for the forthcoming Propagation.
-- Some tasking rendez-vous attempts lead to an occurrence transfer
-- from the server to the client (see Exceptional_Complete_Rendezvous).
-- In those cases Setup is called twice for the very same occurrence
-- before it gets propagated: once from the server, because this is
-- where the occurrence contents is elaborated and known, and then
-- once from the client when it detects the case and actually raises
-- the exception in its own context.
-- The Is_Setup_And_Not_Propagated predicate tells us when we are in
-- the second call to Setup for a Transferred occurrence, and there is
-- nothing to be done here in this situation. This predicate cannot be
-- True if we are dealing with a Reraise, and we may even be called
-- with a raw uninitialized Excep occurrence in this case so we should
-- not check anyway. Observe the front-end expansion for a "raise;" to
-- see that happening. We get a local occurrence and a direct call to
-- Save_Occurrence without the intermediate init-proc call.
if not Reraised and then Is_Setup_And_Not_Propagated (Excep) then
return;
end if;
-- Shift the contents of the Top of the stack in a freshly allocated
-- entry, which leaves the room in the fixed Top entry available for the
-- occurrence about to be propagated.
Next := new Exception_Occurrence;
Save_Occurrence_And_Private (Next.all, Top.all);
-- Allocate Private_Data for the occurrence about to be propagated
-- and link everything together.
-- Allocate what will be the Private_Data block for the exception
-- to be propagated.
GCC_Exception := new GNAT_GCC_Exception;
GCC_Exception.Next_Exception := Next;
-- If the Top of the occurrence stack is not currently used for an
-- active exception (the stack is empty) we just need to setup the
-- Private_Data pointer.
-- Otherwise, we also need to shift the contents of the Top of the
-- stack in a freshly allocated entry and link everything together.
if Top.Private_Data /= System.Null_Address then
Next := new Exception_Occurrence;
Save_Occurrence_And_Private (Next.all, Top.all);
GCC_Exception.Next_Exception := Next;
Top.Private_Data := GCC_Exception.all'Address;
end if;
Top.Private_Data := GCC_Exception.all'Address;
Set_Setup_And_Not_Propagated (Top);
end Setup_Exception;
-------------------
@ -403,16 +485,16 @@ package body Exception_Propagation is
GCC_Exception : GNAT_GCC_Exception_Access;
begin
if Excep.Private_Data = System.Null_Address then
GCC_Exception := new GNAT_GCC_Exception;
Excep.Private_Data := GCC_Exception.all'Address;
else
GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data);
end if;
pragma Assert (Excep.Private_Data /= System.Null_Address);
-- Fill in the useful flags for the personality routine called for each
-- Retrieve the Private_Data for this occurrence and set the useful
-- flags for the personality routine, which will be called for each
-- frame via Unwind_RaiseException below.
GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data);
Clear_Setup_And_Not_Propagated (Excep);
GCC_Exception.Id := Excep.Id;
GCC_Exception.N_Cleanups_To_Trigger := 0;

5
gcc/ada/einfo.ads
View File

@ -1250,8 +1250,8 @@ package Einfo is
-- Has_Completion (Flag26)
-- Present in all entities that require a completion (functions,
-- procedures, private types, limited private types, incomplete types,
-- and packages that require a body). Set if the completion has been
-- encountered and analyzed.
-- constants and packages that require a body). The flag is set if the
-- completion has been encountered and analyzed.
-- Has_Completion_In_Body (Flag71)
-- Present in "Taft amendment types" that is to say incomplete types
@ -4142,6 +4142,7 @@ package Einfo is
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
-- Has_Completion (Flag26) (constants only)
-- Has_Size_Clause (Flag29)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)

23
gcc/ada/eval_fat.adb
View File

@ -382,14 +382,10 @@ package body Eval_Fat is
Calculate_Fraction_And_Exponent : begin
Uintp_Mark := Mark;
-- Put back sign before applying the rounding.
if UR_Is_Negative (X) then
Fraction := -Fraction;
end if;
-- Determine correct rounding based on the remainder
-- which is in N and the divisor D.
-- which is in N and the divisor D. The rounding is
-- performed on the absolute value of X, so Ceiling
-- and Floor need to check for the sign of X explicitly.
case Mode is
when Round_Even =>
@ -416,11 +412,14 @@ package body Eval_Fat is
end if;
when Ceiling =>
if N > Uint_0 then
if N > Uint_0 and then not UR_Is_Negative (X) then
Fraction := Fraction + 1;
end if;
when Floor => null;
when Floor =>
if N > Uint_0 and then UR_Is_Negative (X) then
Fraction := Fraction + 1;
end if;
end case;
-- The result must be normalized to [1.0/Radix, 1.0),
@ -431,6 +430,12 @@ package body Eval_Fat is
Exponent := Exponent + 1;
end if;
-- Put back sign after applying the rounding.
if UR_Is_Negative (X) then
Fraction := -Fraction;
end if;
Release_And_Save (Uintp_Mark, Fraction, Exponent);
end Calculate_Fraction_And_Exponent;
end Decompose_Int;

5
gcc/ada/exp_ch2.adb
View File

@ -519,8 +519,9 @@ package body Exp_Ch2 is
P_Comp_Ref :=
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Parm_Type,
New_Reference_To (Addr_Ent, Loc)),
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (Parm_Type,
New_Reference_To (Addr_Ent, Loc))),
Selector_Name =>
New_Reference_To (Entry_Component (Ent_Formal), Loc));

66
gcc/ada/exp_ch6.adb
View File

@ -2278,6 +2278,9 @@ package body Exp_Ch6 is
-- If procedure body has no local variables, inline body without
-- creating block, otherwise rewrite call with block.
function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
-- Determine whether a formal parameter is used only once in Orig_Bod
---------------------
-- Make_Exit_Label --
---------------------
@ -2512,6 +2515,62 @@ package body Exp_Ch6 is
end if;
end Rewrite_Procedure_Call;
-------------------------
-- Formal_Is_Used_Once --
------------------------
function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
Use_Counter : Int := 0;
function Count_Uses (N : Node_Id) return Traverse_Result;
-- Traverse the tree and count the uses of the formal parameter.
-- In this case, for optimization purposes, we do not need to
-- continue the traversal once more than one use is encountered.
function Count_Uses (N : Node_Id) return Traverse_Result is
begin
-- The original node is an identifier
if Nkind (N) = N_Identifier
and then Present (Entity (N))
-- The original node's entity points to the one in the
-- copied body.
and then Nkind (Entity (N)) = N_Identifier
and then Present (Entity (Entity (N)))
-- The entity of the copied node is the formal parameter
and then Entity (Entity (N)) = Formal
then
Use_Counter := Use_Counter + 1;
if Use_Counter > 1 then
-- Denote more than one use and abandon the traversal
Use_Counter := 2;
return Abandon;
end if;
end if;
return OK;
end Count_Uses;
procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
-- Start of processing for Formal_Is_Used_Once
begin
Count_Formal_Uses (Orig_Bod);
return Use_Counter = 1;
end Formal_Is_Used_Once;
-- Start of processing for Expand_Inlined_Call
begin
@ -2608,6 +2667,13 @@ package body Exp_Ch6 is
(not Is_Scalar_Type (Etype (A))
or else Ekind (Entity (A)) = E_Enumeration_Literal))
-- When the actual is an identifier and the corresponding formal
-- is used only once in the original body, the formal can be
-- substituted directly with the actual parameter.
or else (Nkind (A) = N_Identifier
and then Formal_Is_Used_Once (F))
or else Nkind (A) = N_Real_Literal
or else Nkind (A) = N_Integer_Literal
or else Nkind (A) = N_Character_Literal

2
gcc/ada/exp_intr.adb
View File

@ -72,7 +72,7 @@ package body Exp_Intr is
procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind);
-- Expand an intrinsic shift operation, N and E are from the call to
-- Expand_Instrinsic_Call (call node and subprogram spec entity) and
-- Expand_Intrinsic_Call (call node and subprogram spec entity) and
-- K is the kind for the shift node
procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id);

8
gcc/ada/g-debpoo.adb
View File

@ -1095,7 +1095,7 @@ package body GNAT.Debug_Pools is
if Pool.Raise_Exceptions then
raise Freeing_Not_Allocated_Storage;
else
Put ("Freeing not allocated storage, at ");
Put ("error: Freeing not allocated storage, at ");
Put_Line (Pool.Stack_Trace_Depth, null,
Deallocate_Label'Address,
Code_Address_For_Deallocate_End);
@ -1106,7 +1106,7 @@ package body GNAT.Debug_Pools is
if Pool.Raise_Exceptions then
raise Freeing_Deallocated_Storage;
else
Put ("Freeing already deallocated storage, at ");
Put ("error: Freeing already deallocated storage, at ");
Put_Line (Pool.Stack_Trace_Depth, null,
Deallocate_Label'Address,
Code_Address_For_Deallocate_End);
@ -1225,7 +1225,7 @@ package body GNAT.Debug_Pools is
if Pool.Raise_Exceptions then
raise Accessing_Not_Allocated_Storage;
else
Put ("Accessing not allocated storage, at ");
Put ("error: Accessing not allocated storage, at ");
Put_Line (Pool.Stack_Trace_Depth, null,
Dereference_Label'Address,
Code_Address_For_Dereference_End);
@ -1238,7 +1238,7 @@ package body GNAT.Debug_Pools is
if Pool.Raise_Exceptions then
raise Accessing_Deallocated_Storage;
else
Put ("Accessing deallocated storage, at ");
Put ("error: Accessing deallocated storage, at ");
Put_Line
(Pool.Stack_Trace_Depth, null,
Dereference_Label'Address,

17
gcc/ada/g-debpoo.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -249,20 +249,35 @@ private
Storage_Address : out Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count);
-- Allocate a new chunk of memory, and set it up so that the debug pool
-- can check accesses to its data, and report incorrect access later on.
-- The parameters have the same semantics as defined in the ARM95.
procedure Deallocate
(Pool : in out Debug_Pool;
Storage_Address : Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count);
-- Mark a block of memory as invalid. It might not be physically removed
-- immediately, depending on the setup of the debug pool, so that checks
-- are still possible.
-- The parameters have the same semantics as defined in the ARM95.
function Storage_Size (Pool : Debug_Pool) return SSC;
-- Return the maximal size of data that can be allocated through Pool.
-- Since Pool uses the malloc() system call, all the memory is accessible
-- through the pool
procedure Dereference
(Pool : in out Debug_Pool;
Storage_Address : System.Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count);
-- Check whether a derefence statement is valid, ie whether the pointer
-- was allocated through Pool. As documented above, errors will be
-- reported either by a special error message or an exception, depending
-- on the setup of the storage pool.
-- The parameters have the same semantics as defined in the ARM95.
type Byte_Count is mod System.Max_Binary_Modulus;
-- Type used for maintaining byte counts, needs to be large enough

14
gcc/ada/gnat_ugn.texi
View File

@ -280,10 +280,10 @@ Switches for gcc
* Output and Error Message Control::
* Warning Message Control::
* Debugging and Assertion Control::
* Run-Time Checks::
* Stack Overflow Checking::
* Validity Checking::
* Style Checking::
* Run-Time Checks::
* Stack Overflow Checking::
* Using gcc for Syntax Checking::
* Using gcc for Semantic Checking::
* Compiling Ada 83 Programs::
@ -3631,10 +3631,10 @@ describe the switches in more detail in functionally grouped sections.
* Output and Error Message Control::
* Warning Message Control::
* Debugging and Assertion Control::
* Run-Time Checks::
* Stack Overflow Checking::
* Validity Checking::
* Style Checking::
* Run-Time Checks::
* Stack Overflow Checking::
* Using gcc for Syntax Checking::
* Using gcc for Semantic Checking::
* Compiling Ada 83 Programs::
@ -12435,6 +12435,8 @@ The @code{Library_Dir} attribute has a string value that designates the path
(absolute or relative) of the directory where the library will reside.
It must designate an existing directory, and this directory must be
different from the project's object directory. It also needs to be writable.
The directory should only be used for one library; the reason is that all
files contained in this directory may be deleted by the Project Manager.
If both @code{Library_Name} and @code{Library_Dir} are specified and
are legal, then the project file defines a library project. The optional
@ -13758,6 +13760,10 @@ specifying @file{source*.adb} is the same as giving every file in the current
directory whose name starts with @file{source} and whose extension is
@file{adb}.
You shouldn't specify any directory name, just base names. @command{gnatxref}
and @command{gnatfind} will be able to locate these files by themselves using
the source path. If you specify directories, no result is produced.
@end table
@noindent

2
gcc/ada/gnatbind.adb
View File

@ -43,6 +43,7 @@ with Osint; use Osint;
with Osint.B; use Osint.B;
with Output; use Output;
with Rident; use Rident;
with Snames;
with Switch; use Switch;
with Switch.B; use Switch.B;
with Targparm; use Targparm;
@ -444,6 +445,7 @@ begin
Csets.Initialize;
Namet.Initialize;
Snames.Initialize;
-- Acquire target parameters

10
gcc/ada/gnatsym.adb
View File

@ -124,7 +124,7 @@ procedure Gnatsym is
procedure Parse_Cmd_Line is
begin
loop
case GNAT.Command_Line.Getopt ("c C q r: s: v V:") is
case GNAT.Command_Line.Getopt ("c C q r: R s: v V:") is
when ASCII.NUL =>
exit;
@ -141,6 +141,9 @@ procedure Gnatsym is
Reference_Symbol_File_Name :=
new String'(GNAT.Command_Line.Parameter);
when 'R' =>
Symbol_Policy := Restricted;
when 's' =>
Symbol_File_Name := new String'(GNAT.Command_Line.Parameter);
@ -183,10 +186,11 @@ procedure Gnatsym is
begin
Write_Line ("gnatsym [options] object_file {object_file}");
Write_Eol;
Write_Line (" -c Compliant policy");
Write_Line (" -C Controlled policy");
Write_Line (" -c Compliant symbol policy");
Write_Line (" -C Controlled symbol policy");
Write_Line (" -q Quiet mode");
Write_Line (" -r<ref> Reference symbol file name");
Write_Line (" -R Restricted symbol policy");
Write_Line (" -s<sym> Symbol file name");
Write_Line (" -v Verbose mode");
Write_Line (" -V<ver> Version");

96
gcc/ada/make.adb
View File

@ -502,12 +502,8 @@ package body Make is
procedure Debug_Msg (S : String; N : Name_Id);
-- If Debug.Debug_Flag_W is set outputs string S followed by name N.
type Project_Array is array (Positive range <>) of Project_Id;
No_Projects : constant Project_Array := (1 .. 0 => No_Project);
procedure Recursive_Compute_Depth
(Project : Project_Id;
Visited : Project_Array;
Depth : Natural);
-- Compute depth of Project and of the projects it depends on
@ -5554,8 +5550,6 @@ package body Make is
----------------
procedure Initialize is
Next_Arg : Positive;
begin
-- Override default initialization of Check_Object_Consistency
-- since this is normally False for GNATBIND, but is True for
@ -5585,10 +5579,37 @@ package body Make is
Mains.Delete;
Next_Arg := 1;
Scan_Args : while Next_Arg <= Argument_Count loop
-- Add the directory where gnatmake is invoked in the front of the
-- path, if gnatmake is invoked with directory information.
-- Only do this if the platform is not VMS, where the notion of path
-- does not really exist.
if not OpenVMS then
declare
Command : constant String := Command_Name;
begin
for Index in reverse Command'Range loop
if Command (Index) = Directory_Separator then
declare
Absolute_Dir : constant String :=
Normalize_Pathname (Command (Command'First .. Index));
PATH : constant String :=
Absolute_Dir & Path_Separator & Getenv ("PATH").all;
begin
Setenv ("PATH", PATH);
end;
exit;
end if;
end loop;
end;
end if;
-- Scan the switches and arguments
Scan_Args : for Next_Arg in 1 .. Argument_Count loop
Scan_Make_Arg (Argument (Next_Arg), And_Save => True);
Next_Arg := Next_Arg + 1;
end loop Scan_Args;
if Usage_Requested then
@ -5688,8 +5709,13 @@ package body Make is
-- Compute depth of each project
for Proj in 1 .. Projects.Last loop
Projects.Table (Proj).Seen := False;
Projects.Table (Proj).Depth := 0;
end loop;
Recursive_Compute_Depth
(Main_Project, Visited => No_Projects, Depth => 0);
(Main_Project, Depth => 1);
else
@ -6189,26 +6215,28 @@ package body Make is
procedure Recursive_Compute_Depth
(Project : Project_Id;
Visited : Project_Array;
Depth : Natural)
is
List : Project_List;
Proj : Project_Id;
OK : Boolean;
New_Visited : constant Project_Array := Visited & Project;
begin
-- Nothing to do if there is no project
-- Nothing to do if there is no project or if the project has already
-- been seen or if the depth is large enough.
if Project = No_Project then
if Project = No_Project
or else Projects.Table (Project).Seen
or else Projects.Table (Project).Depth >= Depth
then
return;
end if;
-- If current depth of project is lower than Depth, adjust it
Projects.Table (Project).Depth := Depth;
if Projects.Table (Project).Depth < Depth then
Projects.Table (Project).Depth := Depth;
end if;
-- Mark the project as Seen to avoid endless loop caused by limited
-- withs.
Projects.Table (Project).Seen := True;
List := Projects.Table (Project).Imported_Projects;
@ -6217,34 +6245,20 @@ package body Make is
while List /= Empty_Project_List loop
Proj := Project_Lists.Table (List).Project;
List := Project_Lists.Table (List).Next;
OK := True;
-- To avoid endless loops due to cycles with limited widts,
-- do not revisit a project that is already in the chain of imports
-- that brought us here.
for J in Visited'Range loop
if Visited (J) = Proj then
OK := False;
exit;
end if;
end loop;
if OK then
Recursive_Compute_Depth
(Project => Proj,
Visited => New_Visited,
Depth => Depth + 1);
end if;
Recursive_Compute_Depth
(Project => Proj,
Depth => Depth + 1);
end loop;
-- Visit a project being extended, if any
Recursive_Compute_Depth
(Project => Projects.Table (Project).Extends,
Visited => New_Visited,
Depth => Depth + 1);
Depth => Depth + 1);
-- Reset the Seen flag, as we leave this project
Projects.Table (Project).Seen := False;
end Recursive_Compute_Depth;
-----------------------

39
gcc/ada/makegpr.adb
View File

@ -392,7 +392,10 @@ package body Makegpr is
First_Source : Other_Source_Id);
-- ??? needs comment
procedure Display_Command (Name : String; Path : String_Access);
procedure Display_Command
(Name : String;
Path : String_Access;
CPATH : String_Access := null);
-- Display the command for a spawned process, if in Verbose_Mode or
-- not in Quiet_Output.
@ -1625,6 +1628,7 @@ package body Makegpr is
is
Source : Other_Source := Other_Sources.Table (Source_Id);
Success : Boolean;
CPATH : String_Access := null;
begin
-- If the compiler is not know yet, get its path name
@ -1808,11 +1812,18 @@ package body Makegpr is
Add_Search_Directories (Data, Source.Language);
-- Set CPATH, if compiler is GCC
if Compiler_Is_Gcc (Source.Language) then
CPATH := Current_Include_Paths (Source.Language);
end if;
-- And invoke the compiler
Display_Command
(Compiler_Names (Source.Language).all,
Compiler_Paths (Source.Language));
(Name => Compiler_Names (Source.Language).all,
Path => Compiler_Paths (Source.Language),
CPATH => CPATH);
Spawn
(Compiler_Paths (Source.Language).all,
@ -1881,6 +1892,10 @@ package body Makegpr is
Get_Imported_Directories (Main_Project, Data);
Projects.Table (Main_Project) := Data;
-- Compilation will occur in the object directory
Change_Dir (Get_Name_String (Data.Object_Directory));
if not Data.Sources_Present then
if Ada_Is_A_Language then
Mains.Reset;
@ -2238,7 +2253,11 @@ package body Makegpr is
-- Display_Command --
---------------------
procedure Display_Command (Name : String; Path : String_Access) is
procedure Display_Command
(Name : String;
Path : String_Access;
CPATH : String_Access := null)
is
begin
-- Only display the command in Verbose Mode (-v) or when
-- not in Quiet Output (no -q).
@ -2247,6 +2266,11 @@ package body Makegpr is
-- In Verbose Mode output the full path of the spawned process
if Verbose_Mode then
if CPATH /= null then
Write_Str ("CPATH = ");
Write_Line (CPATH.all);
end if;
Write_Str (Path.all);
else
@ -2584,8 +2608,6 @@ package body Makegpr is
----------------
procedure Initialize is
Next_Arg : Positive;
begin
-- Do some necessary package initializations
@ -2605,13 +2627,10 @@ package body Makegpr is
Add_Str_To_Name_Buffer ("compiler_command");
Name_Compiler_Command := Name_Find;
Next_Arg := 1;
-- Get the command line arguments
Scan_Args : while Next_Arg <= Argument_Count loop
Scan_Args : for Next_Arg in 1 .. Argument_Count loop
Scan_Arg (Argument (Next_Arg));
Next_Arg := Next_Arg + 1;
end loop Scan_Args;
-- Fail if command line ended with "-P"

4
gcc/ada/mlib-tgt-vms-alpha.adb
View File

@ -438,6 +438,10 @@ package body MLib.Tgt is
when Controlled =>
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-C");
when Restricted =>
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-R");
end case;
-- Add each relevant object file

4
gcc/ada/mlib-tgt-vms-ia64.adb
View File

@ -471,6 +471,10 @@ package body MLib.Tgt is
when Controlled =>
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-C");
when Restricted =>
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-R");
end case;
-- Add each relevant object file

10
gcc/ada/par-ch12.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -200,7 +200,15 @@ package body Ch12 is
Set_Specification (Gen_Decl, P_Package (Pf_Spcn));
else
Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc);
Set_Specification (Gen_Decl, P_Subprogram_Specification);
if Nkind (Defining_Unit_Name (Specification (Gen_Decl)))
= N_Defining_Program_Unit_Name
and then Scope.Last > 0
then
Error_Msg_SP ("child unit allowed only at library level");
end if;
TF_Semicolon;
end if;

11
gcc/ada/prj-dect.adb
View File

@ -26,6 +26,7 @@
with Err_Vars; use Err_Vars;
with Namet; use Namet;
with Opt; use Opt;
with Prj.Err; use Prj.Err;
with Prj.Strt; use Prj.Strt;
with Prj.Tree; use Prj.Tree;
@ -535,7 +536,10 @@ package body Prj.Dect is
First_Declarative_Item : Project_Node_Id := Empty_Node;
First_Choice : Project_Node_Id := Empty_Node;
First_Choice : Project_Node_Id := Empty_Node;
When_Others : Boolean := False;
-- Set to True when there is a "when others =>" clause
begin
Case_Construction :=
@ -612,6 +616,7 @@ package body Prj.Dect is
Scan;
if Token = Tok_Others then
When_Others := True;
-- Scan past "others"
@ -661,7 +666,9 @@ package body Prj.Dect is
end if;
end loop When_Loop;
End_Case_Construction;
End_Case_Construction
(Check_All_Labels => not When_Others and not Quiet_Output,
Case_Location => Location_Of (Case_Construction));
Expect (Tok_End, "`END CASE`");
Remove_Next_End_Node;

68
gcc/ada/prj-nmsc.adb
View File

@ -1209,7 +1209,44 @@ package body Prj.Nmsc is
end;
end if;
if not Lib_Symbol_File.Default then
if not Lib_Symbol_Policy.Default then
declare
Value : constant String :=
To_Lower
(Get_Name_String (Lib_Symbol_Policy.Value));
begin
if Value = "autonomous" or else Value = "default" then
Data.Symbol_Data.Symbol_Policy := Autonomous;
elsif Value = "compliant" then
Data.Symbol_Data.Symbol_Policy := Compliant;
elsif Value = "controlled" then
Data.Symbol_Data.Symbol_Policy := Controlled;
elsif Value = "restricted" then
Data.Symbol_Data.Symbol_Policy := Restricted;
else
Error_Msg
(Project,
"illegal value for Library_Symbol_Policy",
Lib_Symbol_Policy.Location);
end if;
end;
end if;
if Lib_Symbol_File.Default then
if Data.Symbol_Data.Symbol_Policy = Restricted then
Error_Msg
(Project,
"Library_Symbol_File needs to be defined when " &
"symbol policy is Restricted",
Lib_Symbol_Policy.Location);
end if;
else
Data.Symbol_Data.Symbol_File := Lib_Symbol_File.Value;
Get_Name_String (Lib_Symbol_File.Value);
@ -1245,33 +1282,10 @@ package body Prj.Nmsc is
end if;
end if;
if not Lib_Symbol_Policy.Default then
declare
Value : constant String :=
To_Lower
(Get_Name_String (Lib_Symbol_Policy.Value));
begin
if Value = "autonomous" or else Value = "default" then
Data.Symbol_Data.Symbol_Policy := Autonomous;
elsif Value = "compliant" then
Data.Symbol_Data.Symbol_Policy := Compliant;
elsif Value = "controlled" then
Data.Symbol_Data.Symbol_Policy := Controlled;
else
Error_Msg
(Project,
"illegal value for Library_Symbol_Policy",
Lib_Symbol_Policy.Location);
end if;
end;
end if;
if Lib_Ref_Symbol_File.Default then
if Data.Symbol_Data.Symbol_Policy /= Autonomous then
if Data.Symbol_Data.Symbol_Policy = Compliant
or else Data.Symbol_Data.Symbol_Policy = Controlled
then
Error_Msg
(Project,
"a reference symbol file need to be defined",

42
gcc/ada/prj-strt.adb
View File

@ -260,8 +260,48 @@ package body Prj.Strt is
-- End_Case_Construction --
---------------------------
procedure End_Case_Construction is
procedure End_Case_Construction
(Check_All_Labels : Boolean;
Case_Location : Source_Ptr)
is
Non_Used : Natural := 0;
First_Non_Used : Choice_Node_Id := First_Choice_Node_Id;
begin
-- First, if Check_All_Labels is True, check if all values
-- of the string type have been used.
if Check_All_Labels then
for Choice in Choice_First .. Choices.Last loop
if not Choices.Table (Choice).Already_Used then
Non_Used := Non_Used + 1;
if Non_Used = 1 then
First_Non_Used := Choice;
end if;
end if;
end loop;
-- If only one is not used, report a single warning for this value
if Non_Used = 1 then
Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String;
Error_Msg ("?value { is not used as label", Case_Location);
-- If several are not used, report a warning for each one of them
elsif Non_Used > 1 then
Error_Msg
("?the following values are not used as labels:",
Case_Location);
for Choice in First_Non_Used .. Choices.Last loop
if not Choices.Table (Choice).Already_Used then
Error_Msg_Name_1 := Choices.Table (Choice).The_String;
Error_Msg ("\?{", Case_Location);
end if;
end loop;
end if;
end if;
-- If this is the only case construction, empty the tables
if Choice_Lasts.Last = 1 then

7
gcc/ada/prj-strt.ads
View File

@ -53,11 +53,16 @@ private package Prj.Strt is
-- into a table to be checked against the case labels of the
-- case construction.
procedure End_Case_Construction;
procedure End_Case_Construction
(Check_All_Labels : Boolean;
Case_Location : Source_Ptr);
-- This procedure is called at the end of a case construction
-- to remove the case labels and to restore the previous state.
-- In particular, in the case of nested case constructions,
-- the case labels of the enclosing case construction are restored.
-- When When_Others is False and we are not in quiet output, a warning
-- is emitted for each value of the case variable string type that has
-- not been specified.
procedure Parse_Choice_List
(First_Choice : out Project_Node_Id);

4
gcc/ada/prj.ads
View File

@ -172,8 +172,8 @@ package Prj is
type Lib_Kind is (Static, Dynamic, Relocatable);
type Policy is (Autonomous, Compliant, Controlled);
-- See explaination about this type in package Symbol
type Policy is (Autonomous, Compliant, Controlled, Restricted);
-- See explaination about this type in package Symbols
type Symbol_Record is record
Symbol_File : Name_Id := No_Name;

2
gcc/ada/s-auxdec-vms_64.ads
View File

@ -463,7 +463,7 @@ private
-- convention C so that the critical parameters are passed by reference.
-- Without this, the parameters are passed by copy, creating load/store
-- race conditions. We also inline them, since this seems more in the
-- spirit of the original (hardware instrinsic) routines.
-- spirit of the original (hardware intrinsic) routines.
pragma Convention (C, Clear_Interlocked);
pragma Inline_Always (Clear_Interlocked);

2
gcc/ada/s-auxdec.ads
View File

@ -459,7 +459,7 @@ private
-- convention C so that the critical parameters are passed by reference.
-- Without this, the parameters are passed by copy, creating load/store
-- race conditions. We also inline them, since this seems more in the
-- spirit of the original (hardware instrinsic) routines.
-- spirit of the original (hardware intrinsic) routines.
pragma Convention (C, Clear_Interlocked);
pragma Inline_Always (Clear_Interlocked);

13
gcc/ada/s-fatgen.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -302,12 +302,12 @@ package body System.Fat_Gen is
Ex : UI := Adjustment;
begin
if Adjustment < T'Machine_Emin then
if Adjustment < T'Machine_Emin - 1 then
Y := 2.0 ** T'Machine_Emin;
Y1 := Y;
Ex := Ex - T'Machine_Emin;
while Ex <= 0 loop
while Ex < 0 loop
Y := T'Machine (Y / 2.0);
if Y = 0.0 then
@ -337,6 +337,9 @@ package body System.Fat_Gen is
if Radix_Digits >= T'Machine_Mantissa then
return X;
elsif Radix_Digits <= 0 then
raise Constraint_Error;
else
L := Exponent (X) - Radix_Digits;
Y := Truncation (Scaling (X, -L));
@ -433,6 +436,10 @@ package body System.Fat_Gen is
P_Even : Boolean;
begin
if Y = 0.0 then
raise Constraint_Error;
end if;
if X > 0.0 then
Sign_X := 1.0;
Arg := X;

4
gcc/ada/s-maccod.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
-- This package provides machine code support, both for instrinsic machine
-- This package provides machine code support, both for intrinsic machine
-- operations, and also for machine code statements. See GNAT documentation
-- for full details.

1
gcc/ada/s-stchop-vxworks.adb
View File

@ -122,6 +122,7 @@ package body System.Stack_Checking.Operations is
Td_ErrorStatus : Interfaces.C.int; -- most recent task error status
Td_Delay : Interfaces.C.int; -- delay/timeout ticks
end record;
pragma Convention (C, Task_Descriptor);
-- This VxWorks procedure fills in a specified task descriptor
-- for a specified task.

2
gcc/ada/s-taenca.adb
View File

@ -154,7 +154,7 @@ package body System.Tasking.Entry_Calls is
use type Ada.Exceptions.Exception_Id;
procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
pragma Import (C, Internal_Raise, "__gnat_raise_after_setup");
pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
E : constant Ada.Exceptions.Exception_Id :=
Entry_Call.Exception_To_Raise;

4
gcc/ada/s-unstyp.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -88,7 +88,7 @@ pragma Pure (Unsigned_Types);
-- Types used for packed array conversions
subtype Bytes_F is Packed_Bytes4 (1 .. Float'Size / 8);
-- Type used in implementation of Is_Negative instrinsic (see Exp_Intr)
-- Type used in implementation of Is_Negative intrinsic (see Exp_Intr)
function Shift_Left
(Value : Short_Short_Unsigned;

39
gcc/ada/sem_attr.adb
View File

@ -671,12 +671,8 @@ package body Sem_Attr is
-- object, and that the expression, if present, is static
-- and within the range of the dimensions of the type.
if Is_Array_Type (P_Type) then
Index := First_Index (P_Base_Type);
else pragma Assert (Is_Access_Type (P_Type));
Index := First_Index (Base_Type (Designated_Type (P_Type)));
end if;
pragma Assert (Is_Array_Type (P_Type));
Index := First_Index (P_Base_Type);
if No (E1) then
@ -722,6 +718,7 @@ package body Sem_Attr is
-- Normal case of array type or subtype
Check_Either_E0_Or_E1;
Check_Dereference;
if Is_Array_Type (P_Type) then
if not Is_Constrained (P_Type)
@ -740,26 +737,18 @@ package body Sem_Attr is
D := Number_Dimensions (P_Type);
elsif Is_Access_Type (P_Type)
and then Is_Array_Type (Designated_Type (P_Type))
then
if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
Error_Attr ("prefix of % attribute cannot be access type", P);
end if;
D := Number_Dimensions (Designated_Type (P_Type));
-- If there is an implicit dereference, then we must freeze
-- the designated type of the access type, since the type of
-- the referenced array is this type (see AI95-00106).
Freeze_Before (N, Designated_Type (P_Type));
else
if Is_Private_Type (P_Type) then
Error_Attr
("prefix for % attribute may not be private type", P);
elsif Is_Access_Type (P_Type)
and then Is_Array_Type (Designated_Type (P_Type))
and then Is_Entity_Name (P)
and then Is_Type (Entity (P))
then
Error_Attr ("prefix of % attribute cannot be access type", P);
elsif Attr_Id = Attribute_First
or else
Attr_Id = Attribute_Last
@ -874,6 +863,13 @@ package body Sem_Attr is
Resolve (P);
if Is_Access_Type (P_Type) then
-- If there is an implicit dereference, then we must freeze
-- the designated type of the access type, since the type of
-- the referenced array is this type (see AI95-00106).
Freeze_Before (N, Designated_Type (P_Type));
Rewrite (P,
Make_Explicit_Dereference (Sloc (P),
Prefix => Relocate_Node (P)));
@ -1861,6 +1857,7 @@ package body Sem_Attr is
-- If the prefix is a selected component whose prefix is of an
-- access type, then introduce an explicit dereference.
-- ??? Could we reuse Check_Dereference here?
if Nkind (Pref) = N_Selected_Component
and then Is_Access_Type (Ptyp)

1
gcc/ada/sem_ch12.adb
View File

@ -9531,7 +9531,6 @@ package body Sem_Ch12 is
-- inlining.
Rewrite (N, New_Copy (N2));
Set_Associated_Node (N, N2);
Set_Analyzed (N, False);
end if;
end if;

7
gcc/ada/sem_ch3.adb
View File

@ -1696,6 +1696,13 @@ package body Sem_Ch3 is
Set_Is_True_Constant (Id, True);
-- If we are analyzing a constant declaration, set its completion
-- flag after analyzing the expression.
if Constant_Present (N) then
Set_Has_Completion (Id);
end if;
if not Assignment_OK (N) then
Check_Initialization (T, E);
end if;

47
gcc/ada/sem_ch7.adb
View File

@ -691,6 +691,12 @@ package body Sem_Ch7 is
-- Child and Unit are entities of compilation units. True if Child
-- is a public child of Parent as defined in 10.1.1
procedure Inspect_Deferred_Constant_Completion;
-- Examines the deferred constants in the private part of the
-- package specification. Emits the error "constant declaration
-- requires initialization expression " if not completed by an
-- import pragma.
---------------------
-- Clear_Constants --
---------------------
@ -793,6 +799,42 @@ package body Sem_Ch7 is
end if;
end Is_Public_Child;
--------------------------------------------
-- Inspect_Deferred_Constant_Completion --
--------------------------------------------
procedure Inspect_Deferred_Constant_Completion is
Decl : Node_Id;
begin
Decl := First (Priv_Decls);
while Present (Decl) loop
-- Deferred constant signature
if Nkind (Decl) = N_Object_Declaration
and then Constant_Present (Decl)
and then No (Expression (Decl))
-- No need to check internally generated constants
and then Comes_From_Source (Decl)
-- The constant is not completed. A full object declaration
-- or a pragma Import complete a deferred constant.
and then not Has_Completion (Defining_Identifier (Decl))
then
Error_Msg_N
("constant declaration requires initialization expression",
Defining_Identifier (Decl));
end if;
Decl := Next (Decl);
end loop;
end Inspect_Deferred_Constant_Completion;
-- Start of processing for Analyze_Package_Specification
begin
@ -887,6 +929,11 @@ package body Sem_Ch7 is
Analyze_Declarations (Priv_Decls);
-- Check the private declarations for incomplete deferred
-- constants.
Inspect_Deferred_Constant_Completion;
-- The first private entity is the immediate follower of the last
-- visible entity, if there was one.

2
gcc/ada/sem_ch8.adb
View File

@ -1436,7 +1436,7 @@ package body Sem_Ch8 is
Set_Alias (New_S, Old_S);
end if;
-- Note that we do not set Is_Instrinsic_Subprogram if we have
-- Note that we do not set Is_Intrinsic_Subprogram if we have
-- a renaming as body, since the entity in this case is not an
-- intrinsic (it calls an intrinsic, but we have a real body
-- for this call, and it is in this body that the required

6
gcc/ada/sem_prag.adb
View File

@ -2705,6 +2705,12 @@ package body Sem_Prag is
Set_Is_Public (Def_Id);
Process_Interface_Name (Def_Id, Arg3, Arg4);
-- pragma Import completes deferred constants
if Ekind (Def_Id) = E_Constant then
Set_Has_Completion (Def_Id);
end if;
-- It is not possible to import a constant of an unconstrained
-- array type (e.g. string) because there is no simple way to
-- write a meaningful subtype for it.

1
gcc/ada/sem_res.adb
View File

@ -6355,6 +6355,7 @@ package body Sem_Res is
if Warn_On_Redundant_Constructs
and then Comes_From_Source (Orig_N)
and then Nkind (Orig_N) = N_Type_Conversion
and then not In_Instance
then
Orig_N := Original_Node (Expression (Orig_N));
Orig_T := Target_Type;

2
gcc/ada/sem_util.adb
View File

@ -42,7 +42,7 @@ with Nmake; use Nmake;
with Output; use Output;
with Opt; use Opt;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Rtsfind; use Rtsfind;
with Scans; use Scans;
with Scn; use Scn;
with Sem; use Sem;

162
gcc/ada/symbols-vms-alpha.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2003 Free Software Foundation, Inc. --
-- Copyright (C) 2003-2004 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- --
@ -229,25 +229,52 @@ package body Symbols is
Success := True;
-- If policy is not autonomous, attempt to read the reference file
-- If policy is Compliant or Controlled, attempt to read the reference
-- file. If policy is Restricted, attempt to read the symbol file.
if Sym_Policy /= Autonomous then
begin
Open (File, In_File, Reference);
case Sym_Policy is
when Autonomous =>
null;
exception
when Ada.Text_IO.Name_Error =>
return;
when Compliant | Controlled =>
begin
Open (File, In_File, Reference);
when X : others =>
if not Quiet then
Put_Line ("could not open """ & Reference & """");
Put_Line (Exception_Message (X));
end if;
exception
when Ada.Text_IO.Name_Error =>
Success := False;
return;
Success := False;
return;
end;
when X : others =>
if not Quiet then
Put_Line ("could not open """ & Reference & """");
Put_Line (Exception_Message (X));
end if;
Success := False;
return;
end;
when Restricted =>
begin
Open (File, In_File, Symbol_File);
exception
when Ada.Text_IO.Name_Error =>
Success := False;
return;
when X : others =>
if not Quiet then
Put_Line ("could not open """ & Symbol_File & """");
Put_Line (Exception_Message (X));
end if;
Success := False;
return;
end;
end case;
-- Read line by line
@ -637,7 +664,7 @@ package body Symbols is
""" is no longer present in the object files");
end if;
if Sym_Policy = Controlled then
if Sym_Policy = Controlled or else Sym_Policy = Restricted then
Success := False;
return;
@ -656,78 +683,83 @@ package body Symbols is
end if;
end loop;
-- Append additional symbols, if any, to the Original_Symbols table
if Sym_Policy /= Restricted then
for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop
S_Data := Complete_Symbols.Table (Index);
-- Append additional symbols, if any, to the Original_Symbols
-- table.
if S_Data.Present then
for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop
S_Data := Complete_Symbols.Table (Index);
if Sym_Policy = Controlled then
Put_Line ("symbol """ & S_Data.Name.all &
""" is not in the reference symbol file");
Success := False;
return;
if S_Data.Present then
elsif Soft_Minor_ID then
Minor_ID := Minor_ID + 1;
Soft_Minor_ID := False;
if Sym_Policy = Controlled then
Put_Line ("symbol """ & S_Data.Name.all &
""" is not in the reference symbol file");
Success := False;
return;
elsif Soft_Minor_ID then
Minor_ID := Minor_ID + 1;
Soft_Minor_ID := False;
end if;
Symbol_Table.Increment_Last (Original_Symbols);
Original_Symbols.Table
(Symbol_Table.Last (Original_Symbols)) := S_Data;
Complete_Symbols.Table (Index).Present := False;
end if;
end loop;
Symbol_Table.Increment_Last (Original_Symbols);
Original_Symbols.Table (Symbol_Table.Last (Original_Symbols)) :=
S_Data;
Complete_Symbols.Table (Index).Present := False;
end if;
end loop;
-- Create the symbol file
-- Create the symbol file
Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all);
Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all);
Put (File, Case_Sensitive);
Put_Line (File, "yes");
Put (File, Case_Sensitive);
Put_Line (File, "yes");
-- Put a line in the symbol file for each symbol in the symbol
-- table.
-- Put a line in the symbol file for each symbol in the symbol table
for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop
if Original_Symbols.Table (Index).Present then
Put (File, Symbol_Vector);
Put (File, Original_Symbols.Table (Index).Name.all);
for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop
if Original_Symbols.Table (Index).Present then
Put (File, Symbol_Vector);
Put (File, Original_Symbols.Table (Index).Name.all);
if Original_Symbols.Table (Index).Kind = Data then
Put_Line (File, Equal_Data);
if Original_Symbols.Table (Index).Kind = Data then
Put_Line (File, Equal_Data);
else
Put_Line (File, Equal_Procedure);
end if;
else
Put_Line (File, Equal_Procedure);
Free (Original_Symbols.Table (Index).Name);
end if;
end loop;
Free (Original_Symbols.Table (Index).Name);
end if;
end loop;
Put (File, Case_Sensitive);
Put_Line (File, "NO");
Put (File, Case_Sensitive);
Put_Line (File, "NO");
-- Put the version IDs
-- Put the version IDs
Put (File, Gsmatch);
Put (File, Image (Major_ID));
Put (File, ',');
Put_Line (File, Image (Minor_ID));
Put (File, Gsmatch);
Put (File, Image (Major_ID));
Put (File, ',');
Put_Line (File, Image (Minor_ID));
-- And we are done
-- And we are done
Close (File);
Close (File);
-- Reset both tables
-- Reset both tables
Symbol_Table.Set_Last (Original_Symbols, 0);
Symbol_Table.Set_Last (Complete_Symbols, 0);
Symbol_Table.Set_Last (Original_Symbols, 0);
Symbol_Table.Set_Last (Complete_Symbols, 0);
-- Clear the symbol file name
-- Clear the symbol file name
Free (Symbol_File_Name);
Free (Symbol_File_Name);
end if;
Success := True;
end if;

8
gcc/ada/symbols.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2003 Free Software Foundation, Inc. --
-- Copyright (C) 2003-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -44,9 +44,13 @@ package Symbols is
-- all symbols are already found in the reference file or with an
-- incremented minor ID, if not.
Controlled);
Controlled,
-- Fail if symbols are not the same as those in the reference file
Restricted);
-- Restrict the symbols to those in the symbol file. Fail if some
-- symbols in the symbol file are not exported from the object files.
type Symbol_Kind is (Data, Proc);
-- To distinguish between the different kinds of symbols