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

revert: [multiple changes] 

2004-06-25  Pascal Obry  <obry@gnat.com>

	* makegpr.adb (Build_Library): Remove parameter Lib_Address and
	Relocatable from Build_Dynamic_Library call.

	* gnat_ugn.texi: Change documentation about Library_Kind. Dynamic and
	Relocatable are now synonym.

	* Makefile.in: Use s-parame-mingw.adb on MingW platform.

	* mlib-prj.adb (Build_Library): Remove DLL_Address constant definition.
	Remove parameter Lib_Address and Relocatable from Build_Dynamic_Library
	call.

	* mlib-tgt.ads, mlib-tgt.adb (Build_Dynamic_Library): Remove parameter
	Lib_Address and Relocatable.
	(Default_DLL_Address): Removed.

	* mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb,
	mlib-tgt-hpux.adb, mlib-tgt-linux.adb, mlib-tgt-solaris.adb,
	mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, mlib-tgt-vxworks.adb:
	(Build_Dynamic_Library): Remove parameter Lib_Address and Relocatable.
	(Default_DLL_Address): Removed.

	* mlib-tgt-mingw.adb: Ditto.
	(Build_Dynamic_Library): Do not add "lib" prefix to the DLL name.

	* s-taprop-mingw.adb (Create_Task): Use Adjust_Storage_Size to compute
	the initial thread stack size.

	* a-strmap.ads: Move package L to private part as it is not used in
	the spec. Found while reading code.

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

	* tracebak.c: Introduce support for a GCC infrastructure based
	implementation of __gnat_backtrace.

	* raise.c: Don't rely on a C mapping of the GNAT_GCC_Exception record
	any more. Use accessors instead. This eases maintenance and relaxes
	some alignment constraints.
	(_GNAT_Exception structure): Remove the Ada specific fields
	(EID_For, Adjust_N_Cleanups_For): New accessors, exported by
	a-exexpr.adb.
	(is_handled_by, __gnat_eh_personality): Replace component references to
	exception structure by use of the new accessors.

	* init.c (__gnat_initialize): Adjust comments to match the just
	reverted meaning of the -static link-time option.

	* adaint.c (convert_addresses): Arrange not to define a stub for
	mips-irix any more, as we now want to rely on a real version from a
	recent libaddr2line.

	* a-exexpr.adb: Provide new accessors to a GNAT_GCC occurrence, so that
	the personality routine can use them and not have to rely on a C
	counterpart of the record anymore. This simplifies maintenance and
	relaxes the constraint of having Standard'Maximum_Alignment match
	BIGGEST_ALIGNMENT.
	Update comments, and add a section on the common header alignment issue.

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

	* a-ngelfu.adb (Tanh): Use full 20 digit precision for constants in
	polynomial approximation. Fixes inconsistency with Cody/Waite algorithm.

2004-06-25  Robert Dewar  <dewar@gnat.com>

	* gnat_rm.texi: Fix section on component clauses to indicate that the
	restriction on byte boundary placement still applies for bit packed
	arrays.
	Add comment on stack usage from Initialize_Scalars

	* gnat_ugn.texi: Add documentation for -gnatyLnnn

	* stylesw.ads, stylesw.adb: Implement new -gnatyLnnn option for
	limiting nesting level.

	* usage.adb: Add line for -gnatyLnnn switch

	* g-debpoo.ads, xtreeprs.adb, sinput.ads, sem_ch13.ads,
	sem_ch13.adb, exp_aggr.adb: Minor reformatting

	* sem_prag.adb (Process_Atomic_Shared_Volatile): Set Is_Atomic on base
	type as well as on the subtype. This corrects a problem in freeze in
	setting alignments of atomic types.

	* sem_eval.ads: Minor comment typo fixed

	* par-util.adb (Push_Scope_Stack): Check for violation of max nesting
	level.  Minor reformatting.

	* fname.adb (Is_Predefined_File_Name): Require a letter after the
	minus sign. This means that file names like a--b.adb will not be
	considered predefined.

	* freeze.adb: Propagate new flag Must_Be_On_Byte_Boundary to containing
	record Test new flag and give diagnostic for bad component clause.
	(Freeze_Entity): Set alignment of array from component alignment in
	cases where this is safe to do.

	* exp_pakd.adb: Set new flag Must_Be_On_Byte_Boundary for large packed
	arrays.

	* cstand.adb: (Create_Standard): Set alignment of String to 1

	* einfo.ads, einfo.adb: Introduce new flag Must_Be_On_Byte_Boundary

	* exp_ch4.adb (Expand_Array_Equality): Improve efficiency of generated
	code in the common constrained array cases.

	* a-storio.adb: Change implementation to avoid possible alignment
	problems on machines requiring strict alignment (data should be moved
	as type Buffer, not type Elmt).

	* checks.adb (Apply_Array_Size_Check): Improve these checks by
	killing the overflow checks which we really do not need (64-bits is
	enough).

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

	* makegpr.adb (Is_Included_In_Global_Archive): New Boolean function
	(Add_Archives.Recursive_Add_Archives): Call Add_Archive_Path
	inconditionally for the main project.
	(Recursive_Add_Archives.Add_Archive_Path): New procedure
	(Link_Executables.Check_Time_Stamps): New procedure
	(Link_Executables.Link_Foreign): New procedure
	Changes made to reduce nesting level of this package
	(Check): New procedure
	(Add_Switches): When not in quiet output, check that a switch is not
	the concatenation of several valid switches. If it is, issue a warning.
	(Build_Global_Archive): If the global archive is rebuilt, linking need
	to be done.
	(Compile_Sources): Rebuilding a library archive does not imply
	rebuilding the global archive.
	(Build_Global_Archive): New procedure
	(Build_Library): New name for Build_Archive, now only for library
	project
	(Check_Archive_Builder): New procedure
	(Create_Global_Archive_Dependency_File): New procedure
	(Gprmake): Call Build_Global_Archive before linking
	* makegpr.adb: Use Other_Sources_Present instead of Sources_Present
	throughout.
	(Scan_Arg): Display the Copyright notice when -v is used

	* gnat_ugn.texi: Document new switch -files= (VMS qualifier /FILES=)
	for gnatls.

	* vms_data.ads: Add qualifier /MAX_NESTING=nnn (-gnatyLnnn) for GNAT
	COMPILE.
	Add new GNAT LIST qualifier /FILES=
	Added qualifier /DIRECTORY= to GNAT METRIC
	Added qualifier /FILES= to GNAT METRIC
	Added qualifier /FILES to GNAT PRETTY

	* switch.adb (Is_Front_End_Switch): Refine the test for --RTS or -fRTS,
	to take into account both versions of the switch.

	* switch-c.adb (Scan_Front_End_Switches): New switch -gnatez. Should
	always be the last switch to the gcc driver. Disable switch storing so
	that switches automatically added by the gcc driver are not put in the
	ALI file.

	* prj.adb (Project_Empty): Take into account changes in components of
	Project_Data.

	* prj.ads (Languages_Processed): New enumaration value All_Languages.

	* prj.ads (Project_Data): Remove component Lib_Elaboration: never
	used. Split Boolean component Ada_Sources_Present in two Boolean
	components Ada_Sources_Present and Other_Sources_Present.
	Minor reformatting

	* prj-env.adb (For_All_Source_Dirs.Add): Use Ada_Sources_Present
	instead of Sources_Present.
	(Set_Ada_Paths.Add.Recursive_Add): Ditto

	* prj-nmsc.adb: Minor reformatting
	(Check_Ada_Naming_Scheme): New name of procedure Check_Naming_Scheme
	(Check_Ada_Naming_Scheme_Validity): New name of previous procedure
	Check_Ada_Naming_Scheme.
	Change Sources_Present to Ada_Sources_Present or Other_Sources_Present
	throughout.

	* prj-part.adb (Post_Parse_Context_Clause): New Boolean parameter
	In_Limited.
	Make sure that all cycles where there is at least one "limited with"
	are detected.
	(Parse_Single_Project): New Boolean parameter In_Limited

	* prj-proc.adb (Recursive_Check): When Process_Languages is
	All_Languages, call first Prj.Nmsc.Ada_Check, then
	Prj.Nmsc.Other_Languages_Check.

	* prj-proc.adb (Process): Use Ada_Sources_Present or
	Other_Sources_Present (instead of Sources_Present) depending on
	Process_Languages.

	* lang-specs.h: Keep -g and -m switches in the same order, and as the
	last switches.

	* lib.adb (Switch_Storing_Enabled): New global Boolean flag
	(Disable_Switch_Storing): New procedure. Set Switch_Storing_Enabled to
	False.
	(Store_Compilation_Switch): Do nothing if Switch_Storing_Enabled is
	False.

	* lib.ads (Disable_Switch_Storing): New procedure.

	* make.adb: Modifications to reduce nesting level of this package.
	(Check_Standard_Library): New procedure
	(Gnatmake.Check_Mains): New procedure
	(Gnatmake.Create_Binder_Mapping_File): New procedure
	(Compile_Sources.Compile): Add switch -gnatez as the last option
	(Display): Never display -gnatez

	* Makefile.generic:
	When using $(MAIN_OBJECT), always use $(OBJ_DIR)/$(MAIN_OBJECT)

	* gnatcmd.adb (Check_Project): New function
	(Process_Link): New procedure to reduce nesting depth
	(Check_Files): New procedure to reduce the nesting depth.
	For GNAT METRIC, include the inherited sources in extending projects.
	(GNATCmd): When GNAT LS is invoked with a project file and no files,
	add the list of files from the sources of the project file. If this list
	is too long, put it in a temp text files and use switch -files=
	(Delete_Temp_Config_Files): Delete the temp text file that contains
	a list of source for gnatpp or gnatmetric, if one has been created.
	(GNATCmd): For GNAT METRIC and GNAT PRETTY, if the number of sources
	in the project file is too large, create a temporary text file that
	list them and pass it to the tool with "-files=<temp text file>".
	(GNATCmd): For GNAT METRIC add "-d=<abject dir>" as the first switch

	* gnatlink.adb (Gnatlink): Do not compile with --RTS= when the
	generated file is in not in Ada.

	* gnatls.adb: Remove all parameters And_Save that are no longer used.
	(Scan_Ls_Arg): Add processing for -files=
	(Usage): Add line for -files=

	* g-os_lib.adb (On_Windows): New global constant Boolean flag
	(Normalize_Pathname): When on Windows and the path starts with a
	directory separator, make sure that the resulting path will start with
	a drive letter.

	* clean.adb (Clean_Archive): New procedure
	(Clean_Project): When there is non-Ada code, delete the global archive,
	the archive dependency files, the object files and their dependency
	files, if they exist.
	(Gnatclean): Call Prj.Pars.Parse for All_Languages, not for Ada only.

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

	* sinfo.ads: Fix typo in comment.

	* sem_dist.adb (Process_Remote_AST_Attribute): Simplify code that uses
	the TSS for remote access-to-subprogram types, since these TSS are
	always present once the type has been analyzed.
	(RAS_E_Dereference): Same.

	* sem_attr.adb (Analyze_Attribute): When analysis of an attribute
	reference raises Bad_Attribute, mark the reference as analyzed so the
	node (and any children resulting from rewrites that could have occurred
	during the analysis that ultimately failed) is not analyzed again.

	* exp_ch7.ads (Find_Final_List): Fix misaligned comment.

	* exp_dist.adb: Minor comment fix.

	* exp_ch4.adb (Expand_N_Allocator): For an allocator whose expected
	type is an anonymous access type, no unchecked deallocation of the
	allocated object can occur. If the object is controlled, attach it with
	a count of 1. This allows attachment to the Global_Final_List, if
	no other relevant list is available.
	(Get_Allocator_Final_List): For an anonymous access type that is
	the type of a discriminant or record component, the corresponding
	finalisation list is the one of the scope of the type.

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

	* sem_ch3.adb (Replace_Type): When computing the signature of an
	inherited subprogram, use the first subtype if the derived type
	declaration has no constraint.

	* exp_ch6.adb (Add_Call_By_Copy_Code): Check that formal is an array
	before applying previous optimization. Minor code cleanup.

	* exp_util.adb (Is_Possibly_Unaligned_Slice): If the component is
	placed at the beginning of an unpacked record without explicit
	alignment, a slice of it will be aligned and does not need a copy when
	used as an actual.

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

	PR ada/15591
	PR ada/15592
	* sem_ch8.adb (Attribute_Renaming): Reject renaming if the attribute
	reference is written with expressions mimicking parameters.

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

	PR ada/15589
	* sem_ch3.adb (Build_Derived_Record_Type): Add additional check to
	STEP 2a. The constraints of a full type declaration of a derived record
	type are checked for conformance with those declared in the
	corresponding private extension declaration. The message
	"not conformant with previous declaration" is emitted if an error is
	detected.

2004-06-25  Vasiliy Fofanov  <fofanov@act-europe.fr>

	* g-traceb.ads: Document the need for -E binder switch in the spec.

	* g-trasym.ads: Document the need for -E binder switch in the spec.

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

	* sem_prag.adb: Add handling of pragma Detect_Blocking.

	* snames.h, snames.ads, snames.adb: Add entry for pragma
	Detect_Blocking.

	* s-rident.ads: Change reference to pragma Detect_Blocking.

	* targparm.ads, targparm.adb: Allow pragma Detect_Blocking in
	system.ads.

	* opt.ads (Detect_Blocking): New Boolean variable (defaulted to False)
	to indicate whether pragma Detect_Blocking is active.

	* par-prag.adb: Add entry for pragma Detect_Blocking.

	* rtsfind.adb (RTU_Loaded): Fix the temporary kludge to get past bug
	of not handling WITH.
	Note that this replaces the previous update which was incorrect.

2004-06-25  Javier Miranda  <miranda@gnat.com>

	* sem_ch10.adb (Re_Install_Use_Clauses): Force the installation of the
	use-clauses to have a clean environment.

	* sem_ch8.adb (Install_Use_Clauses): Addition of a new formal to force
	the installation of the use-clauses to stablish a clean environment in
	case of compilation of a separate unit; otherwise the call to
	use_one_package is protected by the barrier Applicable_Use.

	* sem_ch8.ads (Install_Use_Clauses): Addition of a new formal to force
	the installation of the use-clauses to stablish a clean environment in
	case of compilation of a separate unit.
	(End_Use_Clauses): Minor comment cleanup.

2004-06-25  Sergey Rybin  <rybin@act-europe.fr>

	* gnat_ugn.texi: Add description of the gnatpp 'files' switch

From-SVN: r83658
This commit is contained in:
Arnaud Charlet 2004-06-25 18:39:33 +02:00
parent 29357d8b94
commit 0da2c8ac77
89 changed files with 4939 additions and 3216 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

355
gcc/ada/ChangeLog
View File

@ -1,3 +1,358 @@
2004-06-25 Pascal Obry <obry@gnat.com>
* makegpr.adb (Build_Library): Remove parameter Lib_Address and
Relocatable from Build_Dynamic_Library call.
* gnat_ugn.texi: Change documentation about Library_Kind. Dynamic and
Relocatable are now synonym.
* Makefile.in: Use s-parame-mingw.adb on MingW platform.
* mlib-prj.adb (Build_Library): Remove DLL_Address constant definition.
Remove parameter Lib_Address and Relocatable from Build_Dynamic_Library
call.
* mlib-tgt.ads, mlib-tgt.adb (Build_Dynamic_Library): Remove parameter
Lib_Address and Relocatable.
(Default_DLL_Address): Removed.
* mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb,
mlib-tgt-hpux.adb, mlib-tgt-linux.adb, mlib-tgt-solaris.adb,
mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, mlib-tgt-vxworks.adb:
(Build_Dynamic_Library): Remove parameter Lib_Address and Relocatable.
(Default_DLL_Address): Removed.
* mlib-tgt-mingw.adb: Ditto.
(Build_Dynamic_Library): Do not add "lib" prefix to the DLL name.
* s-taprop-mingw.adb (Create_Task): Use Adjust_Storage_Size to compute
the initial thread stack size.
* a-strmap.ads: Move package L to private part as it is not used in
the spec. Found while reading code.
2004-06-25 Olivier Hainque <hainque@act-europe.fr>
* tracebak.c: Introduce support for a GCC infrastructure based
implementation of __gnat_backtrace.
* raise.c: Don't rely on a C mapping of the GNAT_GCC_Exception record
any more. Use accessors instead. This eases maintenance and relaxes
some alignment constraints.
(_GNAT_Exception structure): Remove the Ada specific fields
(EID_For, Adjust_N_Cleanups_For): New accessors, exported by
a-exexpr.adb.
(is_handled_by, __gnat_eh_personality): Replace component references to
exception structure by use of the new accessors.
* init.c (__gnat_initialize): Adjust comments to match the just
reverted meaning of the -static link-time option.
* adaint.c (convert_addresses): Arrange not to define a stub for
mips-irix any more, as we now want to rely on a real version from a
recent libaddr2line.
* a-exexpr.adb: Provide new accessors to a GNAT_GCC occurrence, so that
the personality routine can use them and not have to rely on a C
counterpart of the record anymore. This simplifies maintenance and
relaxes the constraint of having Standard'Maximum_Alignment match
BIGGEST_ALIGNMENT.
Update comments, and add a section on the common header alignment issue.
2004-06-25 Geert Bosch <bosch@gnat.com>
* a-ngelfu.adb (Tanh): Use full 20 digit precision for constants in
polynomial approximation. Fixes inconsistency with Cody/Waite algorithm.
2004-06-25 Robert Dewar <dewar@gnat.com>
* gnat_rm.texi: Fix section on component clauses to indicate that the
restriction on byte boundary placement still applies for bit packed
arrays.
Add comment on stack usage from Initialize_Scalars
* gnat_ugn.texi: Add documentation for -gnatyLnnn
* stylesw.ads, stylesw.adb: Implement new -gnatyLnnn option for
limiting nesting level.
* usage.adb: Add line for -gnatyLnnn switch
* g-debpoo.ads, xtreeprs.adb, sinput.ads, sem_ch13.ads,
sem_ch13.adb, exp_aggr.adb: Minor reformatting
* sem_prag.adb (Process_Atomic_Shared_Volatile): Set Is_Atomic on base
type as well as on the subtype. This corrects a problem in freeze in
setting alignments of atomic types.
* sem_eval.ads: Minor comment typo fixed
* par-util.adb (Push_Scope_Stack): Check for violation of max nesting
level. Minor reformatting.
* fname.adb (Is_Predefined_File_Name): Require a letter after the
minus sign. This means that file names like a--b.adb will not be
considered predefined.
* freeze.adb: Propagate new flag Must_Be_On_Byte_Boundary to containing
record Test new flag and give diagnostic for bad component clause.
(Freeze_Entity): Set alignment of array from component alignment in
cases where this is safe to do.
* exp_pakd.adb: Set new flag Must_Be_On_Byte_Boundary for large packed
arrays.
* cstand.adb: (Create_Standard): Set alignment of String to 1
* einfo.ads, einfo.adb: Introduce new flag Must_Be_On_Byte_Boundary
* exp_ch4.adb (Expand_Array_Equality): Improve efficiency of generated
code in the common constrained array cases.
* a-storio.adb: Change implementation to avoid possible alignment
problems on machines requiring strict alignment (data should be moved
as type Buffer, not type Elmt).
* checks.adb (Apply_Array_Size_Check): Improve these checks by
killing the overflow checks which we really do not need (64-bits is
enough).
2004-06-25 Vincent Celier <celier@gnat.com>
* makegpr.adb (Is_Included_In_Global_Archive): New Boolean function
(Add_Archives.Recursive_Add_Archives): Call Add_Archive_Path
inconditionally for the main project.
(Recursive_Add_Archives.Add_Archive_Path): New procedure
(Link_Executables.Check_Time_Stamps): New procedure
(Link_Executables.Link_Foreign): New procedure
Changes made to reduce nesting level of this package
(Check): New procedure
(Add_Switches): When not in quiet output, check that a switch is not
the concatenation of several valid switches. If it is, issue a warning.
(Build_Global_Archive): If the global archive is rebuilt, linking need
to be done.
(Compile_Sources): Rebuilding a library archive does not imply
rebuilding the global archive.
(Build_Global_Archive): New procedure
(Build_Library): New name for Build_Archive, now only for library
project
(Check_Archive_Builder): New procedure
(Create_Global_Archive_Dependency_File): New procedure
(Gprmake): Call Build_Global_Archive before linking
* makegpr.adb: Use Other_Sources_Present instead of Sources_Present
throughout.
(Scan_Arg): Display the Copyright notice when -v is used
* gnat_ugn.texi: Document new switch -files= (VMS qualifier /FILES=)
for gnatls.
* vms_data.ads: Add qualifier /MAX_NESTING=nnn (-gnatyLnnn) for GNAT
COMPILE.
Add new GNAT LIST qualifier /FILES=
Added qualifier /DIRECTORY= to GNAT METRIC
Added qualifier /FILES= to GNAT METRIC
Added qualifier /FILES to GNAT PRETTY
* switch.adb (Is_Front_End_Switch): Refine the test for --RTS or -fRTS,
to take into account both versions of the switch.
* switch-c.adb (Scan_Front_End_Switches): New switch -gnatez. Should
always be the last switch to the gcc driver. Disable switch storing so
that switches automatically added by the gcc driver are not put in the
ALI file.
* prj.adb (Project_Empty): Take into account changes in components of
Project_Data.
* prj.ads (Languages_Processed): New enumaration value All_Languages.
* prj.ads (Project_Data): Remove component Lib_Elaboration: never
used. Split Boolean component Ada_Sources_Present in two Boolean
components Ada_Sources_Present and Other_Sources_Present.
Minor reformatting
* prj-env.adb (For_All_Source_Dirs.Add): Use Ada_Sources_Present
instead of Sources_Present.
(Set_Ada_Paths.Add.Recursive_Add): Ditto
* prj-nmsc.adb: Minor reformatting
(Check_Ada_Naming_Scheme): New name of procedure Check_Naming_Scheme
(Check_Ada_Naming_Scheme_Validity): New name of previous procedure
Check_Ada_Naming_Scheme.
Change Sources_Present to Ada_Sources_Present or Other_Sources_Present
throughout.
* prj-part.adb (Post_Parse_Context_Clause): New Boolean parameter
In_Limited.
Make sure that all cycles where there is at least one "limited with"
are detected.
(Parse_Single_Project): New Boolean parameter In_Limited
* prj-proc.adb (Recursive_Check): When Process_Languages is
All_Languages, call first Prj.Nmsc.Ada_Check, then
Prj.Nmsc.Other_Languages_Check.
* prj-proc.adb (Process): Use Ada_Sources_Present or
Other_Sources_Present (instead of Sources_Present) depending on
Process_Languages.
* lang-specs.h: Keep -g and -m switches in the same order, and as the
last switches.
* lib.adb (Switch_Storing_Enabled): New global Boolean flag
(Disable_Switch_Storing): New procedure. Set Switch_Storing_Enabled to
False.
(Store_Compilation_Switch): Do nothing if Switch_Storing_Enabled is
False.
* lib.ads (Disable_Switch_Storing): New procedure.
* make.adb: Modifications to reduce nesting level of this package.
(Check_Standard_Library): New procedure
(Gnatmake.Check_Mains): New procedure
(Gnatmake.Create_Binder_Mapping_File): New procedure
(Compile_Sources.Compile): Add switch -gnatez as the last option
(Display): Never display -gnatez
* Makefile.generic:
When using $(MAIN_OBJECT), always use $(OBJ_DIR)/$(MAIN_OBJECT)
* gnatcmd.adb (Check_Project): New function
(Process_Link): New procedure to reduce nesting depth
(Check_Files): New procedure to reduce the nesting depth.
For GNAT METRIC, include the inherited sources in extending projects.
(GNATCmd): When GNAT LS is invoked with a project file and no files,
add the list of files from the sources of the project file. If this list
is too long, put it in a temp text files and use switch -files=
(Delete_Temp_Config_Files): Delete the temp text file that contains
a list of source for gnatpp or gnatmetric, if one has been created.
(GNATCmd): For GNAT METRIC and GNAT PRETTY, if the number of sources
in the project file is too large, create a temporary text file that
list them and pass it to the tool with "-files=<temp text file>".
(GNATCmd): For GNAT METRIC add "-d=<abject dir>" as the first switch
* gnatlink.adb (Gnatlink): Do not compile with --RTS= when the
generated file is in not in Ada.
* gnatls.adb: Remove all parameters And_Save that are no longer used.
(Scan_Ls_Arg): Add processing for -files=
(Usage): Add line for -files=
* g-os_lib.adb (On_Windows): New global constant Boolean flag
(Normalize_Pathname): When on Windows and the path starts with a
directory separator, make sure that the resulting path will start with
a drive letter.
* clean.adb (Clean_Archive): New procedure
(Clean_Project): When there is non-Ada code, delete the global archive,
the archive dependency files, the object files and their dependency
files, if they exist.
(Gnatclean): Call Prj.Pars.Parse for All_Languages, not for Ada only.
2004-06-25 Thomas Quinot <quinot@act-europe.fr>
* sinfo.ads: Fix typo in comment.
* sem_dist.adb (Process_Remote_AST_Attribute): Simplify code that uses
the TSS for remote access-to-subprogram types, since these TSS are
always present once the type has been analyzed.
(RAS_E_Dereference): Same.
* sem_attr.adb (Analyze_Attribute): When analysis of an attribute
reference raises Bad_Attribute, mark the reference as analyzed so the
node (and any children resulting from rewrites that could have occurred
during the analysis that ultimately failed) is not analyzed again.
* exp_ch7.ads (Find_Final_List): Fix misaligned comment.
* exp_dist.adb: Minor comment fix.
* exp_ch4.adb (Expand_N_Allocator): For an allocator whose expected
type is an anonymous access type, no unchecked deallocation of the
allocated object can occur. If the object is controlled, attach it with
a count of 1. This allows attachment to the Global_Final_List, if
no other relevant list is available.
(Get_Allocator_Final_List): For an anonymous access type that is
the type of a discriminant or record component, the corresponding
finalisation list is the one of the scope of the type.
2004-06-25 Ed Schonberg <schonberg@gnat.com>
* sem_ch3.adb (Replace_Type): When computing the signature of an
inherited subprogram, use the first subtype if the derived type
declaration has no constraint.
* exp_ch6.adb (Add_Call_By_Copy_Code): Check that formal is an array
before applying previous optimization. Minor code cleanup.
* exp_util.adb (Is_Possibly_Unaligned_Slice): If the component is
placed at the beginning of an unpacked record without explicit
alignment, a slice of it will be aligned and does not need a copy when
used as an actual.
2004-06-25 Ed Schonberg <schonberg@gnat.com>
PR ada/15591
PR ada/15592
* sem_ch8.adb (Attribute_Renaming): Reject renaming if the attribute
reference is written with expressions mimicking parameters.
2004-06-25 Hristian Kirtchev <kirtchev@gnat.com>
PR ada/15589
* sem_ch3.adb (Build_Derived_Record_Type): Add additional check to
STEP 2a. The constraints of a full type declaration of a derived record
type are checked for conformance with those declared in the
corresponding private extension declaration. The message
"not conformant with previous declaration" is emitted if an error is
detected.
2004-06-25 Vasiliy Fofanov <fofanov@act-europe.fr>
* g-traceb.ads: Document the need for -E binder switch in the spec.
* g-trasym.ads: Document the need for -E binder switch in the spec.
2004-06-25 Jose Ruiz <ruiz@act-europe.fr>
* sem_prag.adb: Add handling of pragma Detect_Blocking.
* snames.h, snames.ads, snames.adb: Add entry for pragma
Detect_Blocking.
* s-rident.ads: Change reference to pragma Detect_Blocking.
* targparm.ads, targparm.adb: Allow pragma Detect_Blocking in
system.ads.
* opt.ads (Detect_Blocking): New Boolean variable (defaulted to False)
to indicate whether pragma Detect_Blocking is active.
* par-prag.adb: Add entry for pragma Detect_Blocking.
* rtsfind.adb (RTU_Loaded): Fix the temporary kludge to get past bug
of not handling WITH.
Note that this replaces the previous update which was incorrect.
2004-06-25 Javier Miranda <miranda@gnat.com>
* sem_ch10.adb (Re_Install_Use_Clauses): Force the installation of the
use-clauses to have a clean environment.
* sem_ch8.adb (Install_Use_Clauses): Addition of a new formal to force
the installation of the use-clauses to stablish a clean environment in
case of compilation of a separate unit; otherwise the call to
use_one_package is protected by the barrier Applicable_Use.
* sem_ch8.ads (Install_Use_Clauses): Addition of a new formal to force
the installation of the use-clauses to stablish a clean environment in
case of compilation of a separate unit.
(End_Use_Clauses): Minor comment cleanup.
2004-06-25 Sergey Rybin <rybin@act-europe.fr>
* gnat_ugn.texi: Add description of the gnatpp 'files' switch
2004-06-23 Richard Henderson <rth@redhat.com>
* trans.c (gnat_gimplify_stmt): Update gimplify_type_sizes call.

6
gcc/ada/Makefile.generic
View File

@ -374,13 +374,13 @@ else
link: $(LINKER) archive-objects force
@$(display) $(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES)
@$(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS) $(FLDFLAGS)
-largs $(OBJ_DIR)/$(MAIN_OBJECT) $(LARGS) $(LDFLAGS) $(FLDFLAGS)
internal-build: $(LINKER) archive-objects force
@$(display) $(GNATMAKE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(display) $(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS)
@$(GNATMAKE) $(EXEC_RULE) \
-B -P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
-largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS) $(FLDFLAGS)
-largs $(OBJ_DIR)/$(MAIN_OBJECT) $(LARGS) $(LDFLAGS) $(FLDFLAGS)
endif
else

5
gcc/ada/Makefile.in
View File

@ -1204,8 +1204,8 @@ endif
$(LIBGNAT_TARGET_PAIRS_AUX2)
ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),)
TOOLS_TARGET_PAIRS= \
mlib-tgt.adb<mlib-tgt-vms-ia64.adb \
TOOLS_TARGET_PAIRS= \
mlib-tgt.adb<mlib-tgt-vms-ia64.adb \
symbols.adb<symbols-vms-ia64.adb
else
TOOLS_TARGET_PAIRS= \
@ -1246,6 +1246,7 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
s-osprim.adb<s-osprim-mingw.adb \
s-taprop.adb<s-taprop-mingw.adb \
s-taspri.ads<s-taspri-mingw.ads \
s-parame.adb<s-parame-mingw.adb \
g-socthi.ads<g-socthi-mingw.ads \
g-socthi.adb<g-socthi-mingw.adb \
g-soccon.ads<g-soccon-mingw.ads \

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

@ -106,7 +106,7 @@ package body Exception_Propagation is
type Unwind_Word is mod 2 ** System.Word_Size;
for Unwind_Word'Size use System.Word_Size;
-- Map the corresponding C type used in Unwind_Exception below.
-- Map the corresponding C type used in Unwind_Exception below
type Unwind_Exception is record
Class : Exception_Class := GNAT_Exception_Class;
@ -114,46 +114,36 @@ package body Exception_Propagation is
Private1 : Unwind_Word;
Private2 : Unwind_Word;
end record;
-- Map the GCC struct used for exception handling.
-- Map the GCC struct used for exception handling
for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
-- The C++ ABI mandates the common exception header to be at least
-- doubleword aligned, and the libGCC implementation actually makes it
-- maximally aligned (see unwind.h). We need to match this because:
-- 1/ We pass pointers to such headers down to the underlying
-- libGCC unwinder,
-- and
-- 2/ The GNAT_GCC_Exception record below starts with this common
-- common header and has a C counterpart which needs to be laid
-- out identically in raise.c. If the alignment of the C and Ada
-- common headers mismatch, their size may also differ, and the
-- layouts may not match anymore.
-- maximally aligned (see unwind.h). See additional comments on the
-- alignment below.
---------------------------------------------------------------
-- GNAT specific entities to deal with the GCC eh circuitry --
---------------------------------------------------------------
-- A GNAT exception object to be dealt with by the personality routine
-- called by the GCC unwinding runtime. This structure shall match the
-- one in raise.c and is currently experimental as it might be merged
-- with the GNAT runtime definition some day.
-- called by the GCC unwinding runtime.
type GNAT_GCC_Exception is record
Header : Unwind_Exception;
-- ABI Exception header first.
Id : Exception_Id;
-- GNAT Exception identifier. This is used by the personality
-- routine to determine if the context it examines contains a
-- handler for the exception beeing propagated.
-- GNAT Exception identifier. This is filled by Propagate_Exception
-- and then used by the personality routine to determine if the context
-- it examines contains a handler for the exception beeing propagated.
N_Cleanups_To_Trigger : Integer;
-- Number of cleanup only frames encountered in SEARCH phase.
-- This is used to control the forced unwinding triggered when
-- no handler has been found.
-- Number of cleanup only frames encountered in SEARCH phase. This is
-- initialized to 0 by Propagate_Exception and maintained by the
-- personality routine to control a forced unwinding phase triggering
-- all the cleanups before calling Unhandled_Exception_Terminate when
-- an exception is not handled.
Next_Exception : EOA;
-- Used to create a linked list of exception occurrences.
@ -161,6 +151,23 @@ package body Exception_Propagation is
pragma Convention (C, GNAT_GCC_Exception);
-- There is a subtle issue with the common header alignment, since the C
-- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
-- Standard'Maximum_Alignment, and those two values don't quite represent
-- the same concepts and so may be decoupled someday. One typical reason
-- is that BIGGEST_ALIGNMENT may be larger than what the underlying system
-- allocator guarantees, and there are extra costs involved in allocating
-- objects aligned to such factors.
-- To deal with the potential alignment differences between the C and Ada
-- representations, the Ada part of the whole structure is only accessed
-- by the personality routine through the accessors declared below. Ada
-- specific fields are thus always accessed through consistent layout, and
-- we expect the actual alignment to always be large enough to avoid traps
-- from the C accesses to the common header. Besides, accessors aleviate
-- the need for a C struct whole conterpart, both painful and errorprone
-- to maintain anyway.
type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
function To_GNAT_GCC_Exception is new
@ -251,6 +258,15 @@ package body Exception_Propagation is
function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code;
pragma Export (C, Import_Code_For, "__gnat_import_code_for");
function EID_For (GNAT_Exception : GNAT_GCC_Exception_Access)
return Exception_Id;
pragma Export (C, EID_For, "__gnat_eid_for");
procedure Adjust_N_Cleanups_For
(GNAT_Exception : GNAT_GCC_Exception_Access;
Adjustment : Integer);
pragma Export (C, Adjust_N_Cleanups_For, "__gnat_adjust_n_cleanups_for");
------------
-- Remove --
------------
@ -457,6 +473,7 @@ package body Exception_Propagation is
-- already been performed by Propagate_Exception. This hook remains for
-- potential future necessity in optimizing the overall scheme, as well
-- a useful debugging tool.
null;
end Begin_Handler;
@ -466,7 +483,6 @@ package body Exception_Propagation is
procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
Removed : Boolean;
begin
Removed := Remove (Get_Current_Excep.all, GCC_Exception);
pragma Assert (Removed);
@ -553,6 +569,30 @@ package body Exception_Propagation is
Unhandled_Exception_Terminate;
end Propagate_Exception;
---------------------------
-- Adjust_N_Cleanups_For --
---------------------------
procedure Adjust_N_Cleanups_For
(GNAT_Exception : GNAT_GCC_Exception_Access;
Adjustment : Integer)
is
begin
GNAT_Exception.N_Cleanups_To_Trigger :=
GNAT_Exception.N_Cleanups_To_Trigger + Adjustment;
end Adjust_N_Cleanups_For;
-------------
-- EID_For --
-------------
function EID_For
(GNAT_Exception : GNAT_GCC_Exception_Access) return Exception_Id
is
begin
return GNAT_Exception.Id;
end EID_For;
---------------------
-- Import_Code_For --
---------------------
@ -612,29 +652,29 @@ package body Exception_Propagation is
-- An attempt was made to use the Private_Data pointer for this purpose.
-- It did not work because:
-- 1/ The Private_Data has to be saved by Save_Occurrence to be usable
-- 1) The Private_Data has to be saved by Save_Occurrence to be usable
-- as a key in case of a later reraise,
-- 2/ There is no easy way to synchronize End_Handler for an occurrence
-- 2) There is no easy way to synchronize End_Handler for an occurrence
-- and the data attached to potential copies, so these copies may end
-- up pointing to stale data. Moreover ...
-- 3/ The same address may be reused for different occurrences, which
-- 3) The same address may be reused for different occurrences, which
-- defeats the idea of using it as a key.
-- The example below illustrates:
-- Saved_CE : Exception_Occurrence;
--
-- begin
-- raise Constraint_Error;
-- exception
-- when CE: others =>
-- Save_Occurrence (Saved_CE, CE); <= Saved_CE.PDA = CE.PDA
-- end;
--
-- <= Saved_CE.PDA is stale (!)
--
-- begin
-- raise Program_Error; <= Saved_CE.PDA = PE.PDA (!!)
-- exception

18
gcc/ada/a-ngelfu.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2002, 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- --
@ -992,16 +992,16 @@ package body Ada.Numerics.Generic_Elementary_Functions is
----------
function Tanh (X : Float_Type'Base) return Float_Type'Base is
P0 : constant Float_Type'Base := -0.16134_11902E4;
P1 : constant Float_Type'Base := -0.99225_92967E2;
P2 : constant Float_Type'Base := -0.96437_49299E0;
P0 : constant Float_Type'Base := -0.16134_11902_39962_28053E+4;
P1 : constant Float_Type'Base := -0.99225_92967_22360_83313E+2;
P2 : constant Float_Type'Base := -0.96437_49277_72254_69787E+0;
Q0 : constant Float_Type'Base := 0.48402_35707E4;
Q1 : constant Float_Type'Base := 0.22337_72071E4;
Q2 : constant Float_Type'Base := 0.11274_47438E3;
Q3 : constant Float_Type'Base := 0.10000000000E1;
Q0 : constant Float_Type'Base := 0.48402_35707_19886_88686E+4;
Q1 : constant Float_Type'Base := 0.22337_72071_89623_12926E+4;
Q2 : constant Float_Type'Base := 0.11274_47438_05349_49335E+3;
Q3 : constant Float_Type'Base := 0.10000_00000_00000_00000E+1;
Half_Ln3 : constant Float_Type'Base := 0.54930_61443;
Half_Ln3 : constant Float_Type'Base := 0.54930_61443_34054_84570;
P, Q, R : Float_Type'Base;
Y : constant Float_Type'Base := abs X;

21
gcc/ada/a-storio.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992,1993,1994 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,32 +31,31 @@
-- --
------------------------------------------------------------------------------
with System.Address_To_Access_Conversions;
with Unchecked_Conversion;
package body Ada.Storage_IO is
package Element_Ops is new
System.Address_To_Access_Conversions (Element_Type);
type Buffer_Ptr is access all Buffer_Type;
type Elmt_Ptr is access all Element_Type;
function To_Buffer_Ptr is new Unchecked_Conversion (Elmt_Ptr, Buffer_Ptr);
----------
-- Read --
----------
procedure Read (Buffer : in Buffer_Type; Item : out Element_Type) is
procedure Read (Buffer : Buffer_Type; Item : out Element_Type) is
begin
Element_Ops.To_Pointer (Item'Address).all :=
Element_Ops.To_Pointer (Buffer'Address).all;
To_Buffer_Ptr (Item'Unrestricted_Access).all := Buffer;
end Read;
-----------
-- Write --
-----------
procedure Write (Buffer : out Buffer_Type; Item : in Element_Type) is
procedure Write (Buffer : out Buffer_Type; Item : Element_Type) is
begin
Element_Ops.To_Pointer (Buffer'Address).all :=
Element_Ops.To_Pointer (Item'Address).all;
Buffer := To_Buffer_Ptr (Item'Unrestricted_Access).all;
end Write;
end Ada.Storage_IO;

10
gcc/ada/a-strmap.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@ -40,8 +40,6 @@ with Ada.Characters.Latin_1;
package Ada.Strings.Maps is
pragma Preelaborate (Maps);
package L renames Ada.Characters.Latin_1;
--------------------------------
-- Character Set Declarations --
--------------------------------
@ -139,10 +137,6 @@ pragma Preelaborate (Maps);
type Character_Mapping_Function is
access function (From : in Character) return Character;
------------------
-- Private Part --
------------------
private
pragma Inline (Is_In);
pragma Inline (Value);
@ -161,6 +155,8 @@ private
type Character_Mapping is array (Character) of Character;
package L renames Ada.Characters.Latin_1;
Identity : constant Character_Mapping :=
(L.NUL & -- NUL 0
L.SOH & -- SOH 1

3
gcc/ada/adaint.c
View File

@ -2444,7 +2444,8 @@ _flush_cache()
&& ! defined (hpux) \
&& ! defined (_AIX) \
&& ! (defined (__alpha__) && defined (__osf__)) \
&& ! defined (__MINGW32__))
&& ! defined (__MINGW32__) \
&& ! (defined (__mips) && defined (__sgi)))
/* Dummy function to satisfy g-trasym.o. Currently Solaris sparc, HP/UX,
GNU/Linux x86, Tru64 & Windows provide a non-dummy version of this

255
gcc/ada/checks.adb
View File

@ -695,6 +695,17 @@ package body Checks is
-- and perhaps this is not quite the right value, but it is good
-- enough to catch the normal cases (and the relevant ACVC tests!)
-- The situation is as follows. In GNAT 3 (GCC 2.x), the size in bits
-- is computed in 32 bits without an overflow check. That's a real
-- problem for Ada. So what we do in GNAT 3 is to approximate the
-- size of an array by manually multiplying the element size by the
-- number of elements, and comparing that against the allowed limits.
-- In GNAT 5, the size in byte is still computed in 32 bits without
-- an overflow check in the dynamic case, but the size in bits is
-- computed in 64 bits. We assume that's good enough, so we use the
-- size in bits for the test.
procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ctyp : constant Entity_Id := Component_Type (Typ);
@ -774,13 +785,19 @@ package body Checks is
-- Start of processing for Apply_Array_Size_Check
begin
if not Expander_Active
or else Storage_Checks_Suppressed (Typ)
then
-- No need for a check if not expanding
if not Expander_Active then
return;
end if;
-- It is pointless to insert this check inside an init proc, because
-- No need for a check if checks are suppressed
if Storage_Checks_Suppressed (Typ) then
return;
end if;
-- It is pointless to insert this check inside an init proc, because
-- that's too late, we have already built the object to be the right
-- size, and if it's too large, too bad!
@ -803,112 +820,151 @@ package body Checks is
end if;
end loop;
-- First step is to calculate the maximum number of elements. For this
-- calculation, we use the actual size of the subtype if it is static,
-- and if a bound of a subtype is non-static, we go to the bound of the
-- base type.
-- GCC 3 case
Siz := Uint_1;
Indx := First_Index (Typ);
while Present (Indx) loop
Xtyp := Etype (Indx);
Lo := Type_Low_Bound (Xtyp);
Hi := Type_High_Bound (Xtyp);
if Opt.GCC_Version = 3 then
-- If any bound raises constraint error, we will never get this
-- far, so there is no need to generate any kind of check.
-- No problem if size is known at compile time (even if the front
-- end does not know it) because the back end does do overflow
-- checking on the size in bytes if it is compile time known.
if Raises_Constraint_Error (Lo)
if Size_Known_At_Compile_Time (Typ) then
return;
end if;
-- No problem on 64-bit machines, we just don't bother with
-- the case where the size in bytes overflows 64-bits.
if System_Address_Size = 64 then
return;
end if;
end if;
-- Following code is temporarily deleted, since GCC 3 is returning
-- zero for size in bits of large dynamic arrays. ???
-- -- Otherwise we check for the size in bits exceeding 2**31-1 * 8.
-- -- This is the case in which we could end up with problems from
-- -- an unnoticed overflow in computing the size in bytes
--
-- Check_Siz := (Uint_2 ** 31 - Uint_1) * Uint_8;
--
-- Sizx :=
-- Make_Attribute_Reference (Loc,
-- Prefix => New_Occurrence_Of (Typ, Loc),
-- Attribute_Name => Name_Size);
-- GCC 2 case (for now this is for GCC 3 dynamic case as well)
begin
-- First step is to calculate the maximum number of elements. For
-- this calculation, we use the actual size of the subtype if it is
-- static, and if a bound of a subtype is non-static, we go to the
-- bound of the base type.
Siz := Uint_1;
Indx := First_Index (Typ);
while Present (Indx) loop
Xtyp := Etype (Indx);
Lo := Type_Low_Bound (Xtyp);
Hi := Type_High_Bound (Xtyp);
-- If any bound raises constraint error, we will never get this
-- far, so there is no need to generate any kind of check.
if Raises_Constraint_Error (Lo)
or else
Raises_Constraint_Error (Hi)
Raises_Constraint_Error (Hi)
then
Uintp.Release (Umark);
return;
end if;
-- Otherwise get bounds values
if Is_Static_Expression (Lo) then
Lob := Expr_Value (Lo);
else
Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp)));
Static := False;
end if;
if Is_Static_Expression (Hi) then
Hib := Expr_Value (Hi);
else
Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp)));
Static := False;
end if;
Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0);
Next_Index (Indx);
end loop;
-- Compute the limit against which we want to check. For subprograms,
-- where the array will go on the stack, we use 8*2**24, which (in
-- bits) is the size of a 16 megabyte array.
if Is_Subprogram (Scope (Ent)) then
Check_Siz := Uint_2 ** 27;
else
Check_Siz := Uint_2 ** 31;
end if;
-- If we have all static bounds and Siz is too large, then we know
-- we know we have a storage error right now, so generate message
if Static and then Siz >= Check_Siz then
Insert_Action (N,
Make_Raise_Storage_Error (Loc,
Reason => SE_Object_Too_Large));
Error_Msg_N ("?Storage_Error will be raised at run-time", N);
Uintp.Release (Umark);
return;
end if;
-- Case of component size known at compile time. If the array
-- size is definitely in range, then we do not need a check.
if Known_Esize (Ctyp)
and then Siz * Esize (Ctyp) < Check_Siz
then
Uintp.Release (Umark);
return;
end if;
-- Otherwise get bounds values
-- Here if a dynamic check is required
if Is_Static_Expression (Lo) then
Lob := Expr_Value (Lo);
else
Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp)));
Static := False;
end if;
-- What we do is to build an expression for the size of the array,
-- which is computed as the 'Size of the array component, times
-- the size of each dimension.
if Is_Static_Expression (Hi) then
Hib := Expr_Value (Hi);
else
Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp)));
Static := False;
end if;
Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0);
Next_Index (Indx);
end loop;
-- Compute the limit against which we want to check. For subprograms,
-- where the array will go on the stack, we use 8*2**24, which (in
-- bits) is the size of a 16 megabyte array.
if Is_Subprogram (Scope (Ent)) then
Check_Siz := Uint_2 ** 27;
else
Check_Siz := Uint_2 ** 31;
end if;
-- If we have all static bounds and Siz is too large, then we know we
-- know we have a storage error right now, so generate message
if Static and then Siz >= Check_Siz then
Insert_Action (N,
Make_Raise_Storage_Error (Loc,
Reason => SE_Object_Too_Large));
Error_Msg_N ("?Storage_Error will be raised at run-time", N);
Uintp.Release (Umark);
return;
end if;
-- Case of component size known at compile time. If the array
-- size is definitely in range, then we do not need a check.
if Known_Esize (Ctyp)
and then Siz * Esize (Ctyp) < Check_Siz
then
Uintp.Release (Umark);
return;
end if;
-- Here if a dynamic check is required
-- What we do is to build an expression for the size of the array,
-- which is computed as the 'Size of the array component, times
-- the size of each dimension.
Uintp.Release (Umark);
Sizx :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ctyp, Loc),
Attribute_Name => Name_Size);
Indx := First_Index (Typ);
for J in 1 .. Number_Dimensions (Typ) loop
if Sloc (Etype (Indx)) = Sloc (N) then
Ensure_Defined (Etype (Indx), N);
end if;
Sizx :=
Make_Op_Multiply (Loc,
Left_Opnd => Sizx,
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Length,
Expressions => New_List (
Make_Integer_Literal (Loc, J))));
Next_Index (Indx);
end loop;
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ctyp, Loc),
Attribute_Name => Name_Size);
Indx := First_Index (Typ);
for J in 1 .. Number_Dimensions (Typ) loop
if Sloc (Etype (Indx)) = Sloc (N) then
Ensure_Defined (Etype (Indx), N);
end if;
Sizx :=
Make_Op_Multiply (Loc,
Left_Opnd => Sizx,
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Length,
Expressions => New_List (
Make_Integer_Literal (Loc, J))));
Next_Index (Indx);
end loop;
end;
-- Common code to actually emit the check
Code :=
Make_Raise_Storage_Error (Loc,
@ -916,11 +972,12 @@ package body Checks is
Make_Op_Ge (Loc,
Left_Opnd => Sizx,
Right_Opnd =>
Make_Integer_Literal (Loc, Check_Siz)),
Reason => SE_Object_Too_Large);
Make_Integer_Literal (Loc,
Intval => Check_Siz)),
Reason => SE_Object_Too_Large);
Set_Size_Check_Code (Defining_Identifier (N), Code);
Insert_Action (N, Code);
Insert_Action (N, Code, Suppress => All_Checks);
end Apply_Array_Size_Check;
----------------------------

358
gcc/ada/clean.adb
View File

@ -31,6 +31,7 @@ with Csets;
with Gnatvsn;
with Hostparm;
with Makeutl; use Makeutl;
with MLib.Tgt; use MLib.Tgt;
with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
@ -182,6 +183,10 @@ package body Clean is
function Assembly_File_Name (Source : Name_Id) return String;
-- Returns the assembly file name corresponding to Source
procedure Clean_Archive (Project : Project_Id);
-- Delete a global archive or a fake library project archive and the
-- dependency file, if they exist.
procedure Clean_Directory (Dir : Name_Id);
-- Delete all regular files in a library directory or in a library
-- interface dir.
@ -314,6 +319,39 @@ package body Clean is
return Src & Assembly_Suffix;
end Assembly_File_Name;
-------------------
-- Clean_Archive --
-------------------
procedure Clean_Archive (Project : Project_Id) is
Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
Data : constant Project_Data := Projects.Table (Project);
Archive_Name : constant String :=
"lib" & Get_Name_String (Data.Name) & '.' & Archive_Ext;
-- The name of the archive file for this project
Archive_Dep_Name : constant String :=
"lib" & Get_Name_String (Data.Name) & ".deps";
-- The name of the archive dependency file for this project
Obj_Dir : constant String := Get_Name_String (Data.Object_Directory);
begin
Change_Dir (Obj_Dir);
if Is_Regular_File (Archive_Name) then
Delete (Obj_Dir, Archive_Name);
end if;
if Is_Regular_File (Archive_Dep_Name) then
Delete (Obj_Dir, Archive_Dep_Name);
end if;
Change_Dir (Current_Dir);
end Clean_Archive;
---------------------
-- Clean_Directory --
---------------------
@ -534,6 +572,11 @@ package body Clean is
Index2 : Int;
Lib_File : File_Name_Type;
Source_Id : Other_Source_Id;
Source : Other_Source;
Global_Archive : Boolean := False;
use Prj.Com;
begin
@ -567,141 +610,221 @@ package body Clean is
begin
Change_Dir (Obj_Dir);
-- First, deal with Ada.
-- Look through the units to find those that are either immediate
-- sources or inherited sources of the project.
for Unit in 1 .. Prj.Com.Units.Last loop
U_Data := Prj.Com.Units.Table (Unit);
File_Name1 := No_Name;
File_Name2 := No_Name;
if Data.Languages (Lang_Ada) then
for Unit in 1 .. Prj.Com.Units.Last loop
U_Data := Prj.Com.Units.Table (Unit);
File_Name1 := No_Name;
File_Name2 := No_Name;
-- If either the spec or the body is a source of the project,
-- check for the corresponding ALI file in the object
-- directory.
-- If either the spec or the body is a source of the
-- project, check for the corresponding ALI file in the
-- object directory.
if In_Extension_Chain
(U_Data.File_Names (Body_Part).Project, Project)
or else
In_Extension_Chain
(U_Data.File_Names (Specification).Project, Project)
then
File_Name1 := U_Data.File_Names (Body_Part).Name;
Index1 := U_Data.File_Names (Body_Part).Index;
File_Name2 := U_Data.File_Names (Specification).Name;
Index2 := U_Data.File_Names (Specification).Index;
if In_Extension_Chain
(U_Data.File_Names (Body_Part).Project, Project)
or else
In_Extension_Chain
(U_Data.File_Names (Specification).Project, Project)
then
File_Name1 := U_Data.File_Names (Body_Part).Name;
Index1 := U_Data.File_Names (Body_Part).Index;
File_Name2 := U_Data.File_Names (Specification).Name;
Index2 := U_Data.File_Names (Specification).Index;
-- If there is no body file name, then there may be only a
-- spec.
-- If there is no body file name, then there may be only
-- a spec.
if File_Name1 = No_Name then
File_Name1 := File_Name2;
Index1 := Index2;
File_Name2 := No_Name;
Index2 := 0;
if File_Name1 = No_Name then
File_Name1 := File_Name2;
Index1 := Index2;
File_Name2 := No_Name;
Index2 := 0;
end if;
end if;
end if;
-- If there is either a spec or a body, look for files in the
-- object directory.
-- If there is either a spec or a body, look for files
-- in the object directory.
if File_Name1 /= No_Name then
Lib_File := Osint.Lib_File_Name (File_Name1, Index1);
if File_Name1 /= No_Name then
Lib_File := Osint.Lib_File_Name (File_Name1, Index1);
declare
Asm : constant String := Assembly_File_Name (Lib_File);
ALI : constant String := ALI_File_Name (Lib_File);
Obj : constant String := Object_File_Name (Lib_File);
Adt : constant String := Tree_File_Name (Lib_File);
Deb : constant String := Debug_File_Name (File_Name1);
Rep : constant String := Repinfo_File_Name (File_Name1);
Del : Boolean := True;
declare
Asm : constant String := Assembly_File_Name (Lib_File);
ALI : constant String := ALI_File_Name (Lib_File);
Obj : constant String := Object_File_Name (Lib_File);
Adt : constant String := Tree_File_Name (Lib_File);
Deb : constant String :=
Debug_File_Name (File_Name1);
Rep : constant String :=
Repinfo_File_Name (File_Name1);
Del : Boolean := True;
begin
-- If the ALI file exists and is read-only, no file is
-- deleted.
begin
-- If the ALI file exists and is read-only, no file
-- is deleted.
if Is_Regular_File (ALI) then
if Is_Writable_File (ALI) then
Delete (Obj_Dir, ALI);
if Is_Regular_File (ALI) then
if Is_Writable_File (ALI) then
Delete (Obj_Dir, ALI);
else
Del := False;
else
Del := False;
if Verbose_Mode then
Put ('"');
Put (Obj_Dir);
if Verbose_Mode then
Put ('"');
Put (Obj_Dir);
if Obj_Dir (Obj_Dir'Last) /= Dir_Separator then
Put (Dir_Separator);
if Obj_Dir (Obj_Dir'Last) /=
Dir_Separator
then
Put (Dir_Separator);
end if;
Put (ALI);
Put_Line (""" is read-only");
end if;
Put (ALI);
Put_Line (""" is read-only");
end if;
end if;
end if;
if Del then
if Del then
-- Object file
-- Object file
if Is_Regular_File (Obj) then
Delete (Obj_Dir, Obj);
if Is_Regular_File (Obj) then
Delete (Obj_Dir, Obj);
end if;
-- Assembly file
if Is_Regular_File (Asm) then
Delete (Obj_Dir, Asm);
end if;
-- Tree file
if Is_Regular_File (Adt) then
Delete (Obj_Dir, Adt);
end if;
-- First expanded source file
if Is_Regular_File (Deb) then
Delete (Obj_Dir, Deb);
end if;
-- Repinfo file
if Is_Regular_File (Rep) then
Delete (Obj_Dir, Rep);
end if;
-- Second expanded source file
if File_Name2 /= No_Name then
declare
Deb : constant String :=
Debug_File_Name (File_Name2);
Rep : constant String :=
Repinfo_File_Name (File_Name2);
begin
if Is_Regular_File (Deb) then
Delete (Obj_Dir, Deb);
end if;
if Is_Regular_File (Rep) then
Delete (Obj_Dir, Rep);
end if;
end;
end if;
end if;
end;
end if;
end loop;
end if;
-- Assembly file
-- Check if a global archive and it dependency file could have
-- been created and, if they exist, delete them.
if Is_Regular_File (Asm) then
Delete (Obj_Dir, Asm);
end if;
if Project = Main_Project and then not Data.Library then
Global_Archive := False;
-- Tree file
for Proj in 1 .. Projects.Last loop
if Projects.Table (Proj).Other_Sources_Present then
Global_Archive := True;
exit;
end if;
end loop;
if Is_Regular_File (Adt) then
Delete (Obj_Dir, Adt);
end if;
-- First expanded source file
if Is_Regular_File (Deb) then
Delete (Obj_Dir, Deb);
end if;
-- Repinfo file
if Is_Regular_File (Rep) then
Delete (Obj_Dir, Rep);
end if;
-- Second expanded source file
if File_Name2 /= No_Name then
declare
Deb : constant String :=
Debug_File_Name (File_Name2);
Rep : constant String :=
Repinfo_File_Name (File_Name2);
begin
if Is_Regular_File (Deb) then
Delete (Obj_Dir, Deb);
end if;
if Is_Regular_File (Rep) then
Delete (Obj_Dir, Rep);
end if;
end;
end if;
end if;
end;
if Global_Archive then
Clean_Archive (Project);
end if;
end loop;
end if;
if Verbose_Mode then
New_Line;
if Data.Other_Sources_Present then
-- There is non-Ada code: delete the object files and
-- the dependency files, if they exist.
Source_Id := Data.First_Other_Source;
while Source_Id /= No_Other_Source loop
Source := Other_Sources.Table (Source_Id);
if Is_Regular_File
(Get_Name_String (Source.Object_Name))
then
Delete (Obj_Dir, Get_Name_String (Source.Object_Name));
end if;
if Is_Regular_File (Get_Name_String (Source.Dep_Name)) then
Delete (Obj_Dir, Get_Name_String (Source.Dep_Name));
end if;
Source_Id := Source.Next;
end loop;
-- If it is a library with only non Ada sources, delete
-- the fake archive and the dependency file, if they exist.
if Data.Library and then not Data.Languages (Lang_Ada) then
Clean_Archive (Project);
end if;
end if;
end;
end if;
-- If this is a library project, clean the library directory, the
-- interface copy dir and, for a Stand-Alone Library, the binder
-- generated files of the library.
-- The directories are cleaned only if switch -c is not specified.
if Data.Library then
if not Compile_Only then
Clean_Directory (Data.Library_Dir);
if Data.Library_Src_Dir /= No_Name
and then Data.Library_Src_Dir /= Data.Library_Dir
then
Clean_Directory (Data.Library_Src_Dir);
end if;
end if;
if Data.Standalone_Library and then
Data.Object_Directory /= No_Name
then
Delete_Binder_Generated_Files
(Get_Name_String (Data.Object_Directory), Data.Library_Name);
end if;
end if;
if Verbose_Mode then
New_Line;
end if;
-- If switch -r is specified, call Clean_Project recursively for the
-- imported projects and the project being extended.
@ -745,36 +868,12 @@ package body Clean is
end;
end if;
-- If this is a library project, clean the library directory, the
-- interface copy dir and, for a Stand-Alone Library, the binder
-- generated files of the library.
-- The directories are cleaned only if switch -c is not specified.
if Data.Library then
if not Compile_Only then
Clean_Directory (Data.Library_Dir);
if Data.Library_Src_Dir /= No_Name
and then Data.Library_Src_Dir /= Data.Library_Dir
then
Clean_Directory (Data.Library_Src_Dir);
end if;
end if;
if Data.Standalone_Library and then
Data.Object_Directory /= No_Name
then
Delete_Binder_Generated_Files
(Get_Name_String (Data.Object_Directory), Data.Library_Name);
end if;
-- Otherwise, for the main project, delete the executables and the
-- For the main project, delete the executables and the
-- binder generated files.
-- The executables are deleted only if switch -c is not specified.
elsif Project = Main_Project and then Data.Exec_Directory /= No_Name then
if Project = Main_Project and then Data.Exec_Directory /= No_Name then
declare
Exec_Dir : constant String :=
Get_Name_String (Data.Exec_Directory);
@ -1000,7 +1099,8 @@ package body Clean is
Prj.Pars.Parse
(Project => Main_Project,
Project_File_Name => Project_File_Name.all,
Packages_To_Check => Packages_To_Check_By_Gnatmake);
Packages_To_Check => Packages_To_Check_By_Gnatmake,
Process_Languages => All_Languages);
if Main_Project = No_Project then
Fail ("""" & Project_File_Name.all &

2
gcc/ada/cstand.adb
View File

@ -243,7 +243,6 @@ package body CStand is
Set_Etype (First_Entity (Standard_Op_Concatw), Standard_Wide_String);
Set_Etype (Last_Entity (Standard_Op_Concatw), Standard_Wide_String);
end Create_Operators;
---------------------
@ -584,6 +583,7 @@ package body CStand is
Set_Component_Type (Standard_String, Standard_Character);
Set_Component_Size (Standard_String, Uint_8);
Init_Size_Align (Standard_String);
Set_Alignment (Standard_String, Uint_1);
-- Set index type of String

18
gcc/ada/einfo.adb
View File

@ -419,10 +419,9 @@ package body Einfo is
-- Has_Contiguous_Rep Flag181
-- Has_Xref_Entry Flag182
-- Must_Be_On_Byte_Boundary Flag183
-- Remaining flags are currently unused and available
-- (unused) Flag183
-- Note: there are no unused flags currently!
--------------------------------
-- Attribute Access Functions --
@ -1754,6 +1753,12 @@ package body Einfo is
return Uint17 (Base_Type (Id));
end Modulus;
function Must_Be_On_Byte_Boundary (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
return Flag183 (Id);
end Must_Be_On_Byte_Boundary;
function Needs_Debug_Info (Id : E) return B is
begin
return Flag147 (Id);
@ -3712,6 +3717,12 @@ package body Einfo is
Set_Uint17 (Id, V);
end Set_Modulus;
procedure Set_Must_Be_On_Byte_Boundary (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
Set_Flag183 (Id, V);
end Set_Must_Be_On_Byte_Boundary;
procedure Set_Needs_Debug_Info (Id : E; V : B := True) is
begin
Set_Flag147 (Id, V);
@ -6249,6 +6260,7 @@ package body Einfo is
W ("Kill_Tag_Checks", Flag34 (Id));
W ("Machine_Radix_10", Flag84 (Id));
W ("Materialize_Entity", Flag168 (Id));
W ("Must_Be_On_Byte_Boundary", Flag183 (Id));
W ("Needs_Debug_Info", Flag147 (Id));
W ("Needs_No_Actuals", Flag22 (Id));
W ("Never_Set_In_Source", Flag115 (Id));

13
gcc/ada/einfo.ads
View File

@ -2443,6 +2443,14 @@ package Einfo is
-- case, this will be a power of 2, but if Non_Binary_Modulus is
-- set, then it will not be a power of 2.
-- Must_Be_On_Byte_Boundary (Flag183)
-- Present in entities for types and subtypes. Set if objects of
-- the type must always be allocated on a byte boundary (more
-- accurately a storage unit boundary). The front end checks that
-- component clauses respect this rule, and the back end ensures
-- that record packing does not violate this rule. Currently the
-- flag is set only for packed arrays longer than 64 bits.
-- Needs_Debug_Info (Flag147)
-- Present in all entities. Set if the entity requires debugging
-- information to be generated. This is true of all entities that
@ -3995,6 +4003,7 @@ package Einfo is
-- Is_Tagged_Type (Flag55)
-- Is_Unsigned_Type (Flag144)
-- Is_Volatile (Flag16)
-- Must_Be_On_Byte_Boundary (Flag183)
-- Size_Depends_On_Discriminant (Flag177)
-- Size_Known_At_Compile_Time (Flag92)
-- Strict_Alignment (Flag145) (base type only)
@ -5197,6 +5206,7 @@ package Einfo is
function Materialize_Entity (Id : E) return B;
function Mechanism (Id : E) return M;
function Modulus (Id : E) return U;
function Must_Be_On_Byte_Boundary (Id : E) return B;
function Needs_Debug_Info (Id : E) return B;
function Needs_No_Actuals (Id : E) return B;
function Never_Set_In_Source (Id : E) return B;
@ -5671,6 +5681,7 @@ package Einfo is
procedure Set_Materialize_Entity (Id : E; V : B := True);
procedure Set_Mechanism (Id : E; V : M);
procedure Set_Modulus (Id : E; V : U);
procedure Set_Must_Be_On_Byte_Boundary (Id : E; V : B := True);
procedure Set_Needs_Debug_Info (Id : E; V : B := True);
procedure Set_Needs_No_Actuals (Id : E; V : B := True);
procedure Set_Never_Set_In_Source (Id : E; V : B := True);
@ -6197,6 +6208,7 @@ package Einfo is
pragma Inline (Materialize_Entity);
pragma Inline (Mechanism);
pragma Inline (Modulus);
pragma Inline (Must_Be_On_Byte_Boundary);
pragma Inline (Needs_Debug_Info);
pragma Inline (Needs_No_Actuals);
pragma Inline (Never_Set_In_Source);
@ -6506,6 +6518,7 @@ package Einfo is
pragma Inline (Set_Materialize_Entity);
pragma Inline (Set_Mechanism);
pragma Inline (Set_Modulus);
pragma Inline (Set_Must_Be_On_Byte_Boundary);
pragma Inline (Set_Needs_Debug_Info);
pragma Inline (Set_Needs_No_Actuals);
pragma Inline (Set_Never_Set_In_Source);

2
gcc/ada/exp_aggr.adb
View File

@ -4125,7 +4125,7 @@ package body Exp_Aggr is
raise Program_Error;
end if;
-- Name in assignment is explicit dereference.
-- Name in assignment is explicit dereference
Target := New_Copy (Tmp);
end if;

415
gcc/ada/exp_ch4.adb
View File

@ -94,20 +94,21 @@ package body Exp_Ch4 is
function Expand_Array_Equality
(Nod : Node_Id;
Typ : Entity_Id;
A_Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id) return Node_Id;
Bodies : List_Id;
Typ : Entity_Id) return Node_Id;
-- Expand an array equality into a call to a function implementing this
-- equality, and a call to it. Loc is the location for the generated
-- nodes. Typ is the type of the array, and Lhs, Rhs are the array
-- expressions to be compared. A_Typ is the type of the arguments,
-- which may be a private type, in which case Typ is its full view.
-- nodes. Lhs and Rhs are the array expressions to be compared.
-- Bodies is a list on which to attach bodies of local functions that
-- are created in the process. This is the responsibility of the
-- are created in the process. It is the responsibility of the
-- caller to insert those bodies at the right place. Nod provides
-- the Sloc value for the generated code.
-- the Sloc value for the generated code. Normally the types used
-- for the generated equality routine are taken from Lhs and Rhs.
-- However, in some situations of generated code, the Etype fields
-- of Lhs and Rhs are not set yet. In such cases, Typ supplies the
-- type to be used for the formal parameters.
procedure Expand_Boolean_Operator (N : Node_Id);
-- Common expansion processing for Boolean operators (And, Or, Xor)
@ -124,7 +125,8 @@ package body Exp_Ch4 is
-- is a list on which to attach bodies of local functions that are
-- created in the process. This is the responsability of the caller
-- to insert those bodies at the right place. Nod provides the Sloc
-- value for generated code.
-- value for generated code. Lhs and Rhs are the left and right sides
-- for the comparison, and Typ is the type of the arrays to compare.
procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id);
-- This routine handles expansion of concatenation operations, where
@ -570,7 +572,7 @@ package body Exp_Ch4 is
and then Nkind (Exp) = N_Allocator
and then Nkind (Expression (Exp)) /= N_Qualified_Expression
then
-- Apply constraint to designated subtype indication.
-- Apply constraint to designated subtype indication
Apply_Constraint_Check (Expression (Exp),
Designated_Type (Designated_Type (PtrT)),
@ -858,7 +860,7 @@ package body Exp_Ch4 is
-- Expand an equality function for multi-dimensional arrays. Here is
-- an example of such a function for Nb_Dimension = 2
-- function Enn (A : arr; B : arr) return boolean is
-- function Enn (A : atyp; B : btyp) return boolean is
-- begin
-- if (A'length (1) = 0 or else A'length (2) = 0)
-- and then
@ -866,50 +868,49 @@ package body Exp_Ch4 is
-- then
-- return True; -- RM 4.5.2(22)
-- end if;
--
-- if A'length (1) /= B'length (1)
-- or else
-- A'length (2) /= B'length (2)
-- then
-- return False; -- RM 4.5.2(23)
-- end if;
--
-- declare
-- A1 : Index_type_1 := A'first (1)
-- B1 : Index_Type_1 := B'first (1)
-- B1 : Index_T1 := B'first (1)
-- begin
-- loop
-- for A1 in A'range (1) loop
-- declare
-- A2 : Index_type_2 := A'first (2);
-- B2 : Index_type_2 := B'first (2)
-- B2 : Index_T2 := B'first (2)
-- begin
-- loop
-- for A2 in A'range (2) loop
-- if A (A1, A2) /= B (B1, B2) then
-- return False;
-- end if;
--
-- exit when A2 = A'last (2);
-- A2 := Index_type2'succ (A2);
-- B2 := Index_type2'succ (B2);
-- B2 := Index_T2'succ (B2);
-- end loop;
-- end;
--
-- exit when A1 = A'last (1);
-- A1 := Index_type1'succ (A1);
-- B1 := Index_type1'succ (B1);
-- B1 := Index_T1'succ (B1);
-- end loop;
-- end;
--
-- return true;
-- end Enn;
-- Note on the formal types used (atyp and btyp). If either of the
-- arrays is of a private type, we use the underlying type, and
-- do an unchecked conversion of the actual. If either of the arrays
-- has a bound depending on a discriminant, then we use the base type
-- since otherwise we have an escaped discriminant in the function.
function Expand_Array_Equality
(Nod : Node_Id;
Typ : Entity_Id;
A_Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id) return Node_Id
Bodies : List_Id;
Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
Decls : constant List_Id := New_List;
@ -924,6 +925,10 @@ package body Exp_Ch4 is
A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
Ltyp : Entity_Id;
Rtyp : Entity_Id;
-- The parameter types to be used for the formals
function Arr_Attr
(Arr : Entity_Id;
Nam : Name_Id;
@ -934,29 +939,37 @@ package body Exp_Ch4 is
-- Create one statement to compare corresponding components,
-- designated by a full set of indices.
function Get_Arg_Type (N : Node_Id) return Entity_Id;
-- Given one of the arguments, computes the appropriate type to
-- be used for that argument in the corresponding function formal
function Handle_One_Dimension
(N : Int;
Index : Node_Id) return Node_Id;
-- This procedure returns a declare block:
-- This procedure returns the following code
--
-- declare
-- An : Index_Type_n := A'First (n);
-- Bn : Index_Type_n := B'First (n);
-- Bn : Index_T := B'First (n);
-- begin
-- loop
-- for An in A'range (n) loop
-- xxx
-- exit when An = A'Last (n);
-- An := Index_Type_n'Succ (An)
-- Bn := Index_Type_n'Succ (Bn)
-- Bn := Index_T'Succ (Bn)
-- end loop;
-- end;
--
-- Note: we don't need Bn or the declare block when the index types
-- of the two arrays are constrained and identical.
--
-- where N is the value of "n" in the above code. Index is the
-- N'th index node, whose Etype is Index_Type_n in the above code.
-- The xxx statement is either the declare block for the next
-- The xxx statement is either the loop or declare for the next
-- dimension or if this is the last dimension the comparison
-- of corresponding components of the arrays.
--
-- Note: if the index types are identical and constrained, we
-- need only one index, so we generate only An and we do not
-- need the declare block.
--
-- The actual way the code works is to return the comparison
-- of corresponding components for the N+1 call. That's neater!
@ -1025,6 +1038,40 @@ package body Exp_Ch4 is
Expression => New_Occurrence_Of (Standard_False, Loc))));
end Component_Equality;
------------------
-- Get_Arg_Type --
------------------
function Get_Arg_Type (N : Node_Id) return Entity_Id is
T : Entity_Id;
X : Node_Id;
begin
T := Etype (N);
if No (T) then
return Typ;
else
T := Underlying_Type (T);
X := First_Index (T);
while Present (X) loop
if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
or else
Denotes_Discriminant (Type_High_Bound (Etype (X)))
then
T := Base_Type (T);
exit;
end if;
Next_Index (X);
end loop;
return T;
end if;
end Get_Arg_Type;
--------------------------
-- Handle_One_Dimension --
---------------------------
@ -1033,70 +1080,85 @@ package body Exp_Ch4 is
(N : Int;
Index : Node_Id) return Node_Id
is
Need_Separate_Indexes : constant Boolean :=
Ltyp /= Rtyp
or else not Is_Constrained (Ltyp);
-- If the index types are identical, and we are working with
-- constrained types, then we can use the same index for both of
-- the arrays.
An : constant Entity_Id := Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('A'));
Bn : constant Entity_Id := Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('B'));
Index_Type_n : Entity_Id;
Bn : Entity_Id;
Index_T : Entity_Id;
Stm_List : List_Id;
Loop_Stm : Node_Id;
begin
if N > Number_Dimensions (Typ) then
return Component_Equality (Typ);
if N > Number_Dimensions (Ltyp) then
return Component_Equality (Ltyp);
end if;
-- Case where we generate a declare block
-- Case where we generate a loop
Index_T := Base_Type (Etype (Index));
if Need_Separate_Indexes then
Bn :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('B'));
else
Bn := An;
end if;
Index_Type_n := Base_Type (Etype (Index));
Append (New_Reference_To (An, Loc), Index_List1);
Append (New_Reference_To (Bn, Loc), Index_List2);
return
Make_Block_Statement (Loc,
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => An,
Object_Definition =>
New_Reference_To (Index_Type_n, Loc),
Expression => Arr_Attr (A, Name_First, N)),
Stm_List := New_List (
Handle_One_Dimension (N + 1, Next_Index (Index)));
Make_Object_Declaration (Loc,
Defining_Identifier => Bn,
Object_Definition =>
New_Reference_To (Index_Type_n, Loc),
Expression => Arr_Attr (B, Name_First, N))),
if Need_Separate_Indexes then
Append_To (Stm_List,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Bn, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Index_T, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (New_Reference_To (Bn, Loc)))));
end if;
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Implicit_Loop_Statement (Nod,
Statements => New_List (
Handle_One_Dimension (N + 1, Next_Index (Index)),
Loop_Stm :=
Make_Implicit_Loop_Statement (Nod,
Statements => Stm_List,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => An,
Discrete_Subtype_Definition =>
Arr_Attr (A, Name_Range, N))));
Make_Exit_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => New_Reference_To (An, Loc),
Right_Opnd => Arr_Attr (A, Name_Last, N))),
-- If separate indexes, need a declare block to declare Bn
Make_Assignment_Statement (Loc,
Name => New_Reference_To (An, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (Index_Type_n, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (
New_Reference_To (An, Loc)))),
if Need_Separate_Indexes then
return
Make_Block_Statement (Loc,
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Bn,
Object_Definition => New_Reference_To (Index_T, Loc),
Expression => Arr_Attr (B, Name_First, N))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Loop_Stm)));
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Bn, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (Index_Type_n, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (
New_Reference_To (Bn, Loc)))))))));
-- If no separate indexes, return loop statement on its own
else
return Loop_Stm;
end if;
end Handle_One_Dimension;
-----------------------
@ -1113,7 +1175,7 @@ package body Exp_Ch4 is
begin
Alist := Empty;
Blist := Empty;
for J in 1 .. Number_Dimensions (Typ) loop
for J in 1 .. Number_Dimensions (Ltyp) loop
Atest :=
Make_Op_Eq (Loc,
Left_Opnd => Arr_Attr (A, Name_Length, J),
@ -1157,7 +1219,7 @@ package body Exp_Ch4 is
begin
Result := Empty;
for J in 1 .. Number_Dimensions (Typ) loop
for J in 1 .. Number_Dimensions (Ltyp) loop
Rtest :=
Make_Op_Ne (Loc,
Left_Opnd => Arr_Attr (A, Name_Length, J),
@ -1179,14 +1241,29 @@ package body Exp_Ch4 is
-- Start of processing for Expand_Array_Equality
begin
Ltyp := Get_Arg_Type (Lhs);
Rtyp := Get_Arg_Type (Rhs);
-- For now, if the argument types are not the same, go to the
-- base type, since the code assumes that the formals have the
-- same type. This is fixable in future ???
if Ltyp /= Rtyp then
Ltyp := Base_Type (Ltyp);
Rtyp := Base_Type (Rtyp);
pragma Assert (Ltyp = Rtyp);
end if;
-- Build list of formals for function
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => A,
Parameter_Type => New_Reference_To (Typ, Loc)),
Parameter_Type => New_Reference_To (Ltyp, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => B,
Parameter_Type => New_Reference_To (Typ, Loc)));
Parameter_Type => New_Reference_To (Rtyp, Loc)));
Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
@ -1220,30 +1297,45 @@ package body Exp_Ch4 is
Expression =>
New_Occurrence_Of (Standard_False, Loc)))),
Handle_One_Dimension (1, First_Index (Typ)),
Handle_One_Dimension (1, First_Index (Ltyp)),
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_True, Loc)))));
Set_Has_Completion (Func_Name, True);
Set_Is_Inlined (Func_Name);
-- If the array type is distinct from the type of the arguments,
-- it is the full view of a private type. Apply an unchecked
-- conversion to insure that analysis of the call succeeds.
if Base_Type (A_Typ) /= Base_Type (Typ) then
Actuals := New_List (
OK_Convert_To (Typ, Lhs),
OK_Convert_To (Typ, Rhs));
else
Actuals := New_List (Lhs, Rhs);
end if;
declare
L, R : Node_Id;
begin
L := Lhs;
R := Rhs;
if No (Etype (Lhs))
or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
then
L := OK_Convert_To (Ltyp, Lhs);
end if;
if No (Etype (Rhs))
or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
then
R := OK_Convert_To (Rtyp, Rhs);
end if;
Actuals := New_List (L, R);
end;
Append_To (Bodies, Func_Body);
return
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Name, Loc),
Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations => Actuals);
end Expand_Array_Equality;
@ -1370,8 +1462,7 @@ package body Exp_Ch4 is
-- case of any composite type recursively containing such fields.
else
return Expand_Array_Equality
(Nod, Full_Type, Typ, Lhs, Rhs, Bodies);
return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type);
end if;
elsif Is_Tagged_Type (Full_Type) then
@ -2101,6 +2192,7 @@ package body Exp_Ch4 is
procedure Expand_N_Allocator (N : Node_Id) is
PtrT : constant Entity_Id := Etype (N);
Dtyp : constant Entity_Id := Designated_Type (PtrT);
Desig : Entity_Id;
Loc : constant Source_Ptr := Sloc (N);
Temp : Entity_Id;
@ -2172,8 +2264,8 @@ package body Exp_Ch4 is
-- so that the constant is not labelled as having a nomimally
-- unconstrained subtype.
if Entity (Desig) = Base_Type (Designated_Type (PtrT)) then
Desig := New_Occurrence_Of (Designated_Type (PtrT), Loc);
if Entity (Desig) = Base_Type (Dtyp) then
Desig := New_Occurrence_Of (Dtyp, Loc);
end if;
Insert_Action (N,
@ -2198,6 +2290,8 @@ package body Exp_Ch4 is
return;
end if;
-- Handle case of qualified expression (other than optimization above)
if Nkind (Expression (N)) = N_Qualified_Expression then
Expand_Allocator_Expression (N);
@ -2219,19 +2313,19 @@ package body Exp_Ch4 is
else
declare
T : constant Entity_Id := Entity (Expression (N));
Init : Entity_Id;
Arg1 : Node_Id;
Args : List_Id;
Decls : List_Id;
Decl : Node_Id;
Discr : Elmt_Id;
Flist : Node_Id;
Temp_Decl : Node_Id;
Temp_Type : Entity_Id;
T : constant Entity_Id := Entity (Expression (N));
Init : Entity_Id;
Arg1 : Node_Id;
Args : List_Id;
Decls : List_Id;
Decl : Node_Id;
Discr : Elmt_Id;
Flist : Node_Id;
Temp_Decl : Node_Id;
Temp_Type : Entity_Id;
Attach_Level : Uint;
begin
if No_Initialization (N) then
null;
@ -2284,7 +2378,7 @@ package body Exp_Ch4 is
-- if the context is access to class wide, indicate that
-- the object being allocated has the right specific type.
if Is_Class_Wide_Type (Designated_Type (PtrT)) then
if Is_Class_Wide_Type (Dtyp) then
Arg1 := Unchecked_Convert_To (T, Arg1);
end if;
end if;
@ -2327,7 +2421,6 @@ package body Exp_Ch4 is
-- part of the generated code for the allocator).
if Has_Task (T) then
if No (Master_Id (Base_Type (PtrT))) then
-- The designated type was an incomplete type, and
@ -2475,13 +2568,18 @@ package body Exp_Ch4 is
if Controlled_Type (T) then
Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
if Ekind (PtrT) = E_Anonymous_Access_Type then
Attach_Level := Uint_1;
else
Attach_Level := Uint_2;
end if;
Insert_Actions (N,
Make_Init_Call (
Ref => New_Copy_Tree (Arg1),
Typ => T,
Flist_Ref => Flist,
With_Attach => Make_Integer_Literal (Loc, 2)));
With_Attach => Make_Integer_Literal (Loc,
Attach_Level)));
end if;
if Is_CPP_Class (T) then
@ -3283,7 +3381,6 @@ package body Exp_Ch4 is
-- all three are available, False if any one of these is unavailable.
procedure Expand_N_Op_Concat (N : Node_Id) is
Opnds : List_Id;
-- List of operands to be concatenated
@ -3643,10 +3740,13 @@ package body Exp_Ch4 is
begin
Force_Validity_Checks := True;
Rewrite (N,
Expand_Array_Equality (N, Typl, A_Typ,
Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies));
Insert_Actions (N, Bodies);
Expand_Array_Equality
(N,
Relocate_Node (Lhs),
Relocate_Node (Rhs),
Bodies,
Typl));
Insert_Actions (N, Bodies);
Analyze_And_Resolve (N, Standard_Boolean);
Force_Validity_Checks := Save_Force_Validity_Checks;
end;
@ -3672,9 +3772,12 @@ package body Exp_Ch4 is
else
Rewrite (N,
Expand_Array_Equality (N, Typl, A_Typ,
Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies));
Expand_Array_Equality
(N,
Relocate_Node (Lhs),
Relocate_Node (Rhs),
Bodies,
Typl));
Insert_Actions (N, Bodies, Suppress => All_Checks);
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
end if;
@ -6510,34 +6613,46 @@ package body Exp_Ch4 is
PtrT : Entity_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (N);
Acc : Entity_Id;
Owner : Entity_Id := PtrT;
-- The entity whose finalisation list must be used to attach the
-- allocated object.
begin
-- If the context is an access parameter, we need to create
-- a non-anonymous access type in order to have a usable
-- final list, because there is otherwise no pool to which
-- the allocated object can belong. We create both the type
-- and the finalization chain here, because freezing an
-- internal type does not create such a chain. The Final_Chain
-- that is thus created is shared by the access parameter.
if Ekind (PtrT) = E_Anonymous_Access_Type then
Acc := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
Insert_Action (N,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Acc,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (T, Loc))));
if Nkind (Associated_Node_For_Itype (PtrT))
in N_Subprogram_Specification
then
-- If the context is an access parameter, we need to create
-- a non-anonymous access type in order to have a usable
-- final list, because there is otherwise no pool to which
-- the allocated object can belong. We create both the type
-- and the finalization chain here, because freezing an
-- internal type does not create such a chain. The Final_Chain
-- that is thus created is shared by the access parameter.
Build_Final_List (N, Acc);
Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Acc));
return Find_Final_List (Acc);
Owner := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
Insert_Action (N,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Owner,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (T, Loc))));
else
return Find_Final_List (PtrT);
Build_Final_List (N, Owner);
Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner));
else
-- Case of an access discriminant, or (Ada 2005) of
-- an anonymous access component: find the final list
-- associated with the scope of the type.
Owner := Scope (PtrT);
end if;
end if;
return Find_Final_List (Owner);
end Get_Allocator_Final_List;
-------------------------------

25
gcc/ada/exp_ch6.adb
View File

@ -534,6 +534,7 @@ package body Exp_Ch6 is
Temp : Entity_Id;
Indic : Node_Id := New_Occurrence_Of (Etype (Formal), Loc);
Var : Entity_Id;
F_Typ : constant Entity_Id := Etype (Formal);
V_Typ : Entity_Id;
Crep : Boolean;
@ -549,7 +550,7 @@ package body Exp_Ch6 is
Var := Make_Var (Expression (Actual));
Crep := not Same_Representation
(Etype (Formal), Etype (Expression (Actual)));
(F_Typ, Etype (Expression (Actual)));
else
V_Typ := Etype (Actual);
@ -567,21 +568,19 @@ package body Exp_Ch6 is
-- right size.
if Ekind (Formal) = E_In_Out_Parameter
or else (Is_Array_Type (Etype (Formal))
and then not Is_Constrained (Etype (Formal)))
or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ))
then
if Nkind (Actual) = N_Type_Conversion then
if Conversion_OK (Actual) then
Init := OK_Convert_To
(Etype (Formal), New_Occurrence_Of (Var, Loc));
Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
else
Init := Convert_To
(Etype (Formal), New_Occurrence_Of (Var, Loc));
Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
end if;
elsif Ekind (Formal) = E_Out_Parameter
and then Number_Dimensions (Etype (Formal)) = 1
and then not Has_Non_Null_Base_Init_Proc (Etype (Formal))
and then Is_Array_Type (F_Typ)
and then Number_Dimensions (F_Typ) = 1
and then not Has_Non_Null_Base_Init_Proc (F_Typ)
then
-- Actual is a one-dimensional array or slice, and the type
-- requires no initialization. Create a temporary of the
@ -591,7 +590,7 @@ package body Exp_Ch6 is
Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Etype (Formal), Loc),
New_Occurrence_Of (F_Typ, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
@ -617,16 +616,16 @@ package body Exp_Ch6 is
elsif Ekind (Formal) = E_Out_Parameter
and then Nkind (Actual) = N_Type_Conversion
and then (Is_Bit_Packed_Array (Etype (Formal))
and then (Is_Bit_Packed_Array (F_Typ)
or else
Is_Bit_Packed_Array (Etype (Expression (Actual))))
then
if Conversion_OK (Actual) then
Init :=
OK_Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc));
OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
else
Init :=
Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc));
Convert_To (F_Typ, New_Occurrence_Of (Var, Loc));
end if;
elsif Ekind (Formal) = E_In_Parameter then

77
gcc/ada/exp_ch7.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,9 +31,9 @@ package Exp_Ch7 is
procedure Expand_N_Package_Body (N : Node_Id);
procedure Expand_N_Package_Declaration (N : Node_Id);
------------------------------
-- Finalization Management --
------------------------------
-----------------------------
-- Finalization Management --
-----------------------------
function In_Finalization_Root (E : Entity_Id) return Boolean;
-- True if current scope is in package System.Finalization_Root. Used
@ -61,15 +61,14 @@ package Exp_Ch7 is
-- True if T potentially needs finalization actions
function Find_Final_List
(E : Entity_Id;
Ref : Node_Id := Empty)
return Node_Id;
-- E is an entity representing a controlled object, a controlled type
-- or a scope. If Ref is not empty, it is a reference to a controlled
-- record, the closest Final list is in the controller component of
-- the record containing Ref otherwise this function returns a
-- reference to the final list attached to the closest dynamic scope
-- (that can be E itself) creating this final list if necessary.
(E : Entity_Id;
Ref : Node_Id := Empty) return Node_Id;
-- E is an entity representing a controlled object, a controlled type
-- or a scope. If Ref is not empty, it is a reference to a controlled
-- record, the closest Final list is in the controller component of
-- the record containing Ref otherwise this function returns a
-- reference to the final list attached to the closest dynamic scope
-- (that can be E itself) creating this final list if necessary.
function Has_New_Controlled_Component (E : Entity_Id) return Boolean;
-- E is a type entity. Give the same resul as Has_Controlled_Component
@ -77,10 +76,9 @@ package Exp_Ch7 is
-- latest extension contains a controlled component.
function Make_Attach_Call
(Obj_Ref : Node_Id;
Flist_Ref : Node_Id;
With_Attach : Node_Id)
return Node_Id;
(Obj_Ref : Node_Id;
Flist_Ref : Node_Id;
With_Attach : Node_Id) return Node_Id;
-- Attach the referenced object to the referenced Final Chain
-- 'Flist_Ref' With_Attach is an expression of type Short_Short_Integer
-- which can be either '0' to signify no attachment, '1' for
@ -88,11 +86,10 @@ package Exp_Ch7 is
-- doubly linked list.
function Make_Init_Call
(Ref : Node_Id;
Typ : Entity_Id;
Flist_Ref : Node_Id;
With_Attach : Node_Id)
return List_Id;
(Ref : Node_Id;
Typ : Entity_Id;
Flist_Ref : Node_Id;
With_Attach : Node_Id) return List_Id;
-- Ref is an expression (with no-side effect and is not required to
-- have been previously analyzed) that references the object to be
-- initialized. Typ is the expected type of Ref, which is a controlled
@ -108,11 +105,10 @@ package Exp_Ch7 is
-- caller, the details are in the body.
function Make_Adjust_Call
(Ref : Node_Id;
Typ : Entity_Id;
Flist_Ref : Node_Id;
With_Attach : Node_Id)
return List_Id;
(Ref : Node_Id;
Typ : Entity_Id;
Flist_Ref : Node_Id;
With_Attach : Node_Id) return List_Id;
-- Ref is an expression (with no-side effect and is not required to
-- have been previously analyzed) that references the object to be
-- adjusted. Typ is the expected type of Ref, which is a controlled
@ -132,8 +128,7 @@ package Exp_Ch7 is
function Make_Final_Call
(Ref : Node_Id;
Typ : Entity_Id;
With_Detach : Node_Id)
return List_Id;
With_Detach : Node_Id) return List_Id;
-- Ref is an expression (with no-side effect and is not required
-- to have been previously analyzed) that references the object to
-- be Finalized. Typ is the expected type of Ref, which is a
@ -161,31 +156,27 @@ package Exp_Ch7 is
--------------------------------------------
function Cleanup_Array
(N : Node_Id;
Obj : Node_Id;
Typ : Entity_Id)
return List_Id;
(N : Node_Id;
Obj : Node_Id;
Typ : Entity_Id) return List_Id;
-- Generate loops to finalize any tasks or simple protected objects
-- that are subcomponents of an array.
function Cleanup_Protected_Object
(N : Node_Id;
Ref : Node_Id)
return Node_Id;
(N : Node_Id;
Ref : Node_Id) return Node_Id;
-- Generate code to finalize a protected object without entries.
function Cleanup_Record
(N : Node_Id;
Obj : Node_Id;
Typ : Entity_Id)
return List_Id;
(N : Node_Id;
Obj : Node_Id;
Typ : Entity_Id) return List_Id;
-- For each subcomponent of a record that contains tasks or simple
-- protected objects, generate the appropriate finalization call.
function Cleanup_Task
(N : Node_Id;
Ref : Node_Id)
return Node_Id;
(N : Node_Id;
Ref : Node_Id) return Node_Id;
-- Generate code to finalize a task.
function Has_Simple_Protected_Object (T : Entity_Id) return Boolean;

2
gcc/ada/exp_dist.adb
View File

@ -66,7 +66,7 @@ package body Exp_Dist is
-- converted to and from this type to make it suitable for
-- System.Partition_Interface.Get_Unique_Remote_Pointer in order
-- to avoid memory leaks when the same remote object arrive on the
-- same partition by following different pathes
-- same partition through several paths;
-- 2) It also has the same dispatching table as the designated type D,
-- and thus can be used as an object designated by a value of type

8
gcc/ada/exp_pakd.adb
View File

@ -1156,7 +1156,7 @@ package body Exp_Pakd is
-- subtype tttPn is
-- System.Packed_Bytes{1,2,4} (0 .. (Bits + 7) / 8 - 1);
-- Bits is the length of the array in bits.
-- Bits is the length of the array in bits
Set_PB_Type;
@ -1197,6 +1197,12 @@ package body Exp_Pakd is
High_Bound => PAT_High)))));
Install_PAT;
-- Currently the code in this unit requires that packed arrays
-- represented by non-modular arrays of bytes be on a byte
-- boundary.
Set_Must_Be_On_Byte_Boundary (Typ);
end if;
end Create_Packed_Array_Type;

31
gcc/ada/exp_util.adb
View File

@ -2384,6 +2384,34 @@ package body Exp_Util is
---------------------------------
function Is_Possibly_Unaligned_Slice (P : Node_Id) return Boolean is
function Has_Non_Trivial_Component_Clause (E : Entity_Id) return Boolean;
-- Check whether the component clause might place the component at an
-- alignment that will require the use of a copy when a slice is passed
-- as a parameter. The code is conservative because at this point the
-- expander does not know the alignment choice that the back-end will
-- make. For now we return true if the component is not the first one
-- in the enclosing record. This routine is a place holder for further
-- analysis of this kind.
--------------------------------------
-- Has_Non_Trivial_Component_Clause --
--------------------------------------
function Has_Non_Trivial_Component_Clause (E : Entity_Id) return Boolean
is
Rep_Clause : constant Node_Id := Component_Clause (E);
begin
if No (Rep_Clause) then
return False;
else
return Intval (Position (Rep_Clause)) /= Uint_0
or else Intval (First_Bit (Rep_Clause)) /= Uint_0;
end if;
end Has_Non_Trivial_Component_Clause;
-- Start of processing for Is_Possibly_Unaligned_Slice
begin
-- ??? GCC3 will eventually handle strings with arbitrary alignments,
-- but for now the following check must be disabled.
@ -2448,7 +2476,8 @@ package body Exp_Util is
or else
Known_Alignment (Etype (Prefix (Pref)))
or else
Present (Component_Clause (Entity (Selector_Name (Pref)))));
Has_Non_Trivial_Component_Clause
(Entity (Selector_Name (Pref))));
end;
end Is_Possibly_Unaligned_Slice;

13
gcc/ada/fname.adb
View File

@ -149,13 +149,18 @@ package body Fname is
if Name_Len > 8 then
return False;
-- Definitely predefined if prefix is a- i- or s-
-- Definitely predefined if prefix is a- i- or s- followed by letter
elsif Name_Len > 2
elsif Name_Len >= 3
and then Name_Buffer (2) = '-'
and then (Name_Buffer (1) = 'a' or else
Name_Buffer (1) = 'i' or else
and then (Name_Buffer (1) = 'a'
or else
Name_Buffer (1) = 'i'
or else
Name_Buffer (1) = 's')
and then (Name_Buffer (3) in 'a' .. 'z'
or else
Name_Buffer (3) in 'A' .. 'Z')
then
return True;
end if;

289
gcc/ada/freeze.adb
View File

@ -601,7 +601,6 @@ package body Freeze is
begin
Index := First_Index (T);
while Present (Index) loop
if Nkind (Index) = N_Range then
Get_Index_Bounds (Index, Low, High);
@ -881,8 +880,7 @@ package body Freeze is
-------------------------------------
function Static_Discriminated_Components
(T : Entity_Id)
return Boolean
(T : Entity_Id) return Boolean
is
Constraint : Elmt_Id;
@ -1340,7 +1338,6 @@ package body Freeze is
Result : in out List_Id)
is
L : constant List_Id := Freeze_Entity (Ent, Loc);
begin
if Is_Non_Empty_List (L) then
if Result = No_List then
@ -1357,7 +1354,6 @@ package body Freeze is
procedure Freeze_Before (N : Node_Id; T : Entity_Id) is
Freeze_Nodes : constant List_Id := Freeze_Entity (T, Sloc (N));
begin
if Is_Non_Empty_List (Freeze_Nodes) then
Insert_Actions (N, Freeze_Nodes);
@ -1619,16 +1615,16 @@ package body Freeze is
if Ekind (Comp) = E_Component
or else Ekind (Comp) = E_Discriminant
then
-- Check for error of component clause given for variable
-- sized type. We have to delay this test till this point,
-- since the component type has to be frozen for us to know
-- if it is variable length. We omit this test in a generic
-- context, it will be applied at instantiation time.
declare
CC : constant Node_Id := Component_Clause (Comp);
begin
-- Check for error of component clause given for variable
-- sized type. We have to delay this test till this point,
-- since the component type has to be frozen for us to know
-- if it is variable length. We omit this test in a generic
-- context, it will be applied at instantiation time.
if Present (CC) then
Placed_Component := True;
@ -1646,116 +1642,141 @@ package body Freeze is
else
Unplaced_Component := True;
end if;
end;
-- If component clause is present, then deal with the
-- non-default bit order case. We cannot do this before
-- the freeze point, because there is no required order
-- for the component clause and the bit_order clause.
-- Case of component requires byte alignment
-- We only do this processing for the base type, and in
-- fact that's important, since otherwise if there are
-- record subtypes, we could reverse the bits once for
-- each subtype, which would be incorrect.
if Must_Be_On_Byte_Boundary (Etype (Comp)) then
if Present (Component_Clause (Comp))
and then Reverse_Bit_Order (Rec)
and then Ekind (E) = E_Record_Type
then
declare
CFB : constant Uint := Component_Bit_Offset (Comp);
CSZ : constant Uint := Esize (Comp);
CLC : constant Node_Id := Component_Clause (Comp);
Pos : constant Node_Id := Position (CLC);
FB : constant Node_Id := First_Bit (CLC);
-- Set the enclosing record to also require byte align
Storage_Unit_Offset : constant Uint :=
CFB / System_Storage_Unit;
Set_Must_Be_On_Byte_Boundary (Rec);
Start_Bit : constant Uint :=
CFB mod System_Storage_Unit;
-- Check for component clause that is inconsistent
-- with the required byte boundary alignment.
begin
-- Cases where field goes over storage unit boundary
if Present (CC)
and then Normalized_First_Bit (Comp) mod
System_Storage_Unit /= 0
then
Error_Msg_N
("component & must be byte aligned",
Component_Name (Component_Clause (Comp)));
end if;
end if;
if Start_Bit + CSZ > System_Storage_Unit then
-- If component clause is present, then deal with the
-- non-default bit order case. We cannot do this before
-- the freeze point, because there is no required order
-- for the component clause and the bit_order clause.
-- Allow multi-byte field but generate warning
-- We only do this processing for the base type, and in
-- fact that's important, since otherwise if there are
-- record subtypes, we could reverse the bits once for
-- each subtype, which would be incorrect.
if Start_Bit mod System_Storage_Unit = 0
and then CSZ mod System_Storage_Unit = 0
then
Error_Msg_N
("multi-byte field specified with non-standard"
& " Bit_Order?", CLC);
if Present (CC)
and then Reverse_Bit_Order (Rec)
and then Ekind (E) = E_Record_Type
then
declare
CFB : constant Uint := Component_Bit_Offset (Comp);
CSZ : constant Uint := Esize (Comp);
CLC : constant Node_Id := Component_Clause (Comp);
Pos : constant Node_Id := Position (CLC);
FB : constant Node_Id := First_Bit (CLC);
if Bytes_Big_Endian then
Storage_Unit_Offset : constant Uint :=
CFB / System_Storage_Unit;
Start_Bit : constant Uint :=
CFB mod System_Storage_Unit;
begin
-- Cases where field goes over storage unit boundary
if Start_Bit + CSZ > System_Storage_Unit then
-- Allow multi-byte field but generate warning
if Start_Bit mod System_Storage_Unit = 0
and then CSZ mod System_Storage_Unit = 0
then
Error_Msg_N
("bytes are not reversed "
& "(component is big-endian)?", CLC);
("multi-byte field specified with non-standard"
& " Bit_Order?", CLC);
if Bytes_Big_Endian then
Error_Msg_N
("bytes are not reversed "
& "(component is big-endian)?", CLC);
else
Error_Msg_N
("bytes are not reversed "
& "(component is little-endian)?", CLC);
end if;
-- Do not allow non-contiguous field
else
Error_Msg_N
("bytes are not reversed "
& "(component is little-endian)?", CLC);
("attempt to specify non-contiguous field"
& " not permitted", CLC);
Error_Msg_N
("\(caused by non-standard Bit_Order "
& "specified)", CLC);
end if;
-- Do not allow non-contiguous field
-- Case where field fits in one storage unit
else
Error_Msg_N
("attempt to specify non-contiguous field"
& " not permitted", CLC);
Error_Msg_N
("\(caused by non-standard Bit_Order "
& "specified)", CLC);
-- Give warning if suspicious component clause
if Intval (FB) >= System_Storage_Unit then
Error_Msg_N
("?Bit_Order clause does not affect " &
"byte ordering", Pos);
Error_Msg_Uint_1 :=
Intval (Pos) + Intval (FB) /
System_Storage_Unit;
Error_Msg_N
("?position normalized to ^ before bit " &
"order interpreted", Pos);
end if;
-- Here is where we fix up the Component_Bit_Offset
-- value to account for the reverse bit order.
-- Some examples of what needs to be done are:
-- First_Bit .. Last_Bit Component_Bit_Offset
-- old new old new
-- 0 .. 0 7 .. 7 0 7
-- 0 .. 1 6 .. 7 0 6
-- 0 .. 2 5 .. 7 0 5
-- 0 .. 7 0 .. 7 0 4
-- 1 .. 1 6 .. 6 1 6
-- 1 .. 4 3 .. 6 1 3
-- 4 .. 7 0 .. 3 4 0
-- The general rule is that the first bit is
-- is obtained by subtracting the old ending bit
-- from storage_unit - 1.
Set_Component_Bit_Offset
(Comp,
(Storage_Unit_Offset * System_Storage_Unit) +
(System_Storage_Unit - 1) -
(Start_Bit + CSZ - 1));
Set_Normalized_First_Bit
(Comp,
Component_Bit_Offset (Comp) mod
System_Storage_Unit);
end if;
-- Case where field fits in one storage unit
else
-- Give warning if suspicious component clause
if Intval (FB) >= System_Storage_Unit then
Error_Msg_N
("?Bit_Order clause does not affect " &
"byte ordering", Pos);
Error_Msg_Uint_1 :=
Intval (Pos) + Intval (FB) / System_Storage_Unit;
Error_Msg_N
("?position normalized to ^ before bit " &
"order interpreted", Pos);
end if;
-- Here is where we fix up the Component_Bit_Offset
-- value to account for the reverse bit order.
-- Some examples of what needs to be done are:
-- First_Bit .. Last_Bit Component_Bit_Offset
-- old new old new
-- 0 .. 0 7 .. 7 0 7
-- 0 .. 1 6 .. 7 0 6
-- 0 .. 2 5 .. 7 0 5
-- 0 .. 7 0 .. 7 0 4
-- 1 .. 1 6 .. 6 1 6
-- 1 .. 4 3 .. 6 1 3
-- 4 .. 7 0 .. 3 4 0
-- The general rule is that the first bit is
-- is obtained by subtracting the old ending bit
-- from storage_unit - 1.
Set_Component_Bit_Offset (Comp,
(Storage_Unit_Offset * System_Storage_Unit)
+ (System_Storage_Unit - 1)
- (Start_Bit + CSZ - 1));
Set_Normalized_First_Bit (Comp,
Component_Bit_Offset (Comp) mod System_Storage_Unit);
end if;
end;
end if;
end;
end if;
end;
end if;
Next_Entity (Comp);
@ -2543,28 +2564,44 @@ package body Freeze is
Set_Has_Non_Standard_Rep (Base_Type (E));
Set_Is_Packed (Base_Type (E));
end if;
Set_Component_Alignment_If_Not_Set (E);
-- If the array is packed, we must create the packed array
-- type to be used to actually implement the type. This is
-- only needed for real array types (not for string literal
-- types, since they are present only for the front end).
if Is_Packed (E)
and then Ekind (E) /= E_String_Literal_Subtype
then
Create_Packed_Array_Type (E);
Freeze_And_Append (Packed_Array_Type (E), Loc, Result);
-- Size information of packed array type is copied to the
-- array type, since this is really the representation.
Set_Size_Info (E, Packed_Array_Type (E));
Set_RM_Size (E, RM_Size (Packed_Array_Type (E)));
end if;
-- For non-packed arrays set the alignment of the array
-- to the alignment of the component type if it is unknown.
-- Skip this in the atomic case, since atomic arrays may
-- need larger alignments.
if not Is_Packed (E)
and then Unknown_Alignment (E)
and then Known_Alignment (Ctyp)
and then Known_Static_Component_Size (E)
and then Known_Static_Esize (Ctyp)
and then Esize (Ctyp) = Component_Size (E)
and then not Is_Atomic (E)
then
Set_Alignment (E, Alignment (Component_Type (E)));
end if;
end;
Set_Component_Alignment_If_Not_Set (E);
-- If the array is packed, we must create the packed array
-- type to be used to actually implement the type. This is
-- only needed for real array types (not for string literal
-- types, since they are present only for the front end).
if Is_Packed (E)
and then Ekind (E) /= E_String_Literal_Subtype
then
Create_Packed_Array_Type (E);
Freeze_And_Append (Packed_Array_Type (E), Loc, Result);
-- Size information of packed array type is copied to the
-- array type, since this is really the representation.
Set_Size_Info (E, Packed_Array_Type (E));
Set_RM_Size (E, RM_Size (Packed_Array_Type (E)));
end if;
-- For a class-wide type, the corresponding specific type is
-- frozen as well (RM 13.14(15))
@ -3628,6 +3665,10 @@ package body Freeze is
-- Returns size of type with given bounds. Also leaves these
-- bounds set as the current bounds of the Typ.
-----------
-- Fsize --
-----------
function Fsize (Lov, Hiv : Ureal) return Nat is
begin
Set_Realval (Lo, Lov);
@ -3635,7 +3676,7 @@ package body Freeze is
return Minimum_Size (Typ);
end Fsize;
-- Start of processing for Freeze_Fixed_Point_Type;
-- Start of processing for Freeze_Fixed_Point_Type
begin
-- If Esize of a subtype has not previously been set, set it now

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

@ -32,31 +32,31 @@
------------------------------------------------------------------------------
-- This packages provides a special implementation of the Ada95 storage pools.
--
-- The goal of this debug pool is to detect incorrect uses of memory
-- (multiple deallocations, access to invalid memory,...). Errors are reported
-- in one of two ways: either by immediately raising an exception, or by
-- printing a message on standard output.
--
-- You need to instrument your code to use this package: for each access type
-- you want to monitor, you need to add a clause similar to:
--
-- type Integer_Access is access Integer;
-- for Integer_Access'Storage_Pool use Pool;
-- where Pool is a tagged object declared with
--
-- Pool : GNAT.Debug_Pools.Debug_Pool;
--
-- This package was designed to be as efficient as possible, but still has an
-- impact on the performance of your code, which depends on the number of
-- allocations, deallocations and, somewhat less, dereferences that your
-- application performs.
--
-- For each faulty memory use, this debug pool will print several lines
-- of information, including things like the location where the memory
-- was initially allocated, the location where it was freed etc.
--
-- Physical allocations and deallocations are done through the usual system
-- calls. However, in order to provide proper checks, the debug pool will not
-- release the memory immediately. It keeps released memory around (the amount
@ -64,27 +64,27 @@
-- has not been allocated and memory that has been allocated but freed. This
-- also means that this memory cannot be reallocated, preventing what would
-- otherwise be a false indication that freed memory is now allocated.
--
-- In addition, this package presents several subprograms that help analyze
-- the behavior of your program, by reporting memory leaks, the total amount
-- of memory that was allocated. The pool is also designed to work correctly
-- in conjunction with gnatmem.
--
-- Finally, a subprogram Print_Pool is provided for use from the debugger.
--
-- Limitations
-- ===========
--
-- Current limitation of this debug pool: if you use this debug pool for a
-- general access type ("access all"), the pool might report invalid
-- dereferences if the access object is pointing to another object on the
-- stack which was not allocated through a call to "new".
--
-- This debug pool will respect all alignments specified in your code, but
-- it does that by aligning all objects using Standard'Maximum_Alignment.
-- This allows faster checks, and limits the performance impact of using
-- this pool.
--
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;

68
gcc/ada/g-os_lib.adb
View File

@ -43,6 +43,8 @@ package body GNAT.OS_Lib is
-- Note: OpenVMS should be a constant, but it cannot be, because it
-- prevents bootstrapping on some platforms.
On_Windows : constant Boolean := Directory_Separator = '\';
pragma Import (Ada, OpenVMS, "system__openvms");
-- Needed to avoid doing useless checks when non on a VMS platform (see
-- Normalize_Pathname).
@ -1584,8 +1586,9 @@ package body GNAT.OS_Lib is
-- Remove trailing directory separator, if any
if Result (Last) = '/' or else
Result (Last) = Directory_Separator
if Last > 1 and then
(Result (Last) = '/' or else
Result (Last) = Directory_Separator)
then
Last := Last - 1;
end if;
@ -1602,13 +1605,26 @@ package body GNAT.OS_Lib is
Last := S1'Last;
if S1 (Last) = '/' or else S1 (Last) = Directory_Separator then
Last := Last - 1;
if Last > 1
and then (S1 (Last) = '/'
or else
S1 (Last) = Directory_Separator)
then
-- Special case for Windows: C:\
if Last = 3
and then S1 (1) /= Directory_Separator
and then S1 (2) = ':'
then
null;
else
Last := Last - 1;
end if;
end if;
return S1 (1 .. Last);
end if;
end Final_Value;
-- Start of processing for Normalize_Pathname
@ -1666,13 +1682,23 @@ package body GNAT.OS_Lib is
end loop;
end if;
-- Resolving logical names from VMS.
-- If we have a Unix path on VMS such as /temp/..., and TEMP is a
-- logical name, we need to resolve this logical name.
-- We find the directory, change to it, get the current directory,
-- and change the directory to this value.
-- Resolve directory names for VMS and Windows
if OpenVMS and then Path_Buffer (1) = '/' then
-- On VMS, if we have a Unix path such as /temp/..., and TEMP is a
-- logical name, we need to resolve this logical name.
-- On Windows, if we have an absolute path starting with a directory
-- separator, we need to have the drive letter appended in front.
-- For both platforms, Get_Current_Dir will return a suitable
-- directory name (logical names resolved on VMS, path starting with
-- a drive letter on Windows). So we find the directory, change to it,
-- call Get_Current_Dir and change the directory to the returned value.
-- Then, of course, we return to the previous directory.
if (OpenVMS or On_Windows)
and then Path_Buffer (1) = Directory_Separator
then
declare
Cur_Dir : String := Get_Directory ("");
-- Save the current directory, so that we can change dir back to
@ -1685,21 +1711,21 @@ package body GNAT.OS_Lib is
-- set to ASCII.NUL to call chdir.
Pos : Positive := End_Path;
-- Position of the last directory separator ('/')
-- Position of the last directory separator
Status : Integer;
-- Value returned by chdir
begin
-- Look for the last '/'
-- Look for the last directory separator
while Path (Pos) /= '/' loop
while Path (Pos) /= Directory_Separator loop
Pos := Pos - 1;
end loop;
-- Get the previous character that is not a '/'
-- Get the previous character that is not a directory separator
while Pos > 1 and then Path (Pos) = '/' loop
while Pos > 1 and then Path (Pos) = Directory_Separator loop
Pos := Pos - 1;
end loop;
@ -1934,7 +1960,6 @@ package body GNAT.OS_Lib is
(Name : C_File_Name;
Fmode : Mode) return File_Descriptor;
pragma Import (C, C_Open_Read, "__gnat_open_read");
begin
return C_Open_Read (Name, Fmode);
end Open_Read;
@ -1944,7 +1969,6 @@ package body GNAT.OS_Lib is
Fmode : Mode) return File_Descriptor
is
C_Name : String (1 .. Name'Length + 1);
begin
C_Name (1 .. Name'Length) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
@ -1963,7 +1987,6 @@ package body GNAT.OS_Lib is
(Name : C_File_Name;
Fmode : Mode) return File_Descriptor;
pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
begin
return C_Open_Read_Write (Name, Fmode);
end Open_Read_Write;
@ -1973,7 +1996,6 @@ package body GNAT.OS_Lib is
Fmode : Mode) return File_Descriptor
is
C_Name : String (1 .. Name'Length + 1);
begin
C_Name (1 .. Name'Length) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
@ -2005,9 +2027,7 @@ package body GNAT.OS_Lib is
is
function rename (From, To : Address) return Integer;
pragma Import (C, rename, "rename");
R : Integer;
begin
R := rename (Old_Name, New_Name);
Success := (R = 0);
@ -2020,14 +2040,11 @@ package body GNAT.OS_Lib is
is
C_Old_Name : String (1 .. Old_Name'Length + 1);
C_New_Name : String (1 .. New_Name'Length + 1);
begin
C_Old_Name (1 .. Old_Name'Length) := Old_Name;
C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
C_New_Name (1 .. New_Name'Length) := New_Name;
C_New_Name (C_New_Name'Last) := ASCII.NUL;
Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
end Rename_File;
@ -2062,7 +2079,6 @@ package body GNAT.OS_Lib is
is
Junk : Process_Id;
Result : Integer;
begin
Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
return Result;

6
gcc/ada/g-traceb.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2002 Ada Core Technologies, Inc. --
-- Copyright (C) 1999-2004 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -42,6 +42,10 @@
-- These code locations may be converted to corresponding source locations
-- using the external addr2line utility, or from within GDB.
-- In order to use this facility, in some cases the binder must be invoked
-- with -E switch (store the backtrace with exception occurence). Please
-- refer to gnatbind documentation for more information.
-- To analyze the code locations later using addr2line or gdb, the necessary
-- units must be compiled with the debugging switch -g in the usual manner.
-- Note that it is not necessary to compile with -g to use Call_Chain. In

4
gcc/ada/g-trasym.ads
View File

@ -40,6 +40,10 @@
-- been compiled with debugging information turned on, since this information
-- is used to build a symbolic traceback.
-- It is also in some cases necessary to invoke the binder
-- with -E switch (store the backtrace with exception occurence). Please
-- refer to gnatbind documentation for more information.
-- In order to retrieve symbolic information, functions in this package will
-- read on disk all the debug information of the executable file (found via
-- Argument (0), so any path information needed to read the executable file

21
gcc/ada/gnat_rm.texi
View File

@ -2224,6 +2224,13 @@ users guide) in conjunction with pragma @code{Initialize_Scalars}
provides a powerful new tool to assist in the detection of problems
caused by uninitialized variables.
Note: the use of @code{Initialize_Scalars} has a fairly extensive
effect on the generated code. This may cause your code to be
substantially larger. It may also cause an increase in the amount
of stack required, so it is probably a good idea to turn on stack
checking (see description of stack checking in the GNAT users guide)
when using this pragma.
@node Pragma Inline_Always
@unnumberedsec Pragma Inline_Always
@findex Inline_Always
@ -9442,15 +9449,19 @@ thus the same lack of restriction applies. For example, if you declare:
then a component clause for a component of type R may start on any
specified bit boundary, and may specify a value of 49 bits or greater.
Packed bit arrays that are longer than 64 bits must always be placed
on a storage unit (byte) boundary. Any component clause that does not
meet this requirement will be rejected.
The rules for other types are different for GNAT 3 and GNAT 5 versions
(based on GCC 2 and GCC 3 respectively). In GNAT 5, larger components
(other than packed arrays)
may also be placed on arbitrary boundaries, so for example, the following
is permitted:
@smallexample @c ada
type R is array (1 .. 79) of Boolean;
pragma Pack (R);
for R'Size use 79;
type R is array (1 .. 10) of Boolean;
for R'Size use 80;
type Q is record
G, H : Boolean;
@ -9460,8 +9471,8 @@ is permitted:
for Q use record
G at 0 range 0 .. 0;
H at 0 range 1 .. 1;
L at 0 range 2 .. 80;
R at 0 range 81 .. 159;
L at 0 range 2 .. 81;
R at 0 range 82 .. 161;
end record;
@end smallexample

39
gcc/ada/gnat_ugn.texi
View File

@ -5429,6 +5429,14 @@ Clear :
@end cartouche
@end smallexample
@item ^Lnnn^MAX_NESTING=nnn^
@emph{Set maximum nesting level}
If the sequence ^Lnnn^MAX_NESTING=nnn^, where nnn is a decimal number in
the range 0-999, appears in the string after @option{-gnaty} then the
maximum level of nesting of constructs (including subprograms, loops,
blocks, packages, and conditionals) may not exceed the given value. A
value of zero disconnects this style check.
@item ^m^LINE_LENGTH^
@emph{Check maximum line length.}
If the ^letter m^word LINE_LENGTH^ appears in the string after @option{-gnaty}
@ -12447,19 +12455,11 @@ library-related attributes are checked only for such project files.
The @code{Library_Kind} attribute has a string value that must be one of the
following (case insensitive): @code{"static"}, @code{"dynamic"} or
@code{"relocatable"}. If this attribute is not specified, the library is a
static library, that is an archive of object files that can be potentially
linked into an static executable. Otherwise, the library may be dynamic or
@code{"relocatable"} (which is a synonym for @code{"dynamic"}). If this
attribute is not specified, the library is a static library, that is
an archive of object files that can be potentially linked into an
static executable. Otherwise, the library may be dynamic or
relocatable, that is a library that is loaded only at the start of execution.
Depending on the operating system, there may or may not be a distinction
between dynamic and relocatable libraries. For Unix and VMS Unix there is no
such distinction.
@ifset unw
On Windows @code{"relocatable"} will build a relocatable @code{DLL}
and @code{"dynamic"} will build a non-relocatable @code{DLL}.
@pxref{Introduction to Dynamic Link Libraries (DLLs)}.
@end ifset
If you need to build both a static and a dynamic library, you should use two
different object directories, since in some cases some extra code needs to
@ -14870,6 +14870,14 @@ contains only one file to reformat
The additional @command{gnatpp} switches are defined in this subsection.
@table @option
@item ^-files @var{filename}^/FILES=@var{output_file}^
@cindex @option{^-files^/FILES^} (@code{gnatpp})
Take the argument source files from the specified file. This file should be an
ordinary textual file containing file names separated by spaces or
line breaks. You can use this switch more then once in the same call to
@command{gnatpp}. You also can combine this switch with explicit list of
files.
@item ^-v^/VERBOSE^
@cindex @option{^-v^/VERBOSE^} (@code{gnatpp})
Verbose mode;
@ -16034,6 +16042,13 @@ Only output information about source files.
@cindex @option{^-u^/OUTPUT=UNITS^} (@code{gnatls})
Only output information about compilation units.
@item ^-files^/FILES^=@var{file}
@cindex @option{^-files^/FILES^} (@code{gnatls})
Take as arguments the files listed in text file @var{file}.
Text file @var{file} may contain empty lines that are ignored.
Each non empty line should contain the name of an existing file.
Several such switches may be specified simultaneously.
@item ^-aO^/OBJECT_SEARCH=^@var{dir}
@itemx ^-aI^/SOURCE_SEARCH=^@var{dir}
@itemx ^-I^/SEARCH=^@var{dir}

892
gcc/ada/gnatcmd.adb
View File

@ -39,6 +39,7 @@ with Prj.Env;
with Prj.Ext; use Prj.Ext;
with Prj.Pars;
with Prj.Util; use Prj.Util;
with Sinput.P;
with Snames; use Snames;
with Table;
with Types; use Types;
@ -61,11 +62,17 @@ procedure GNATCmd is
Current_Verbosity : Prj.Verbosity := Prj.Default;
Tool_Package_Name : Name_Id := No_Name;
Old_Project_File_Used : Boolean := False;
-- This flag indicates a switch -p (for gnatxref and gnatfind) for
-- an old fashioned project file. -p cannot be used in conjonction
-- with -P.
Old_Project_File_Used : Boolean := False;
Max_Files_On_The_Command_Line : constant := 30; -- Arbitrary
Temp_File_Name : String_Access := null;
-- The name of the temporary text file to put a list of source/object
-- files to pass to a tool, when there are more than
-- Max_Files_On_The_Command_Line files.
-- A table to keep the switches from the project file
@ -145,6 +152,19 @@ procedure GNATCmd is
-- Local Subprograms --
-----------------------
procedure Check_Files;
-- For GNAT LIST, GNAT PRETTY and GNAT METRIC, check if a project
-- file is specified, without any file arguments. If it is the case,
-- invoke the GNAT tool with the proper list of files, derived from
-- the sources of the project.
function Check_Project
(Project : Project_Id;
Root_Project : Project_Id) return Boolean;
-- Returns True if Project = Root_Project.
-- For GNAT METRIC, also returns True if Project is extended by
-- Root_Project.
procedure Check_Relative_Executable (Name : in out String_Access);
-- Check if an executable is specified as a relative path.
-- If it is, and the path contains directory information, fail.
@ -168,6 +188,9 @@ procedure GNATCmd is
procedure Non_VMS_Usage;
-- Display usage for platforms other than VMS
procedure Process_Link;
-- Process GNAT LINK, when there is a project file specified.
procedure Set_Library_For
(Project : Project_Id;
There_Are_Libraries : in out Boolean);
@ -186,6 +209,214 @@ procedure GNATCmd is
-- If it is and it includes directory information, prepend the path with
-- Parent.This subprogram is only called when using project files.
-----------------
-- Check_Files --
-----------------
procedure Check_Files is
Add_Sources : Boolean := True;
Unit_Data : Prj.Com.Unit_Data;
Subunit : Boolean := False;
begin
-- Check if there is at least one argument that is not a switch
for Index in 1 .. Last_Switches.Last loop
if Last_Switches.Table (Index) (1) /= '-' then
Add_Sources := False;
exit;
end if;
end loop;
-- If all arguments were switches, add the path names of
-- all the sources of the main project.
if Add_Sources then
declare
Current_Last : constant Integer := Last_Switches.Last;
use Prj.Com;
begin
for Unit in 1 .. Prj.Com.Units.Last loop
Unit_Data := Prj.Com.Units.Table (Unit);
-- For gnatls, we only need to put the library units,
-- body or spec, but not the subunits.
if The_Command = List then
if
Unit_Data.File_Names (Body_Part).Name /= No_Name
then
-- There is a body; check if it is for this
-- project.
if Unit_Data.File_Names (Body_Part).Project =
Project
then
Subunit := False;
if Unit_Data.File_Names (Specification).Name =
No_Name
then
-- We have a body with no spec: we need
-- to check if this is a subunit, because
-- gnatls will complain about subunits.
declare
Src_Ind : Source_File_Index;
begin
Src_Ind := Sinput.P.Load_Project_File
(Get_Name_String
(Unit_Data.File_Names
(Body_Part).Path));
Subunit :=
Sinput.P.Source_File_Is_Subunit
(Src_Ind);
end;
end if;
if not Subunit then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'
(Get_Name_String
(Unit_Data.File_Names
(Body_Part).Display_Name));
end if;
end if;
elsif Unit_Data.File_Names (Specification).Name /=
No_Name
then
-- We have a spec with no body; check if it is
-- for this project.
if Unit_Data.File_Names (Specification).Project =
Project
then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'
(Get_Name_String
(Unit_Data.File_Names
(Specification).Display_Name));
end if;
end if;
else
-- For gnatpp and gnatmetric, put all sources
-- of the project.
for Kind in Prj.Com.Spec_Or_Body loop
-- Put only sources that belong to the main
-- project.
if Check_Project
(Unit_Data.File_Names (Kind).Project, Project)
then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'
(Get_Name_String
(Unit_Data.File_Names
(Kind).Display_Path));
end if;
end loop;
end if;
end loop;
-- If the list of files is too long, create a temporary
-- text file that lists these files, and pass this temp
-- file to gnatpp or gnatmetric using switch -files=.
if Last_Switches.Last - Current_Last >
Max_Files_On_The_Command_Line
then
declare
Temp_File_FD : File_Descriptor;
Buffer : String (1 .. 1_000);
Len : Natural;
OK : Boolean := True;
begin
Create_Temp_File (Temp_File_FD, Temp_File_Name);
if Temp_File_Name /= null then
for Index in Current_Last + 1 ..
Last_Switches.Last
loop
Len := Last_Switches.Table (Index)'Length;
Buffer (1 .. Len) :=
Last_Switches.Table (Index).all;
Len := Len + 1;
Buffer (Len) := ASCII.LF;
Buffer (Len + 1) := ASCII.NUL;
OK :=
Write (Temp_File_FD,
Buffer (1)'Address,
Len) = Len;
exit when not OK;
end loop;
if OK then
Close (Temp_File_FD, OK);
else
Close (Temp_File_FD, OK);
OK := False;
end if;
-- If there were any problem creating the temp
-- file, then pass the list of files.
if OK then
-- Replace the list of files with
-- "-files=<temp file name>".
Last_Switches.Set_Last (Current_Last + 1);
Last_Switches.Table (Last_Switches.Last) :=
new String'("-files=" & Temp_File_Name.all);
end if;
end if;
end;
end if;
end;
end if;
end Check_Files;
-------------------
-- Check_Project --
-------------------
function Check_Project
(Project : Project_Id;
Root_Project : Project_Id) return Boolean
is
begin
if Project = Root_Project then
return True;
elsif The_Command = Metric then
declare
Data : Project_Data := Projects.Table (Root_Project);
begin
while Data.Extends /= No_Project loop
if Project = Data.Extends then
return True;
end if;
Data := Projects.Table (Data.Extends);
end loop;
end;
end if;
return False;
end Check_Project;
-------------------------------
-- Check_Relative_Executable --
-------------------------------
@ -256,6 +487,13 @@ procedure GNATCmd is
end if;
end loop;
end if;
-- If a temporary text file that contains a list of files for a tool
-- has been created, delete this temporary file.
if Temp_File_Name /= null then
Delete_File (Temp_File_Name.all, Success);
end if;
end Delete_Temp_Config_Files;
-----------
@ -273,6 +511,288 @@ procedure GNATCmd is
return 0;
end Index;
------------------
-- Process_Link --
------------------
procedure Process_Link is
Look_For_Executable : Boolean := True;
There_Are_Libraries : Boolean := False;
Path_Option : constant String_Access :=
MLib.Linker_Library_Path_Option;
Prj : Project_Id := Project;
Arg : String_Access;
Last : Natural := 0;
Skip_Executable : Boolean := False;
begin
-- Add the default search directories, to be able to find
-- libgnat in call to MLib.Utl.Lib_Directory.
Add_Default_Search_Dirs;
Library_Paths.Set_Last (0);
-- Check if there are library project files
if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then
Set_Libraries (Project, There_Are_Libraries);
end if;
-- If there are, add the necessary additional switches
if There_Are_Libraries then
-- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-L" & MLib.Utl.Lib_Directory);
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-lgnarl");
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-lgnat");
-- If Path_Option is not null, create the switch
-- ("-Wl,-rpath," or equivalent) with all the library dirs
-- plus the standard GNAT library dir.
if Path_Option /= null then
declare
Option : String_Access;
Length : Natural := Path_Option'Length;
Current : Natural;
begin
-- First, compute the exact length for the switch
for Index in
Library_Paths.First .. Library_Paths.Last
loop
-- Add the length of the library dir plus one
-- for the directory separator.
Length :=
Length +
Library_Paths.Table (Index)'Length + 1;
end loop;
-- Finally, add the length of the standard GNAT
-- library dir.
Length := Length + MLib.Utl.Lib_Directory'Length;
Option := new String (1 .. Length);
Option (1 .. Path_Option'Length) := Path_Option.all;
Current := Path_Option'Length;
-- Put each library dir followed by a dir separator
for Index in
Library_Paths.First .. Library_Paths.Last
loop
Option
(Current + 1 ..
Current +
Library_Paths.Table (Index)'Length) :=
Library_Paths.Table (Index).all;
Current :=
Current +
Library_Paths.Table (Index)'Length + 1;
Option (Current) := Path_Separator;
end loop;
-- Finally put the standard GNAT library dir
Option
(Current + 1 ..
Current + MLib.Utl.Lib_Directory'Length) :=
MLib.Utl.Lib_Directory;
-- And add the switch to the last switches
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
Option;
end;
end if;
end if;
-- Check if the first ALI file specified can be found, either
-- in the object directory of the main project or in an object
-- directory of a project file extended by the main project.
-- If the ALI file can be found, replace its name with its
-- absolute path.
Skip_Executable := False;
Switch_Loop : for J in 1 .. Last_Switches.Last loop
-- If we have an executable just reset the flag
if Skip_Executable then
Skip_Executable := False;
-- If -o, set flag so that next switch is not processed
elsif Last_Switches.Table (J).all = "-o" then
Skip_Executable := True;
-- Normal case
else
declare
Switch : constant String :=
Last_Switches.Table (J).all;
ALI_File : constant String (1 .. Switch'Length + 4) :=
Switch & ".ali";
Test_Existence : Boolean := False;
begin
Last := Switch'Length;
-- Skip real switches
if Switch'Length /= 0
and then Switch (Switch'First) /= '-'
then
-- Append ".ali" if file name does not end with it
if Switch'Length <= 4
or else Switch (Switch'Last - 3 .. Switch'Last)
/= ".ali"
then
Last := ALI_File'Last;
end if;
-- If file name includes directory information,
-- stop if ALI file exists.
if Is_Absolute_Path (ALI_File (1 .. Last)) then
Test_Existence := True;
else
for K in Switch'Range loop
if Switch (K) = '/' or else
Switch (K) = Directory_Separator
then
Test_Existence := True;
exit;
end if;
end loop;
end if;
if Test_Existence then
if Is_Regular_File (ALI_File (1 .. Last)) then
exit Switch_Loop;
end if;
-- Look in object directories if ALI file exists
else
Project_Loop : loop
declare
Dir : constant String :=
Get_Name_String
(Projects.Table (Prj).
Object_Directory);
begin
if Is_Regular_File
(Dir &
Directory_Separator &
ALI_File (1 .. Last))
then
-- We have found the correct project, so we
-- replace the file with the absolute path.
Last_Switches.Table (J) :=
new String'
(Dir & Directory_Separator &
ALI_File (1 .. Last));
-- And we are done
exit Switch_Loop;
end if;
end;
-- Go to the project being extended,
-- if any.
Prj := Projects.Table (Prj).Extends;
exit Project_Loop when Prj = No_Project;
end loop Project_Loop;
end if;
end if;
end;
end if;
end loop Switch_Loop;
-- If a relative path output file has been specified, we add
-- the exec directory.
for J in reverse 1 .. Last_Switches.Last - 1 loop
if Last_Switches.Table (J).all = "-o" then
Check_Relative_Executable
(Name => Last_Switches.Table (J + 1));
Look_For_Executable := False;
exit;
end if;
end loop;
if Look_For_Executable then
for J in reverse 1 .. First_Switches.Last - 1 loop
if First_Switches.Table (J).all = "-o" then
Look_For_Executable := False;
Check_Relative_Executable
(Name => First_Switches.Table (J + 1));
exit;
end if;
end loop;
end if;
-- If no executable is specified, then find the name
-- of the first ALI file on the command line and issue
-- a -o switch with the absolute path of the executable
-- in the exec directory.
if Look_For_Executable then
for J in 1 .. Last_Switches.Last loop
Arg := Last_Switches.Table (J);
Last := 0;
if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then
if Arg'Length > 4
and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
then
Last := Arg'Last - 4;
elsif Is_Regular_File (Arg.all & ".ali") then
Last := Arg'Last;
end if;
if Last /= 0 then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-o");
Get_Name_String
(Projects.Table (Project).Exec_Directory);
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'(Name_Buffer (1 .. Name_Len) &
Directory_Separator &
Base_Name (Arg (Arg'First .. Last)) &
Get_Executable_Suffix.all);
exit;
end if;
end if;
end loop;
end if;
end Process_Link;
---------------------
-- Set_Library_For --
---------------------
@ -317,7 +837,6 @@ procedure GNATCmd is
new String'(Get_Name_String
(Projects.Table (Project).Library_Dir));
end if;
end if;
end Set_Library_For;
@ -341,9 +860,9 @@ procedure GNATCmd is
if Sw (1) = '-' then
if Sw'Length >= 3
and then (Sw (2) = 'A'
or else Sw (2) = 'I'
or else Sw (2) = 'L')
and then (Sw (2) = 'A' or else
Sw (2) = 'I' or else
Sw (2) = 'L')
then
Start := 3;
@ -352,9 +871,9 @@ procedure GNATCmd is
end if;
elsif Sw'Length >= 4
and then (Sw (2 .. 3) = "aL"
or else Sw (2 .. 3) = "aO"
or else Sw (2 .. 3) = "aI")
and then (Sw (2 .. 3) = "aL" or else
Sw (2 .. 3) = "aO" or else
Sw (2 .. 3) = "aI")
then
Start := 4;
@ -937,301 +1456,7 @@ begin
end if;
if The_Command = Link then
-- Add the default search directories, to be able to find
-- libgnat in call to MLib.Utl.Lib_Directory.
Add_Default_Search_Dirs;
declare
There_Are_Libraries : Boolean := False;
Path_Option : constant String_Access :=
MLib.Linker_Library_Path_Option;
begin
Library_Paths.Set_Last (0);
-- Check if there are library project files
if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then
Set_Libraries (Project, There_Are_Libraries);
end if;
-- If there are, add the necessary additional switches
if There_Are_Libraries then
-- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-L" & MLib.Utl.Lib_Directory);
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-lgnarl");
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-lgnat");
-- If Path_Option is not null, create the switch
-- ("-Wl,-rpath," or equivalent) with all the library dirs
-- plus the standard GNAT library dir.
if Path_Option /= null then
declare
Option : String_Access;
Length : Natural := Path_Option'Length;
Current : Natural;
begin
-- First, compute the exact length for the switch
for Index in
Library_Paths.First .. Library_Paths.Last
loop
-- Add the length of the library dir plus one
-- for the directory separator.
Length :=
Length +
Library_Paths.Table (Index)'Length + 1;
end loop;
-- Finally, add the length of the standard GNAT
-- library dir.
Length := Length + MLib.Utl.Lib_Directory'Length;
Option := new String (1 .. Length);
Option (1 .. Path_Option'Length) := Path_Option.all;
Current := Path_Option'Length;
-- Put each library dir followed by a dir separator
for Index in
Library_Paths.First .. Library_Paths.Last
loop
Option
(Current + 1 ..
Current +
Library_Paths.Table (Index)'Length) :=
Library_Paths.Table (Index).all;
Current :=
Current +
Library_Paths.Table (Index)'Length + 1;
Option (Current) := Path_Separator;
end loop;
-- Finally put the standard GNAT library dir
Option
(Current + 1 ..
Current + MLib.Utl.Lib_Directory'Length) :=
MLib.Utl.Lib_Directory;
-- And add the switch to the last switches
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
Option;
end;
end if;
end if;
end;
-- Check if the first ALI file specified can be found, either
-- in the object directory of the main project or in an object
-- directory of a project file extended by the main project.
-- If the ALI file can be found, replace its name with its
-- absolute path.
declare
Skip_Executable : Boolean := False;
begin
Switch_Loop : for J in 1 .. Last_Switches.Last loop
-- If we have an executable just reset the flag
if Skip_Executable then
Skip_Executable := False;
-- If -o, set flag so that next switch is not processed
elsif Last_Switches.Table (J).all = "-o" then
Skip_Executable := True;
-- Normal case
else
declare
Switch : constant String :=
Last_Switches.Table (J).all;
ALI_File : constant String (1 .. Switch'Length + 4) :=
Switch & ".ali";
Last : Natural := Switch'Length;
Test_Existence : Boolean := False;
begin
-- Skip real switches
if Switch'Length /= 0 and then
Switch (Switch'First) /= '-'
then
-- Append ".ali" if file name does not end with it
if Switch'Length <= 4 or else
Switch (Switch'Last - 3 .. Switch'Last) /= ".ali"
then
Last := ALI_File'Last;
end if;
-- If file name includes directory information,
-- stop if ALI file exists.
if Is_Absolute_Path (ALI_File (1 .. Last)) then
Test_Existence := True;
else
for K in Switch'Range loop
if Switch (K) = '/' or else
Switch (K) = Directory_Separator
then
Test_Existence := True;
exit;
end if;
end loop;
end if;
if Test_Existence then
if Is_Regular_File (ALI_File (1 .. Last)) then
exit Switch_Loop;
end if;
else
-- Look in the object directories if the ALI
-- file exists.
declare
Prj : Project_Id := Project;
begin
Project_Loop :
loop
declare
Dir : constant String :=
Get_Name_String
(Projects.Table (Prj).
Object_Directory);
begin
if Is_Regular_File
(Dir & Directory_Separator &
ALI_File (1 .. Last))
then
-- We have found the correct
-- project, so we replace the file
-- with the absolute path.
Last_Switches.Table (J) :=
new String'
(Dir & Directory_Separator &
ALI_File (1 .. Last));
-- And we are done
exit Switch_Loop;
end if;
end;
-- Go to the project being extended,
-- if any.
Prj := Projects.Table (Prj).Extends;
exit Project_Loop when Prj = No_Project;
end loop Project_Loop;
end;
end if;
end if;
end;
end if;
end loop Switch_Loop;
end;
-- If a relative path output file has been specified, we add
-- the exec directory.
declare
Look_For_Executable : Boolean := True;
begin
for J in reverse 1 .. Last_Switches.Last - 1 loop
if Last_Switches.Table (J).all = "-o" then
Check_Relative_Executable
(Name => Last_Switches.Table (J + 1));
Look_For_Executable := False;
exit;
end if;
end loop;
if Look_For_Executable then
for J in reverse 1 .. First_Switches.Last - 1 loop
if First_Switches.Table (J).all = "-o" then
Look_For_Executable := False;
Check_Relative_Executable
(Name => First_Switches.Table (J + 1));
exit;
end if;
end loop;
end if;
-- If no executable is specified, then find the name
-- of the first ALI file on the command line and issue
-- a -o switch with the absolute path of the executable
-- in the exec directory.
if Look_For_Executable then
for J in 1 .. Last_Switches.Last loop
declare
Arg : constant String_Access :=
Last_Switches.Table (J);
Last : Natural := 0;
begin
if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then
if Arg'Length > 4
and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
then
Last := Arg'Last - 4;
elsif Is_Regular_File (Arg.all & ".ali") then
Last := Arg'Last;
end if;
if Last /= 0 then
declare
Executable_Name : constant String :=
Base_Name (Arg (Arg'First .. Last));
begin
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-o");
Get_Name_String
(Projects.Table (Project).Exec_Directory);
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'(Name_Buffer (1 .. Name_Len) &
Directory_Separator &
Executable_Name &
Get_Executable_Suffix.all);
exit;
end;
end if;
end if;
end;
end loop;
end if;
end;
Process_Link;
end if;
if The_Command = Link or The_Command = Bind then
@ -1337,46 +1562,30 @@ begin
end;
end if;
-- For gnatmetric, the generated files should be put in the
-- object directory. This must be the first dwitch, because it may
-- be overriden by a switch in package Metrics in the project file
-- or by a command line option.
if The_Command = Metric then
First_Switches.Increment_Last;
First_Switches.Table (2 .. First_Switches.Last) :=
First_Switches.Table (1 .. First_Switches.Last - 1);
First_Switches.Table (1) :=
new String'("-d=" &
Get_Name_String
(Projects.Table (Project).Object_Directory));
end if;
-- For gnat pretty and gnat metric, if no file has been put on the
-- command line, call the tool with all the sources of the main
-- project.
if The_Command = Pretty or else The_Command = Metric then
declare
Add_Sources : Boolean := True;
Unit_Data : Prj.Com.Unit_Data;
begin
-- Check if there is at least one argument that is not a switch
for Index in 1 .. Last_Switches.Last loop
if Last_Switches.Table (Index)(1) /= '-' then
Add_Sources := False;
exit;
end if;
end loop;
-- If all arguments were switches, add the path names of
-- all the sources of the main project.
if Add_Sources then
for Unit in 1 .. Prj.Com.Units.Last loop
Unit_Data := Prj.Com.Units.Table (Unit);
for Kind in Prj.Com.Spec_Or_Body loop
-- Put only sources that belong to the main project
if Unit_Data.File_Names (Kind).Project = Project then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'
(Get_Name_String
(Unit_Data.File_Names (Kind).Display_Path));
end if;
end loop;
end loop;
end if;
end;
if The_Command = Pretty or else
The_Command = Metric or else
The_Command = List
then
Check_Files;
end if;
end if;
@ -1384,8 +1593,9 @@ begin
declare
The_Args : Argument_List
(1 .. First_Switches.Last + Last_Switches.Last);
Arg_Num : Natural := 0;
(1 .. First_Switches.Last + Last_Switches.Last);
Arg_Num : Natural := 0;
begin
for J in 1 .. First_Switches.Last loop
Arg_Num := Arg_Num + 1;

6
gcc/ada/gnatlink.adb
View File

@ -1406,12 +1406,16 @@ begin
Units.Table (ALIs.Table (A).First_Unit).Last_Arg
loop
-- Do not compile with the front end switches except for --RTS
-- if the binder generated file is in Ada.
declare
Arg : String_Ptr renames Args.Table (Index);
begin
if not Is_Front_End_Switch (Arg.all)
or else Arg (Arg'First + 2 .. Arg'First + 5) = "RTS="
or else
(Ada_Bind_File
and then Arg'Length > 5
and then Arg (Arg'First + 2 .. Arg'First + 5) = "RTS=")
then
Binder_Options_From_ALI.Increment_Last;
Binder_Options_From_ALI.Table

177
gcc/ada/gnatls.adb
View File

@ -115,15 +115,11 @@ procedure Gnatls is
-- Local Subprograms --
-----------------------
procedure Add_Lib_Dir (Dir : String; And_Save : Boolean);
-- Add an object directory, using Osint.Add_Lib_Search_Dir
-- if And_Save is False or keeping in the list First_Lib_Dir,
-- Last_Lib_Dir if And_Save is True.
procedure Add_Lib_Dir (Dir : String);
-- Add an object directory in the list First_Lib_Dir-Last_Lib_Dir
procedure Add_Source_Dir (Dir : String; And_Save : Boolean);
-- Add a source directory, using Osint.Add_Src_Search_Dir
-- if And_Save is False or keeping in the list First_Source_Dir,
-- Last_Source_Dir if And_Save is True.
procedure Add_Source_Dir (Dir : String);
-- Add a source directory in the list First_Source_Dir-Last_Source_Dir
procedure Find_General_Layout;
-- Determine the structure of the output (multi columns or not, etc)
@ -157,7 +153,7 @@ procedure Gnatls is
procedure Reset_Print;
-- Reset Print flags properly when selective output is chosen
procedure Scan_Ls_Arg (Argv : String; And_Save : Boolean);
procedure Scan_Ls_Arg (Argv : String);
-- Scan and process lser specific arguments. Argv is a single argument
procedure Usage;
@ -170,26 +166,21 @@ procedure Gnatls is
-- Add_Lib_Dir --
-----------------
procedure Add_Lib_Dir (Dir : String; And_Save : Boolean) is
procedure Add_Lib_Dir (Dir : String) is
begin
if And_Save then
if First_Lib_Dir = null then
First_Lib_Dir :=
new Dir_Data'
(Value => new String'(Dir),
Next => null);
Last_Lib_Dir := First_Lib_Dir;
else
Last_Lib_Dir.Next :=
new Dir_Data'
(Value => new String'(Dir),
Next => null);
Last_Lib_Dir := Last_Lib_Dir.Next;
end if;
if First_Lib_Dir = null then
First_Lib_Dir :=
new Dir_Data'
(Value => new String'(Dir),
Next => null);
Last_Lib_Dir := First_Lib_Dir;
else
Add_Lib_Search_Dir (Dir);
Last_Lib_Dir.Next :=
new Dir_Data'
(Value => new String'(Dir),
Next => null);
Last_Lib_Dir := Last_Lib_Dir.Next;
end if;
end Add_Lib_Dir;
@ -197,26 +188,21 @@ procedure Gnatls is
-- Add_Source_Dir --
--------------------
procedure Add_Source_Dir (Dir : String; And_Save : Boolean) is
procedure Add_Source_Dir (Dir : String) is
begin
if And_Save then
if First_Source_Dir = null then
First_Source_Dir :=
new Dir_Data'
(Value => new String'(Dir),
Next => null);
Last_Source_Dir := First_Source_Dir;
else
Last_Source_Dir.Next :=
new Dir_Data'
(Value => new String'(Dir),
Next => null);
Last_Source_Dir := Last_Source_Dir.Next;
end if;
if First_Source_Dir = null then
First_Source_Dir :=
new Dir_Data'
(Value => new String'(Dir),
Next => null);
Last_Source_Dir := First_Source_Dir;
else
Add_Src_Search_Dir (Dir);
Last_Source_Dir.Next :=
new Dir_Data'
(Value => new String'(Dir),
Next => null);
Last_Source_Dir := Last_Source_Dir.Next;
end if;
end Add_Source_Dir;
@ -695,7 +681,9 @@ procedure Gnatls is
-- Scan_Ls_Arg --
-------------------
procedure Scan_Ls_Arg (Argv : String; And_Save : Boolean) is
procedure Scan_Ls_Arg (Argv : String) is
FD : File_Descriptor;
Len : Integer;
begin
pragma Assert (Argv'First = 1);
@ -723,23 +711,23 @@ procedure Gnatls is
-- Processing for -Idir
elsif Argv (2) = 'I' then
Add_Source_Dir (Argv (3 .. Argv'Last), And_Save);
Add_Lib_Dir (Argv (3 .. Argv'Last), And_Save);
Add_Source_Dir (Argv (3 .. Argv'Last));
Add_Lib_Dir (Argv (3 .. Argv'Last));
-- Processing for -aIdir (to gcc this is like a -I switch)
elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aI" then
Add_Source_Dir (Argv (4 .. Argv'Last), And_Save);
Add_Source_Dir (Argv (4 .. Argv'Last));
-- Processing for -aOdir
elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aO" then
Add_Lib_Dir (Argv (4 .. Argv'Last), And_Save);
Add_Lib_Dir (Argv (4 .. Argv'Last));
-- Processing for -aLdir (to gnatbind this is like a -aO switch)
elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aL" then
Add_Lib_Dir (Argv (4 .. Argv'Last), And_Save);
Add_Lib_Dir (Argv (4 .. Argv'Last));
-- Processing for -nostdinc
@ -761,6 +749,62 @@ procedure Gnatls is
when others => null;
end case;
-- Processing for -files=file
elsif Argv'Length > 7 and then Argv (1 .. 7) = "-files=" then
FD := Open_Read (Argv (8 .. Argv'Last), GNAT.OS_Lib.Text);
if FD = Invalid_FD then
Osint.Fail ("could not find text file """ &
Argv (8 .. Argv'Last) & '"');
end if;
Len := Integer (File_Length (FD));
declare
Buffer : String (1 .. Len + 1);
Index : Positive := 1;
Last : Positive;
begin
-- Read the file
Len := Read (FD, Buffer (1)'Address, Len);
Buffer (Buffer'Last) := ASCII.NUL;
Close (FD);
-- Scan the file line by line
while Index < Buffer'Last loop
-- Find the end of line
Last := Index;
while Last <= Buffer'Last
and then Buffer (Last) /= ASCII.LF
and then Buffer (Last) /= ASCII.CR
loop
Last := Last + 1;
end loop;
-- Ignore empty lines
if Last > Index then
Add_File (Buffer (Index .. Last - 1));
end if;
Index := Last;
-- Find the beginning of the next line
while Buffer (Index) = ASCII.CR or else
Buffer (Index) = ASCII.LF
loop
Index := Index + 1;
end loop;
end loop;
end;
-- Processing for --RTS=path
elsif Argv'Length >= 5 and then Argv (1 .. 5) = "--RTS" then
@ -849,70 +893,77 @@ procedure Gnatls is
-- Line for -a
Write_Str (" -a also output relevant predefined units");
Write_Str (" -a also output relevant predefined units");
Write_Eol;
-- Line for -u
Write_Str (" -u output only relevant unit names");
Write_Str (" -u output only relevant unit names");
Write_Eol;
-- Line for -h
Write_Str (" -h output this help message");
Write_Str (" -h output this help message");
Write_Eol;
-- Line for -s
Write_Str (" -s output only relevant source names");
Write_Str (" -s output only relevant source names");
Write_Eol;
-- Line for -o
Write_Str (" -o output only relevant object names");
Write_Str (" -o output only relevant object names");
Write_Eol;
-- Line for -d
Write_Str (" -d output sources on which specified units depend");
Write_Str (" -d output sources on which specified units " &
"depend");
Write_Eol;
-- Line for -v
Write_Str (" -v verbose output, full path and unit information");
Write_Str (" -v verbose output, full path and unit " &
"information");
Write_Eol;
Write_Eol;
-- Line for -files=
Write_Str (" -files=fil files are listed in text file 'fil'");
Write_Eol;
-- Line for -aI switch
Write_Str (" -aIdir specify source files search path");
Write_Str (" -aIdir specify source files search path");
Write_Eol;
-- Line for -aO switch
Write_Str (" -aOdir specify object files search path");
Write_Str (" -aOdir specify object files search path");
Write_Eol;
-- Line for -I switch
Write_Str (" -Idir like -aIdir -aOdir");
Write_Str (" -Idir like -aIdir -aOdir");
Write_Eol;
-- Line for -I- switch
Write_Str (" -I- do not look for sources & object files");
Write_Str (" -I- do not look for sources & object files");
Write_Str (" in the default directory");
Write_Eol;
-- Line for -nostdinc
Write_Str (" -nostdinc do not look for source files");
Write_Str (" -nostdinc do not look for source files");
Write_Str (" in the system default directory");
Write_Eol;
-- Line for --RTS
Write_Str (" --RTS=dir specify the default source and object search"
Write_Str (" --RTS=dir specify the default source and object search"
& " path");
Write_Eol;
@ -949,7 +1000,7 @@ begin
Next_Argv : String (1 .. Len_Arg (Next_Arg));
begin
Fill_Arg (Next_Argv'Address, Next_Arg);
Scan_Ls_Arg (Next_Argv, And_Save => True);
Scan_Ls_Arg (Next_Argv);
end;
Next_Arg := Next_Arg + 1;

43
gcc/ada/init.c
View File

@ -1812,27 +1812,34 @@ __gnat_initialize (void)
/* On targets where we might be using the ZCX scheme, we need to register
the frame tables.
For application "modules", the crtstuff objects linked in (crtbegin/endS)
are tailored to provide this service a-la C++ constructor fashion,
typically triggered by the dynamic loader. This is achieved by way of a
special variable declaration in the crt object, the name of which has
been deduced by analyzing the output of the "munching" step documented
for C++. The de-registration call is handled symetrically, a-la C++
destructor fashion and typically triggered by the dynamic unloader. With
this scheme, a mixed Ada/C++ application has to be linked and loaded as
separate modules for each language, which is not unreasonable anyway.
For applications loaded as a set of "modules", the crtstuff objects
linked in (crtbegin/endS) are tailored to provide this service a-la C++
static constructor fashion, typically triggered by the VxWorks loader.
This is achieved by way of a special variable declaration in the crt
object, the name of which has been deduced by analyzing the output of the
"munching" step documented for C++. The de-registration call is handled
symetrically, a-la C++ destructor fashion and typically triggered by the
dynamic unloader. Note that since the tables shall be registered against
a common datastructure, libgcc should be one of the modules (vs beeing
partially linked against all the others at build time) and shall be
loaded first.
For applications statically linked with the kernel, the module scheme
above would lead to duplicated symbols because the VxWorks kernel build
"munches" by default. To prevent those conflicts, we link against
crtbegin/end objects that don't include the special variable and directly
call the appropriate function here. We'll never unload that, so there is
no de-registration to worry about.
For applications linked with the kernel, the scheme above would lead to
duplicated symbols because the VxWorks kernel build "munches" by default.
To prevent those conflicts, we link against crtbegin/end objects that
don't include the special variable and directly call the appropriate
function here. We'll never unload that, so there is no de-registration to
worry about.
For whole applications loaded as a single module, we may use one scheme
or the other, except for the mixed Ada/C++ case in which the first scheme
would fail for the same reason as in the linked-with-kernel situation.
We can differentiate by looking at the __module_has_ctors value provided
by each class of crt objects. As of today, selecting the crt set intended
for applications to be statically linked with the kernel is triggered by
adding "-static" to the gcc *link* command line options.
by each class of crt objects. As of today, selecting the crt set with the
static ctors/dtors capabilities (first scheme above) is triggered by
adding "-static" to the gcc *link* command line options. Without this,
the other set of crt objects is fetched.
This is a first approach, tightly synchronized with a number of GCC
configuration and crtstuff changes. We need to ensure that those changes

2
gcc/ada/lang-specs.h
View File

@ -36,7 +36,7 @@
gnat1 %{I*} %{k8:-gnatk8} %{w:-gnatws} %1 %{!Q:-quiet} %{nostdinc*}\
%{nostdlib*}\
-dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\
%{g*} %{O*} %{W*} %{w} %{p} %{pg:-p} %{m*} %{a} %{f*} %{d*}\
%{O*} %{W*} %{w} %{p} %{pg:-p} %{a} %{f*} %{d*} %{g*&m*} \
%{!S:%{o*:%w%*-gnatO}} \
%i %{S:%W{o*}%{!o*:-o %b.s}} \
%{gnatc*|gnats*: -o %j} \

30
gcc/ada/lib.adb
View File

@ -50,6 +50,9 @@ with Uname; use Uname;
package body Lib is
Switch_Storing_Enabled : Boolean := True;
-- Set to False by Disable_Switch_Storing
-----------------------
-- Local Subprograms --
-----------------------
@ -403,6 +406,11 @@ package body Lib is
return Compilation_Switches.Last;
end Compilation_Switches_Last;
procedure Disable_Switch_Storing is
begin
Switch_Storing_Enabled := False;
end Disable_Switch_Storing;
------------------------------
-- Earlier_In_Extended_Unit --
------------------------------
@ -921,18 +929,20 @@ package body Lib is
procedure Store_Compilation_Switch (Switch : String) is
begin
Compilation_Switches.Increment_Last;
Compilation_Switches.Table (Compilation_Switches.Last) :=
new String'(Switch);
if Switch_Storing_Enabled then
Compilation_Switches.Increment_Last;
Compilation_Switches.Table (Compilation_Switches.Last) :=
new String'(Switch);
-- Fix up --RTS flag which has been transformed by the gcc driver
-- into -fRTS
-- Fix up --RTS flag which has been transformed by the gcc driver
-- into -fRTS
if Switch'Last >= Switch'First + 4
and then Switch (Switch'First .. Switch'First + 4) = "-fRTS"
then
Compilation_Switches.Table
(Compilation_Switches.Last) (Switch'First + 1) := '-';
if Switch'Last >= Switch'First + 4
and then Switch (Switch'First .. Switch'First + 4) = "-fRTS"
then
Compilation_Switches.Table
(Compilation_Switches.Last) (Switch'First + 1) := '-';
end if;
end if;
end Store_Compilation_Switch;

8
gcc/ada/lib.ads
View File

@ -537,7 +537,8 @@ package Lib is
-- be kept consistent).
procedure Replace_Linker_Option_String
(S : String_Id; Match_String : String);
(S : String_Id;
Match_String : String);
-- Replace an existing Linker_Option if the prefix Match_String
-- matches, otherwise call Store_Linker_Option_String.
@ -545,6 +546,11 @@ package Lib is
-- Called to register a compilation switch, either front-end or
-- back-end, which may influence the generated output file(s).
procedure Disable_Switch_Storing;
-- Disable the registration of compilation switches with
-- Store_Compilation_Switch. This is used to not register switches added
-- automatically by the gcc driver.
procedure Store_Linker_Option_String (S : String_Id);
-- This procedure is called to register the string from a pragma
-- Linker_Option. The argument is the Id of the string to register.

821
gcc/ada/make.adb
View File

@ -1986,6 +1986,9 @@ package body Make is
function Bad_Compilation_Count return Natural;
-- Returns the number of compilation failures.
procedure Check_Standard_Library;
-- Check if s-stalib.adb needs to be compiled
procedure Collect_Arguments_And_Compile
(Source_File : File_Name_Type; Source_Index : Int);
-- Collect arguments from project file (if any) and compile
@ -2146,6 +2149,48 @@ package body Make is
return Bad_Compilation.Last - Bad_Compilation.First + 1;
end Bad_Compilation_Count;
----------------------------
-- Check_Standard_Library --
----------------------------
procedure Check_Standard_Library is
begin
Need_To_Check_Standard_Library := False;
if not Targparm.Suppress_Standard_Library_On_Target then
declare
Sfile : Name_Id;
Add_It : Boolean := True;
begin
Name_Len := Standard_Library_Package_Body_Name'Length;
Name_Buffer (1 .. Name_Len) :=
Standard_Library_Package_Body_Name;
Sfile := Name_Enter;
-- If we have a special runtime, we add the standard
-- library only if we can find it.
if RTS_Switch then
Add_It :=
Find_File (Sfile, Osint.Source) /= No_File;
end if;
if Add_It then
if Is_Marked (Sfile) then
if Is_In_Obsoleted (Sfile) then
Executable_Obsolete := True;
end if;
else
Insert_Q (Sfile, Index => 0);
Mark (Sfile, Index => 0);
end if;
end if;
end;
end if;
end Check_Standard_Library;
-----------------------------------
-- Collect_Arguments_And_Compile --
-----------------------------------
@ -2234,7 +2279,7 @@ package body Make is
Source_Index : Int;
Args : Argument_List) return Process_Id
is
Comp_Args : Argument_List (Args'First .. Args'Last + 8);
Comp_Args : Argument_List (Args'First .. Args'Last + 9);
Comp_Next : Integer := Args'First;
Comp_Last : Integer;
@ -2401,6 +2446,9 @@ package body Make is
GNAT.OS_Lib.Normalize_Arguments (Comp_Args (Args'First .. Comp_Last));
Comp_Last := Comp_Last + 1;
Comp_Args (Comp_Last) := new String'("-gnatez");
Display (Gcc.all, Comp_Args (Args'First .. Comp_Last));
if Gcc_Path = null then
@ -2828,40 +2876,7 @@ package body Make is
-- only when "-a" is used.
if Need_To_Check_Standard_Library then
Need_To_Check_Standard_Library := False;
if not Targparm.Suppress_Standard_Library_On_Target then
declare
Sfile : Name_Id;
Add_It : Boolean := True;
begin
Name_Len := Standard_Library_Package_Body_Name'Length;
Name_Buffer (1 .. Name_Len) :=
Standard_Library_Package_Body_Name;
Sfile := Name_Enter;
-- If we have a special runtime, we add the standard
-- library only if we can find it.
if RTS_Switch then
Add_It :=
Find_File (Sfile, Osint.Source) /= No_File;
end if;
if Add_It then
if Is_Marked (Sfile) then
if Is_In_Obsoleted (Sfile) then
Executable_Obsolete := True;
end if;
else
Insert_Q (Sfile, Index => 0);
Mark (Sfile, Index => 0);
end if;
end if;
end;
end if;
Check_Standard_Library;
end if;
-- Now insert in the Q the unmarked source files (i.e. those
@ -3179,39 +3194,44 @@ package body Make is
for J in Args'Range loop
-- Do not display the mapping file argument automatically
-- created when using a project file.
-- Never display -gnatez
if Main_Project = No_Project
or else Debug.Debug_Flag_N
or else Args (J)'Length < 8
or else
Args (J)(Args (J)'First .. Args (J)'First + 6) /= "-gnatem"
then
-- When -dn is not specified, do not display the config
-- pragmas switch (-gnatec) for the temporary file created
-- by the project manager (always the first -gnatec switch).
-- Reset Temporary_Config_File to False so that the eventual
-- other -gnatec switches will be displayed.
if Args (J).all /= "-gnatez" then
if (not Debug.Debug_Flag_N)
and then Temporary_Config_File
and then Args (J)'Length > 7
and then Args (J)(Args (J)'First .. Args (J)'First + 6)
= "-gnatec"
-- Do not display the mapping file argument automatically
-- created when using a project file.
if Main_Project = No_Project
or else Debug.Debug_Flag_N
or else Args (J)'Length < 8
or else
Args (J) (Args (J)'First .. Args (J)'First + 6) /= "-gnatem"
then
Temporary_Config_File := False;
-- When -dn is not specified, do not display the config
-- pragmas switch (-gnatec) for the temporary file created
-- by the project manager (always the first -gnatec switch).
-- Reset Temporary_Config_File to False so that the eventual
-- other -gnatec switches will be displayed.
-- Do not display the -F=mapping_file switch for gnatbind,
-- if -dn is not specified.
if (not Debug.Debug_Flag_N)
and then Temporary_Config_File
and then Args (J)'Length > 7
and then Args (J) (Args (J)'First .. Args (J)'First + 6)
= "-gnatec"
then
Temporary_Config_File := False;
elsif Debug.Debug_Flag_N
or else Args (J)'Length < 4
or else Args (J)(Args (J)'First .. Args (J)'First + 2) /=
"-F="
then
Write_Str (" ");
Write_Str (Args (J).all);
-- Do not display the -F=mapping_file switch for
-- gnatbind, if -dn is not specified.
elsif Debug.Debug_Flag_N
or else Args (J)'Length < 4
or else
Args (J) (Args (J)'First .. Args (J)'First + 2) /= "-F="
then
Write_Str (" ");
Write_Str (Args (J).all);
end if;
end if;
end if;
end loop;
@ -3366,6 +3386,352 @@ package body Make is
-- Set to True when there are Stand-Alone Libraries, so that gnatbind
-- is invoked with the -F switch to force checking of elaboration flags.
Mapping_Path : Name_Id := No_Name;
-- The path name of the mapping file
Discard : Boolean;
procedure Check_Mains;
-- Check that the main subprograms do exist and that they all
-- belong to the same project file.
procedure Create_Binder_Mapping_File
(Args : in out Argument_List; Last_Arg : in out Natural);
-- Create a binder mapping file and add the necessary switch
-----------------
-- Check_Mains --
-----------------
procedure Check_Mains is
Real_Main_Project : Project_Id := No_Project;
-- The project of the first main
Proj : Project_Id := No_Project;
-- The project of the current main
Data : Project_Data;
Real_Path : String_Access;
begin
Mains.Reset;
-- Check each main
loop
declare
Main : constant String := Mains.Next_Main;
-- The name specified on the command line may include
-- directory information.
File_Name : constant String := Base_Name (Main);
-- The simple file name of the current main main
begin
exit when Main = "";
-- Get the project of the current main
Proj := Prj.Env.Project_Of (File_Name, Main_Project);
-- Fail if the current main is not a source of a
-- project.
if Proj = No_Project then
Make_Failed
("""" & Main &
""" is not a source of any project");
else
-- If there is directory information, check that
-- the source exists and, if it does, that the path
-- is the actual path of a source of a project.
if Main /= File_Name then
Data := Projects.Table (Main_Project);
Real_Path :=
Locate_Regular_File
(Main &
Get_Name_String
(Data.Naming.Current_Body_Suffix),
"");
if Real_Path = null then
Real_Path :=
Locate_Regular_File
(Main &
Get_Name_String
(Data.Naming.Current_Spec_Suffix),
"");
end if;
if Real_Path = null then
Real_Path :=
Locate_Regular_File (Main, "");
end if;
-- Fail if the file cannot be found
if Real_Path = null then
Make_Failed
("file """ & Main & """ does not exist");
end if;
declare
Project_Path : constant String :=
Prj.Env.File_Name_Of_Library_Unit_Body
(Name => File_Name,
Project => Main_Project,
Main_Project_Only => False,
Full_Path => True);
Normed_Path : constant String :=
Normalize_Pathname
(Real_Path.all,
Case_Sensitive => False);
Proj_Path : constant String :=
Normalize_Pathname
(Project_Path,
Case_Sensitive => False);
begin
Free (Real_Path);
-- Fail if it is not the correct path
if Normed_Path /= Proj_Path then
if Verbose_Mode then
Write_Str (Normed_Path);
Write_Str (" /= ");
Write_Line (Proj_Path);
end if;
Make_Failed
("""" & Main &
""" is not a source of any project");
end if;
end;
end if;
if not Unique_Compile then
-- Record the project, if it is the first main
if Real_Main_Project = No_Project then
Real_Main_Project := Proj;
elsif Proj /= Real_Main_Project then
-- Fail, as the current main is not a source
-- of the same project as the first main.
Make_Failed
("""" & Main &
""" is not a source of project " &
Get_Name_String
(Projects.Table
(Real_Main_Project).Name));
end if;
end if;
end if;
-- If -u and -U are not used, we may have mains that
-- are sources of a project that is not the one
-- specified with switch -P.
if not Unique_Compile then
Main_Project := Real_Main_Project;
end if;
end;
end loop;
end Check_Mains;
--------------------------------
-- Create_Binder_Mapping_File --
--------------------------------
procedure Create_Binder_Mapping_File
(Args : in out Argument_List; Last_Arg : in out Natural)
is
Mapping_FD : File_Descriptor := Invalid_FD;
-- A File Descriptor for an eventual mapping file
ALI_Unit : Name_Id := No_Name;
-- The unit name of an ALI file
ALI_Name : Name_Id := No_Name;
-- The file name of the ALI file
ALI_Project : Project_Id := No_Project;
-- The project of the ALI file
Bytes : Integer;
OK : Boolean := True;
Status : Boolean;
-- For call to Close
begin
Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path);
if Mapping_FD /= Invalid_FD then
-- Traverse all units
for J in Prj.Com.Units.First .. Prj.Com.Units.Last loop
declare
Unit : constant Prj.Com.Unit_Data :=
Prj.Com.Units.Table (J);
use Prj.Com;
begin
if Unit.Name /= No_Name then
-- If there is a body, put it in the mapping
if Unit.File_Names (Body_Part).Name /= No_Name
and then Unit.File_Names (Body_Part).Project
/= No_Project
then
Get_Name_String (Unit.Name);
Name_Buffer
(Name_Len + 1 .. Name_Len + 2) := "%b";
Name_Len := Name_Len + 2;
ALI_Unit := Name_Find;
ALI_Name :=
Lib_File_Name
(Unit.File_Names (Body_Part).Name);
ALI_Project :=
Unit.File_Names (Body_Part).Project;
-- Otherwise, if there is a spec, put it
-- in the mapping.
elsif Unit.File_Names (Specification).Name
/= No_Name
and then Unit.File_Names
(Specification).Project
/= No_Project
then
Get_Name_String (Unit.Name);
Name_Buffer
(Name_Len + 1 .. Name_Len + 2) := "%s";
Name_Len := Name_Len + 2;
ALI_Unit := Name_Find;
ALI_Name := Lib_File_Name
(Unit.File_Names (Specification).Name);
ALI_Project :=
Unit.File_Names (Specification).Project;
else
ALI_Name := No_Name;
end if;
-- If we have something to put in the mapping
-- then we do it now. However, if the project
-- is extended, we don't put anything in the
-- mapping file, because we do not know where
-- the ALI file is: it might be in the ext-
-- ended project obj dir as well as in the
-- extending project obj dir.
if ALI_Name /= No_Name
and then
Projects.Table (ALI_Project).Extended_By = No_Project
and then
Projects.Table (ALI_Project).Extends = No_Project
then
-- First line is the unit name
Get_Name_String (ALI_Unit);
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.LF;
Bytes :=
Write
(Mapping_FD,
Name_Buffer (1)'Address,
Name_Len);
OK := Bytes = Name_Len;
exit when not OK;
-- Second line it the ALI file name
Get_Name_String (ALI_Name);
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.LF;
Bytes :=
Write
(Mapping_FD,
Name_Buffer (1)'Address,
Name_Len);
OK := Bytes = Name_Len;
exit when not OK;
-- Third line it the ALI path name,
-- concatenation of the project
-- directory with the ALI file name.
declare
ALI : constant String :=
Get_Name_String (ALI_Name);
begin
Get_Name_String
(Projects.Table (ALI_Project).
Object_Directory);
if Name_Buffer (Name_Len) /=
Directory_Separator
then
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) :=
Directory_Separator;
end if;
Name_Buffer
(Name_Len + 1 ..
Name_Len + ALI'Length) := ALI;
Name_Len :=
Name_Len + ALI'Length + 1;
Name_Buffer (Name_Len) := ASCII.LF;
Bytes :=
Write
(Mapping_FD,
Name_Buffer (1)'Address,
Name_Len);
OK := Bytes = Name_Len;
end;
-- If OK is False, it means we were unable
-- to write a line. No point in continuing
-- with the other units.
exit when not OK;
end if;
end if;
end;
end loop;
Close (Mapping_FD, Status);
OK := OK and Status;
-- If the creation of the mapping file was successful,
-- we add the switch to the arguments of gnatbind.
if OK then
Last_Arg := Last_Arg + 1;
Args (Last_Arg) :=
new String'("-F=" & Get_Name_String (Mapping_Path));
end if;
end if;
end Create_Binder_Mapping_File;
-- Start of processing for Gnatmake
-- This body is very long, should be broken down ???
begin
Gnatmake_Called := True;
@ -3466,148 +3832,7 @@ package body Make is
-- project file and, if there are several mains, each of them
-- is a source of the same project file.
Mains.Reset;
declare
Real_Main_Project : Project_Id := No_Project;
-- The project of the first main
Proj : Project_Id := No_Project;
-- The project of the current main
begin
-- Check each main
loop
declare
Main : constant String := Mains.Next_Main;
-- The name specified on the command line may include
-- directory information.
File_Name : constant String := Base_Name (Main);
-- The simple file name of the current main main
begin
exit when Main = "";
-- Get the project of the current main
Proj := Prj.Env.Project_Of (File_Name, Main_Project);
-- Fail if the current main is not a source of a
-- project.
if Proj = No_Project then
Make_Failed
("""" & Main &
""" is not a source of any project");
else
-- If there is directory information, check that
-- the source exists and, if it does, that the path
-- is the actual path of a source of a project.
if Main /= File_Name then
declare
Data : constant Project_Data :=
Projects.Table (Main_Project);
Project_Path : constant String :=
Prj.Env.File_Name_Of_Library_Unit_Body
(Name => File_Name,
Project => Main_Project,
Main_Project_Only => False,
Full_Path => True);
Real_Path : String_Access :=
Locate_Regular_File
(Main &
Get_Name_String
(Data.Naming.Current_Body_Suffix),
"");
begin
if Real_Path = null then
Real_Path :=
Locate_Regular_File
(Main &
Get_Name_String
(Data.Naming.Current_Spec_Suffix),
"");
end if;
if Real_Path = null then
Real_Path :=
Locate_Regular_File (Main, "");
end if;
-- Fail if the file cannot be found
if Real_Path = null then
Make_Failed
("file """ & Main & """ does not exist");
end if;
declare
Normed_Path : constant String :=
Normalize_Pathname
(Real_Path.all,
Case_Sensitive => False);
Proj_Path : constant String :=
Normalize_Pathname
(Project_Path,
Case_Sensitive => False);
begin
Free (Real_Path);
-- Fail if it is not the correct path
if Normed_Path /= Proj_Path then
if Verbose_Mode then
Write_Str (Normed_Path);
Write_Str (" /= ");
Write_Line (Proj_Path);
end if;
Make_Failed
("""" & Main &
""" is not a source of any project");
end if;
end;
end;
end if;
if not Unique_Compile then
-- Record the project, if it is the first main
if Real_Main_Project = No_Project then
Real_Main_Project := Proj;
elsif Proj /= Real_Main_Project then
-- Fail, as the current main is not a source
-- of the same project as the first main.
Make_Failed
("""" & Main &
""" is not a source of project " &
Get_Name_String
(Projects.Table
(Real_Main_Project).Name));
end if;
end if;
end if;
-- If -u and -U are not used, we may have mains that
-- are sources of a project that is not the one
-- specified with switch -P.
if not Unique_Compile then
Main_Project := Real_Main_Project;
end if;
end;
end loop;
end;
Check_Mains;
end if;
-- If no mains have been specified on the command line,
@ -4717,27 +4942,6 @@ package body Make is
Last_Arg : Natural := Binder_Switches.Last;
-- Index of the last argument in Args
Mapping_FD : File_Descriptor := Invalid_FD;
-- A File Descriptor for an eventual mapping file
Mapping_Path : Name_Id := No_Name;
-- The path name of the mapping file
ALI_Unit : Name_Id := No_Name;
-- The unit name of an ALI file
ALI_Name : Name_Id := No_Name;
-- The file name of the ALI file
ALI_Project : Project_Id := No_Project;
-- The project of the ALI file
Bytes : Integer;
OK : Boolean := True;
Status : Boolean;
-- For call to Close
begin
-- If it is the first time the bind step is performed,
-- check if there are shared libraries, so that gnatbind is
@ -4787,164 +4991,7 @@ package body Make is
-- If switch -C was specified, create a binder mapping file
if Create_Mapping_File then
Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path);
if Mapping_FD /= Invalid_FD then
-- Traverse all units
for J in Prj.Com.Units.First .. Prj.Com.Units.Last loop
declare
Unit : constant Prj.Com.Unit_Data :=
Prj.Com.Units.Table (J);
use Prj.Com;
begin
if Unit.Name /= No_Name then
-- If there is a body, put it in the mapping
if Unit.File_Names (Body_Part).Name /= No_Name
and then Unit.File_Names (Body_Part).Project
/= No_Project
then
Get_Name_String (Unit.Name);
Name_Buffer
(Name_Len + 1 .. Name_Len + 2) := "%b";
Name_Len := Name_Len + 2;
ALI_Unit := Name_Find;
ALI_Name :=
Lib_File_Name
(Unit.File_Names (Body_Part).Name);
ALI_Project :=
Unit.File_Names (Body_Part).Project;
-- Otherwise, if there is a spec, put it
-- in the mapping.
elsif Unit.File_Names (Specification).Name
/= No_Name
and then Unit.File_Names
(Specification).Project
/= No_Project
then
Get_Name_String (Unit.Name);
Name_Buffer
(Name_Len + 1 .. Name_Len + 2) := "%s";
Name_Len := Name_Len + 2;
ALI_Unit := Name_Find;
ALI_Name := Lib_File_Name
(Unit.File_Names (Specification).Name);
ALI_Project :=
Unit.File_Names (Specification).Project;
else
ALI_Name := No_Name;
end if;
-- If we have something to put in the mapping
-- then we do it now. However, if the project
-- is extended, we don't put anything in the
-- mapping file, because we do not know where
-- the ALI file is: it might be in the ext-
-- ended project obj dir as well as in the
-- extending project obj dir.
if ALI_Name /= No_Name
and then Projects.Table
(ALI_Project).Extended_By
= No_Project
and then Projects.Table
(ALI_Project).Extends
= No_Project
then
-- First line is the unit name
Get_Name_String (ALI_Unit);
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.LF;
Bytes :=
Write
(Mapping_FD,
Name_Buffer (1)'Address,
Name_Len);
OK := Bytes = Name_Len;
if OK then
-- Second line it the ALI file name
Get_Name_String (ALI_Name);
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.LF;
Bytes :=
Write
(Mapping_FD,
Name_Buffer (1)'Address,
Name_Len);
OK := Bytes = Name_Len;
end if;
if OK then
-- Third line it the ALI path name,
-- concatenation of the project
-- directory with the ALI file name.
declare
ALI : constant String :=
Get_Name_String (ALI_Name);
begin
Get_Name_String
(Projects.Table (ALI_Project).
Object_Directory);
if Name_Buffer (Name_Len) /=
Directory_Separator
then
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) :=
Directory_Separator;
end if;
Name_Buffer
(Name_Len + 1 ..
Name_Len + ALI'Length) := ALI;
Name_Len :=
Name_Len + ALI'Length + 1;
Name_Buffer (Name_Len) := ASCII.LF;
Bytes :=
Write
(Mapping_FD,
Name_Buffer (1)'Address,
Name_Len);
OK := Bytes = Name_Len;
end;
end if;
-- If OK is False, it means we were unable
-- to write a line. No point in continuing
-- with the other units.
exit when not OK;
end if;
end if;
end;
end loop;
Close (Mapping_FD, Status);
OK := OK and Status;
-- If the creation of the mapping file was successful,
-- we add the switch to the arguments of gnatbind.
if OK then
Last_Arg := Last_Arg + 1;
Args (Last_Arg) := new String'
("-F=" & Get_Name_String (Mapping_Path));
end if;
end if;
Create_Binder_Mapping_File (Args, Last_Arg);
end if;
end if;
@ -4962,7 +5009,7 @@ package body Make is
if not Debug.Debug_Flag_N
and then Mapping_Path /= No_Name
then
Delete_File (Get_Name_String (Mapping_Path), OK);
Delete_File (Get_Name_String (Mapping_Path), Discard);
end if;
-- And reraise the exception
@ -4974,7 +5021,7 @@ package body Make is
-- if one was created.
if not Debug.Debug_Flag_N and then Mapping_Path /= No_Name then
Delete_File (Get_Name_String (Mapping_Path), OK);
Delete_File (Get_Name_String (Mapping_Path), Discard);
end if;
end Bind_Step;
end if;
@ -5439,7 +5486,6 @@ package body Make is
when X : others =>
Write_Line (Exception_Information (X));
Make_Failed ("INTERNAL ERROR. Please report.");
end Gnatmake;
----------
@ -5458,7 +5504,6 @@ package body Make is
function In_Ada_Lib_Dir (File : File_Name_Type) return Boolean is
D : constant Name_Id := Get_Directory (File);
B : constant Byte := Get_Name_Table_Byte (D);
begin
return (B and Ada_Lib_Dir) /= 0;
end In_Ada_Lib_Dir;

1433
gcc/ada/makegpr.adb
View File

File diff suppressed because it is too large Load Diff

5
gcc/ada/mlib-prj.adb
View File

@ -324,9 +324,6 @@ package body MLib.Prj is
Project_Name : constant String := Get_Name_String (Data.Name);
DLL_Address : constant String_Access :=
new String'(Default_DLL_Address);
Current_Dir : constant String := Get_Current_Dir;
Lib_Filename : String_Access;
@ -1473,9 +1470,7 @@ package body MLib.Prj is
Lib_Dir => Lib_Dirpath.all,
Symbol_Data => Data.Symbol_Data,
Driver_Name => Driver_Name,
Lib_Address => DLL_Address.all,
Lib_Version => Lib_Version.all,
Relocatable => The_Build_Mode = Relocatable,
Auto_Init => Data.Lib_Auto_Init);
when Static =>

13
gcc/ada/mlib-tgt-aix.adb
View File

@ -124,18 +124,14 @@ package body MLib.Tgt is
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
Relocatable : Boolean := False;
Auto_Init : Boolean := False)
is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Lib_Version);
pragma Unreferenced (Relocatable);
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
@ -222,15 +218,6 @@ package body MLib.Tgt is
Options_2 => Options_2.all);
end Build_Dynamic_Library;
-------------------------
-- Default_DLL_Address --
-------------------------
function Default_DLL_Address return String is
begin
return "";
end Default_DLL_Address;
-------------
-- DLL_Ext --
-------------

13
gcc/ada/mlib-tgt-hpux.adb
View File

@ -104,17 +104,13 @@ package body MLib.Tgt is
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
Relocatable : Boolean := False;
Auto_Init : Boolean := False)
is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
@ -201,15 +197,6 @@ package body MLib.Tgt is
end if;
end Build_Dynamic_Library;
-------------------------
-- Default_DLL_Address --
-------------------------
function Default_DLL_Address return String is
begin
return "";
end Default_DLL_Address;
-------------
-- DLL_Ext --
-------------

13
gcc/ada/mlib-tgt-irix.adb
View File

@ -105,17 +105,13 @@ package body MLib.Tgt is
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
Relocatable : Boolean := False;
Auto_Init : Boolean := False)
is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
@ -196,15 +192,6 @@ package body MLib.Tgt is
end if;
end Build_Dynamic_Library;
-------------------------
-- Default_DLL_Address --
-------------------------
function Default_DLL_Address return String is
begin
return "";
end Default_DLL_Address;
-------------
-- DLL_Ext --
-------------

13
gcc/ada/mlib-tgt-linux.adb
View File

@ -108,17 +108,13 @@ package body MLib.Tgt is
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
Relocatable : Boolean := False;
Auto_Init : Boolean := False)
is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
@ -198,15 +194,6 @@ package body MLib.Tgt is
end if;
end Build_Dynamic_Library;
-------------------------
-- Default_DLL_Address --
-------------------------
function Default_DLL_Address return String is
begin
return "";
end Default_DLL_Address;
-------------
-- DLL_Ext --
-------------

109
gcc/ada/mlib-tgt-mingw.adb
View File

@ -96,9 +96,7 @@ package body MLib.Tgt is
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
Relocatable : Boolean := False;
Auto_Init : Boolean := False)
is
pragma Unreferenced (Foreign);
@ -108,126 +106,25 @@ package body MLib.Tgt is
pragma Unreferenced (Interfaces);
pragma Unreferenced (Lib_Version);
Strip_Name : constant String := "strip";
Strip_Exec : String_Access;
procedure Strip_Reloc (Lib_File : String);
-- Strip .reloc section to build a non relocatable DLL
-----------------
-- Strip_Reloc --
-----------------
procedure Strip_Reloc (Lib_File : String) is
Arguments : Argument_List (1 .. 3);
Success : Boolean;
Line_Length : Natural;
begin
-- Look for strip executable
Strip_Exec := Locate_Exec_On_Path (Strip_Name);
if Strip_Exec = null then
Fail (Strip_Name, " not found in path");
elsif Opt.Verbose_Mode then
Write_Str ("found ");
Write_Line (Strip_Exec.all);
end if;
-- Call it: strip -R .reloc <dll>
Arguments (1) := new String'("-R");
Arguments (2) := new String'(".reloc");
Arguments (3) := new String'(Lib_File);
if not Opt.Quiet_Output then
Write_Str (Strip_Exec.all);
Line_Length := Strip_Exec'Length;
for K in Arguments'Range loop
-- Make sure the Output buffer does not overflow
if Line_Length + 1 + Arguments (K)'Length >
Integer (Opt.Max_Line_Length)
then
Write_Eol;
Line_Length := 0;
end if;
Write_Char (' ');
Write_Str (Arguments (K).all);
Line_Length := Line_Length + 1 + Arguments (K)'Length;
end loop;
Write_Eol;
end if;
Spawn (Strip_Exec.all, Arguments, Success);
if not Success then
Fail (Strip_Name, " execution error.");
end if;
for K in Arguments'Range loop
Free (Arguments (K));
end loop;
end Strip_Reloc;
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
Lib_Dir & Directory_Separator &
Files.Ext_To (Lib_Filename, DLL_Ext);
I_Base : aliased String := "-Wl,--image-base," & Lib_Address;
Options_2 : Argument_List (1 .. 1);
O_Index : Natural := 0;
-- Start of processing for Build_Dynamic_Library
begin
if Opt.Verbose_Mode then
Write_Str ("building ");
if not Relocatable then
Write_Str ("non-");
end if;
Write_Str ("relocatable shared library ");
Write_Str ("building relocatable shared library ");
Write_Line (Lib_File);
end if;
if not Relocatable then
O_Index := O_Index + 1;
Options_2 (O_Index) := I_Base'Unchecked_Access;
end if;
Tools.Gcc
(Output_File => Lib_File,
Objects => Ofiles,
Options => Options,
Driver_Name => Driver_Name,
Options_2 => Options_2 (1 .. O_Index));
if not Relocatable then
-- Strip reloc symbols from the DLL
Strip_Reloc (Lib_File);
end if;
Driver_Name => Driver_Name);
end Build_Dynamic_Library;
-------------------------
-- Default_DLL_Address --
-------------------------
function Default_DLL_Address return String is
begin
return "0x11000000";
end Default_DLL_Address;
-------------
-- DLL_Ext --
-------------

13
gcc/ada/mlib-tgt-solaris.adb
View File

@ -102,17 +102,13 @@ package body MLib.Tgt is
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
Relocatable : Boolean := False;
Auto_Init : Boolean := False)
is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
@ -195,15 +191,6 @@ package body MLib.Tgt is
end if;
end Build_Dynamic_Library;
-------------------------
-- Default_DLL_Address --
-------------------------
function Default_DLL_Address return String is
begin
return "";
end Default_DLL_Address;
-------------
-- DLL_Ext --
-------------

13
gcc/ada/mlib-tgt-tru64.adb
View File

@ -110,17 +110,13 @@ package body MLib.Tgt is
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
Relocatable : Boolean := False;
Auto_Init : Boolean := False)
is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Interfaces);
pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
@ -213,15 +209,6 @@ package body MLib.Tgt is
end if;
end Build_Dynamic_Library;
-------------------------
-- Default_DLL_Address --
-------------------------
function Default_DLL_Address return String is
begin
return "";
end Default_DLL_Address;
-------------
-- DLL_Ext --
-------------

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

@ -132,15 +132,11 @@ package body MLib.Tgt is
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
Relocatable : Boolean := False;
Auto_Init : Boolean := False)
is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
@ -529,15 +525,6 @@ package body MLib.Tgt is
end if;
end Build_Dynamic_Library;
-------------------------
-- Default_DLL_Address --
-------------------------
function Default_DLL_Address return String is
begin
return "";
end Default_DLL_Address;
-------------
-- DLL_Ext --
-------------

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

@ -132,15 +132,11 @@ package body MLib.Tgt is
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
Relocatable : Boolean := False;
Auto_Init : Boolean := False)
is
pragma Unreferenced (Foreign);
pragma Unreferenced (Afiles);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
@ -562,15 +558,6 @@ package body MLib.Tgt is
end if;
end Build_Dynamic_Library;
-------------------------
-- Default_DLL_Address --
-------------------------
function Default_DLL_Address return String is
begin
return "";
end Default_DLL_Address;
-------------
-- DLL_Ext --
-------------

13
gcc/ada/mlib-tgt-vxworks.adb
View File

@ -95,9 +95,7 @@ package body MLib.Tgt is
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
Relocatable : Boolean := False;
Auto_Init : Boolean := False)
is
pragma Unreferenced (Ofiles);
@ -109,24 +107,13 @@ package body MLib.Tgt is
pragma Unreferenced (Lib_Dir);
pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Driver_Name);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Lib_Version);
pragma Unreferenced (Relocatable);
pragma Unreferenced (Auto_Init);
begin
null;
end Build_Dynamic_Library;
-------------------------
-- Default_DLL_Address --
-------------------------
function Default_DLL_Address return String is
begin
return "";
end Default_DLL_Address;
-------------
-- DLL_Ext --
-------------

15
gcc/ada/mlib-tgt.adb
View File

@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2003, Ada Core Technologies, Inc. --
-- Copyright (C) 2001-2004, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -81,9 +81,7 @@ package body MLib.Tgt is
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
Relocatable : Boolean := False;
Auto_Init : Boolean := False)
is
pragma Unreferenced (Ofiles);
@ -95,24 +93,13 @@ package body MLib.Tgt is
pragma Unreferenced (Lib_Dir);
pragma Unreferenced (Symbol_Data);
pragma Unreferenced (Driver_Name);
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Lib_Version);
pragma Unreferenced (Relocatable);
pragma Unreferenced (Auto_Init);
begin
null;
end Build_Dynamic_Library;
-------------------------
-- Default_DLL_Address --
-------------------------
function Default_DLL_Address return String is
begin
return "";
end Default_DLL_Address;
-------------
-- DLL_Ext --
-------------

17
gcc/ada/mlib-tgt.ads
View File

@ -64,11 +64,6 @@ package MLib.Tgt is
-- Returns the name of the program, if any, that generates an index
-- to the contents of an archive, usually "ranlib".
function Default_DLL_Address return String;
-- Default address for non relocatable DLL.
-- For OSes where a dynamic library is always relocatable,
-- this function returns an empty string.
function Dynamic_Option return String;
-- gcc option to create a dynamic library.
-- For Unix, returns "-shared", for Windows returns "-mdll".
@ -96,7 +91,7 @@ package MLib.Tgt is
-- Returns True iff Ext is an object file extension
function Is_C_Ext (Ext : String) return Boolean;
-- Returns True iff Ext is a C file extension.
-- Returns True iff Ext is a C file extension
function Is_Archive_Ext (Ext : String) return Boolean;
-- Returns True iff Ext is an extension for a library
@ -111,9 +106,7 @@ package MLib.Tgt is
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
Relocatable : Boolean := False;
Auto_Init : Boolean := False);
-- Build a dynamic/relocatable library
--
@ -135,20 +128,12 @@ package MLib.Tgt is
--
-- Lib_Dir is the directory path where the library will be located
--
-- Lib_Address is the base address of the library for a non relocatable
-- library, given as an hexadecimal string.
--
-- For OSes that support symbolic links, Lib_Version, if non null,
-- is the actual file name of the library. For example on Unix, if
-- Lib_Filename is "toto" and Lib_Version is "libtoto.so.2.1",
-- "libtoto.so" will be a symbolic link to "libtoto.so.2.1" which
-- will be the actual library file.
--
-- Relocatable indicates if the library should be relocatable or not,
-- for those OSes that actually support non relocatable dynamic libraries.
-- Relocatable indicates that automatic elaboration/finalization must be
-- indicated to the linker, if possible.
--
-- Symbol_Data is used for some patforms, including VMS, to generate
-- the symbols to be exported by the library.
--

24
gcc/ada/opt.ads
View File

@ -249,17 +249,17 @@ package Opt is
Create_Mapping_File : Boolean := False;
-- GNATMAKE
-- Set to True (-C switch) to indicate that gnatmake
-- invokes the compiler with a mapping file (-gnatem compiler switch).
-- Set to True (-C switch) to indicate that gnatmake will invoke
-- the compiler with a mapping file (-gnatem compiler switch).
subtype Debug_Level_Value is Nat range 0 .. 3;
Debugger_Level : Debug_Level_Value := 0;
-- GNATBIND
-- The value given to the -g parameter.
-- The default value for -g with no value is 2
-- This is usually ignored by GNATBIND, except in the VMS version
-- where it is passed as an argument to __gnat_initialize to trigger
-- the activation of the remote debugging interface (is this true???).
-- The value given to the -g parameter. The default value for -g with
-- no value is 2. This is usually ignored by GNATBIND, except in the
-- VMS version where it is passed as an argument to __gnat_initialize
-- to trigger the activation of the remote debugging interface.
-- Is this still true ???
Debug_Generated_Code : Boolean := False;
-- GNAT
@ -274,11 +274,15 @@ package Opt is
-- default was set by the binder, and that the default should be the
-- initial value of System.Secondary_Stack.Default_Secondary_Stack_Size.
Detect_Blocking : Boolean := False;
-- GNAT
-- Set True to force the run time to raise Program_Error if calls to
-- potentially blocking operations are detected from protected actions.
Display_Compilation_Progress : Boolean := False;
-- GNATMAKE
-- Set True (-d switch) to display information on progress while compiling
-- files. Internal flag to be used in conjunction with an IDE such as
-- Glide.
-- files. Internal flag to be used in conjunction with an IDE (e.g GPS).
type Distribution_Stub_Mode_Type is
-- GNAT
@ -457,8 +461,6 @@ package Opt is
GCC_Version : constant Nat := get_gcc_version;
-- GNATMAKE
-- Indicates which version of gcc is in use (2 = 2.8.1, 3 = 3.x).
-- Used in particular to decide if gcc switch -shared-libgcc should be
-- used (it cannot be used for 2.8.1).
Global_Discard_Names : Boolean := False;
-- GNAT, GNATBIND

1
gcc/ada/par-prag.adb
View File

@ -928,6 +928,7 @@ begin
Pragma_Component_Alignment |
Pragma_Controlled |
Pragma_Convention |
Pragma_Detect_Blocking |
Pragma_Discard_Names |
Pragma_Eliminate |
Pragma_Elaborate |

18
gcc/ada/par-util.adb
View File

@ -24,8 +24,9 @@
-- --
------------------------------------------------------------------------------
with Csets; use Csets;
with Uintp; use Uintp;
with Csets; use Csets;
with Stylesw; use Stylesw;
with Uintp; use Uintp;
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
@ -114,7 +115,6 @@ package body Util is
end if;
if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
for J in 1 .. S'Last loop
M1 (P1 + J - 1) := Fold_Upper (S (J));
end loop;
@ -126,7 +126,6 @@ package body Util is
else
return False;
end if;
end Bad_Spelling_Of;
----------------------
@ -360,7 +359,6 @@ package body Util is
procedure Discard_Junk_List (L : List_Id) is
pragma Warnings (Off, L);
begin
null;
end Discard_Junk_List;
@ -371,7 +369,6 @@ package body Util is
procedure Discard_Junk_Node (N : Node_Id) is
pragma Warnings (Off, N);
begin
null;
end Discard_Junk_Node;
@ -627,6 +624,15 @@ package body Util is
procedure Push_Scope_Stack is
begin
Scope.Increment_Last;
if Style_Check_Max_Nesting_Level
and then Scope.Last = Style_Max_Nesting_Level + 1
then
Error_Msg
("(style) maximum nesting level exceeded",
First_Non_Blank_Location);
end if;
Scope.Table (Scope.Last).Junk := False;
Scope.Table (Scope.Last).Node := Empty;

4
gcc/ada/prj-env.adb
View File

@ -1484,7 +1484,7 @@ package body Prj.Env is
-- If there are Ada sources, call action with the name of every
-- source directory.
if Projects.Table (Project).Sources_Present then
if Projects.Table (Project).Ada_Sources_Present then
while Current /= Nil_String loop
The_String := String_Elements.Table (Current);
Action (Get_Name_String (The_String.Value));
@ -1948,7 +1948,7 @@ package body Prj.Env is
-- Add to path all source directories of this project
-- if there are Ada sources.
if Projects.Table (Project).Sources_Present then
if Projects.Table (Project).Ada_Sources_Present then
Add_To_Source_Path (Data.Source_Dirs);
end if;
end if;

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

@ -149,16 +149,21 @@ package body Prj.Nmsc is
function ALI_File_Name (Source : String) return String;
-- Return the ALI file name corresponding to a source.
procedure Check_Ada_Naming_Scheme
(Project : Project_Id;
Naming : Naming_Data);
-- Check that the package Naming is correct.
procedure Check_Ada_Name
(Name : String;
Unit : out Name_Id);
-- Check that a name is a valid Ada unit name.
procedure Check_Ada_Naming_Scheme
(Data : in out Project_Data;
Project : Project_Id);
-- Check the naming scheme part of Data
procedure Check_Ada_Naming_Scheme_Validity
(Project : Project_Id;
Naming : Naming_Data);
-- Check that the package Naming is correct.
procedure Check_For_Source
(File_Name : Name_Id;
Path_Name : Name_Id;
@ -171,11 +176,6 @@ package body Prj.Nmsc is
-- Check if a file in a source directory is a source for a specific
-- language other than Ada.
procedure Check_Naming_Scheme
(Data : in out Project_Data;
Project : Project_Id);
-- Check the naming scheme part of Data
function Check_Project
(P : Project_Id;
Root_Project : Project_Id;
@ -540,7 +540,7 @@ package body Prj.Nmsc is
Languages := Prj.Util.Value_Of (Name_Languages, Data.Decl.Attributes);
Data.Naming.Current_Language := Name_Ada;
Data.Sources_Present := Data.Source_Dirs /= Nil_String;
Data.Ada_Sources_Present := Data.Source_Dirs /= Nil_String;
if not Languages.Default then
declare
@ -566,21 +566,21 @@ package body Prj.Nmsc is
-- Mark the project file as having no sources for Ada
Data.Sources_Present := False;
Data.Ada_Sources_Present := False;
end if;
end;
end if;
Check_Naming_Scheme (Data, Project);
Check_Ada_Naming_Scheme (Data, Project);
Prepare_Ada_Naming_Exceptions (Data.Naming.Bodies, Body_Part);
Prepare_Ada_Naming_Exceptions (Data.Naming.Specs, Specification);
-- If we have source directories, then find the sources
if Data.Sources_Present then
if Data.Ada_Sources_Present then
if Data.Source_Dirs = Nil_String then
Data.Sources_Present := False;
Data.Ada_Sources_Present := False;
else
declare
@ -628,7 +628,7 @@ package body Prj.Nmsc is
begin
Source_Names.Reset;
Data.Sources_Present := Current /= Nil_String;
Data.Ada_Sources_Present := Current /= Nil_String;
while Current /= Nil_String loop
Element := String_Elements.Table (Current);
@ -835,7 +835,7 @@ package body Prj.Nmsc is
end if;
end if;
if Data.Sources_Present then
if Data.Ada_Sources_Present then
-- Check that all individual naming conventions apply to
-- sources of this project file.
@ -1754,7 +1754,8 @@ package body Prj.Nmsc is
Other_Sources.Table (Other_Sources.Last) := Source;
-- There are sources of languages other than Ada in this project
Data.Sources_Present := True;
Data.Other_Sources_Present := True;
-- And there are sources of this language in this project
@ -1776,11 +1777,11 @@ package body Prj.Nmsc is
end if;
end Check_For_Source;
-----------------------------
-- Check_Ada_Naming_Scheme --
-----------------------------
--------------------------------------
-- Check_Ada_Naming_Scheme_Validity --
--------------------------------------
procedure Check_Ada_Naming_Scheme
procedure Check_Ada_Naming_Scheme_Validity
(Project : Project_Id;
Naming : Naming_Data)
is
@ -1909,13 +1910,13 @@ package body Prj.Nmsc is
end if;
end;
end if;
end Check_Ada_Naming_Scheme;
end Check_Ada_Naming_Scheme_Validity;
-------------------------
-- Check_Naming_Scheme --
-------------------------
-----------------------------
-- Check_Ada_Naming_Scheme --
-----------------------------
procedure Check_Naming_Scheme
procedure Check_Ada_Naming_Scheme
(Data : in out Project_Data;
Project : Project_Id)
is
@ -1975,7 +1976,7 @@ package body Prj.Nmsc is
end loop;
end Check_Unit_Names;
-- Start of processing for Check_Naming_Scheme
-- Start of processing for Check_Ada_Naming_Scheme
begin
-- If there is a package Naming, we will put in Data.Naming what is in
@ -2232,14 +2233,14 @@ package body Prj.Nmsc is
-- Check if Data.Naming is valid
Check_Ada_Naming_Scheme (Project, Data.Naming);
Check_Ada_Naming_Scheme_Validity (Project, Data.Naming);
else
Data.Naming.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
Data.Naming.Current_Body_Suffix := Default_Ada_Body_Suffix;
Data.Naming.Separate_Suffix := Default_Ada_Body_Suffix;
end if;
end Check_Naming_Scheme;
end Check_Ada_Naming_Scheme;
-------------------
-- Check_Project --
@ -2515,7 +2516,7 @@ package body Prj.Nmsc is
-- any source, then we never call Find_Sources.
if Current_Source /= Nil_String then
Data.Sources_Present := True;
Data.Ada_Sources_Present := True;
elsif Data.Extends = No_Project then
Error_Msg
@ -3431,8 +3432,9 @@ package body Prj.Nmsc is
Data.Object_Directory := No_Name;
end if;
Data.Source_Dirs := Nil_String;
Data.Sources_Present := False;
Data.Source_Dirs := Nil_String;
Data.Ada_Sources_Present := False;
Data.Other_Sources_Present := False;
else
declare
@ -4016,9 +4018,9 @@ package body Prj.Nmsc is
Data := Projects.Table (Project);
Languages := Prj.Util.Value_Of (Name_Languages, Data.Decl.Attributes);
Data.Sources_Present := Data.Source_Dirs /= Nil_String;
Data.Other_Sources_Present := Data.Source_Dirs /= Nil_String;
if Data.Sources_Present then
if Data.Other_Sources_Present then
-- Check if languages other than Ada are specified in this project
if Languages.Default then
@ -4029,7 +4031,7 @@ package body Prj.Nmsc is
-- No sources of languages other than Ada
Data.Sources_Present := False;
Data.Other_Sources_Present := False;
else
declare
@ -4039,9 +4041,9 @@ package body Prj.Nmsc is
begin
-- Assumethat there is no language other than Ada specified.
-- If in fact there is at least one, we will set back
-- Sources_Present to True.
-- Other_Sources_Present to True.
Data.Sources_Present := False;
Data.Other_Sources_Present := False;
-- Look through all the languages specified in attribute
-- Languages, if any
@ -4070,7 +4072,7 @@ package body Prj.Nmsc is
-- than Ada.
if Lang /= Lang_Ada then
Data.Sources_Present := True;
Data.Other_Sources_Present := True;
end if;
exit Lang_Loop;
@ -4095,11 +4097,11 @@ package body Prj.Nmsc is
-- If there may be some sources, look for them
if Data.Sources_Present then
if Data.Other_Sources_Present then
-- Set Source_Present to False. It will be set back to True whenever
-- a source is found.
Data.Sources_Present := False;
Data.Other_Sources_Present := False;
for Lang in Other_Programming_Language loop
-- For each language (other than Ada) in the project file

32
gcc/ada/prj-part.adb
View File

@ -161,22 +161,26 @@ package body Prj.Part is
(Context_Clause : With_Id;
Imported_Projects : out Project_Node_Id;
Project_Directory : Name_Id;
From_Extended : Extension_Origin);
From_Extended : Extension_Origin;
In_Limited : Boolean);
-- Parse the imported projects that have been stored in table Withs,
-- if any. From_Extended is used for the call to Parse_Single_Project
-- below.
-- below. When In_Limited is True, the importing path includes at least
-- one "limited with".
procedure Parse_Single_Project
(Project : out Project_Node_Id;
Extends_All : out Boolean;
Path_Name : String;
Extended : Boolean;
From_Extended : Extension_Origin);
From_Extended : Extension_Origin;
In_Limited : Boolean);
-- Parse a project file.
-- Recursive procedure: it calls itself for imported and extended
-- projects. When From_Extended is not None, if the project has already
-- been parsed and is an extended project A, return the ultimate
-- (not extended) project that extends A.
-- (not extended) project that extends A. When In_Limited is True,
-- the importing path includes at least one "limited with".
function Project_Path_Name_Of
(Project_File_Name : String;
@ -472,7 +476,8 @@ package body Prj.Part is
Extends_All => Dummy,
Path_Name => Path_Name,
Extended => False,
From_Extended => None);
From_Extended => None,
In_Limited => False);
-- If Project is an extending-all project, create the eventual
-- virtual extending projects and check that there are no illegally
@ -668,7 +673,8 @@ package body Prj.Part is
(Context_Clause : With_Id;
Imported_Projects : out Project_Node_Id;
Project_Directory : Name_Id;
From_Extended : Extension_Origin)
From_Extended : Extension_Origin;
In_Limited : Boolean)
is
Current_With_Clause : With_Id := Context_Clause;
@ -690,7 +696,7 @@ package body Prj.Part is
Current_With := Withs.Table (Current_With_Clause);
Current_With_Clause := Current_With.Next;
Limited_With := Current_With.Limited_With;
Limited_With := In_Limited or Current_With.Limited_With;
declare
Original_Path : constant String :=
@ -783,7 +789,8 @@ package body Prj.Part is
Extends_All => Extends_All,
Path_Name => Imported_Path_Name,
Extended => False,
From_Extended => From_Extended);
From_Extended => From_Extended,
In_Limited => Limited_With);
else
Extends_All := Is_Extending_All (Withed_Project);
@ -833,7 +840,8 @@ package body Prj.Part is
Extends_All : out Boolean;
Path_Name : String;
Extended : Boolean;
From_Extended : Extension_Origin)
From_Extended : Extension_Origin;
In_Limited : Boolean)
is
Normed_Path_Name : Name_Id;
Canonical_Path_Name : Name_Id;
@ -1159,7 +1167,8 @@ package body Prj.Part is
(Context_Clause => First_With,
Imported_Projects => Imported_Projects,
Project_Directory => Project_Directory,
From_Extended => From_Ext);
From_Extended => From_Ext,
In_Limited => In_Limited);
Set_First_With_Clause_Of (Project, Imported_Projects);
end;
@ -1255,7 +1264,8 @@ package body Prj.Part is
Extends_All => Extends_All,
Path_Name => Extended_Project_Path_Name,
Extended => True,
From_Extended => From_Ext);
From_Extended => From_Ext,
In_Limited => In_Limited);
end;
-- A project that extends an extending-all project is also

29
gcc/ada/prj-proc.adb
View File

@ -63,6 +63,14 @@ package body Prj.Proc is
-- Add all attributes, starting with First, with their default
-- values to the package or project with declarations Decl.
procedure Check
(Project : in out Project_Id;
Process_Languages : Languages_Processed;
Follow_Links : Boolean);
-- Set all projects to not checked, then call Recursive_Check for the
-- main project Project. Project is set to No_Project if errors occurred.
-- See Prj.Nmsc.Ada_Check for information on Follow_Links.
function Expression
(Project : Project_Id;
From_Project_Node : Project_Node_Id;
@ -102,14 +110,6 @@ package body Prj.Proc is
-- recursively for all imported projects and a extended project, if any.
-- Then process the declarative items of the project.
procedure Check
(Project : in out Project_Id;
Process_Languages : Languages_Processed;
Follow_Links : Boolean);
-- Set all projects to not checked, then call Recursive_Check for the
-- main project Project. Project is set to No_Project if errors occurred.
-- See Prj.Nmsc.Ada_Check for information on Follow_Links.
procedure Recursive_Check
(Project : Project_Id;
Process_Languages : Languages_Processed;
@ -903,7 +903,13 @@ package body Prj.Proc is
Extending2 := Extending;
while Extending2 /= No_Project loop
if Projects.Table (Extending2).Sources_Present
if ((Process_Languages = Ada_Language
and then
Projects.Table (Extending2).Ada_Sources_Present)
or else
(Process_Languages = Other_Languages
and then
Projects.Table (Extending2).Other_Sources_Present))
and then
Projects.Table (Extending2).Object_Directory = Obj_Dir
then
@ -1827,6 +1833,11 @@ package body Prj.Proc is
when Other_Languages =>
Prj.Nmsc.Other_Languages_Check (Project, Error_Report);
when All_Languages =>
Prj.Nmsc.Ada_Check (Project, Error_Report, Follow_Links);
Prj.Nmsc.Other_Languages_Check (Project, Error_Report);
end case;
end if;
end Recursive_Check;

4
gcc/ada/prj.adb
View File

@ -93,12 +93,12 @@ package body Prj is
Library_Name => No_Name,
Library_Kind => Static,
Lib_Internal_Name => No_Name,
Lib_Elaboration => False,
Standalone_Library => False,
Lib_Interface_ALIs => Nil_String,
Lib_Auto_Init => False,
Symbol_Data => No_Symbols,
Sources_Present => True,
Ada_Sources_Present => True,
Other_Sources_Present => True,
Sources => Nil_String,
First_Other_Source => No_Other_Source,
Last_Other_Source => No_Other_Source,

27
gcc/ada/prj.ads
View File

@ -67,7 +67,7 @@ package Prj is
Slash : Name_Id;
-- "/", used as the path of locally removed files
type Languages_Processed is (Ada_Language, Other_Languages);
type Languages_Processed is (Ada_Language, Other_Languages, All_Languages);
-- To specify how to process project files
type Programming_Language is
@ -521,11 +521,6 @@ package Prj is
-- If a library project, internal name store inside the library
-- Set by Prj.Nmsc.Language_Independent_Check.
Lib_Elaboration : Boolean := False;
-- If a library project, indicate if <lib>init and <lib>final
-- procedures need to be defined.
-- Set by Prj.Nmsc.Language_Independent_Check.
Standalone_Library : Boolean := False;
-- Indicate that this is a Standalone Library Project File.
-- Set by Prj.Nmsc.Ada_Check.
@ -542,16 +537,18 @@ package Prj is
Symbol_Data : Symbol_Record := No_Symbols;
-- Symbol file name, reference symbol file name, symbol policy
Sources_Present : Boolean := True;
-- A flag that indicates if there are sources in this project file.
Ada_Sources_Present : Boolean := True;
-- A flag that indicates if there are Ada sources in this project file.
-- There are no sources if 1) Source_Dirs is specified as an
-- empty list, 2) Source_Files is specified as an empty list, or
-- 3) the current language is not in the list of the specified
-- Languages.
-- 3) Ada is not in the list of the specified Languages.
Other_Sources_Present : Boolean := True;
-- A flag that indicates that there are non-Ada sources in this project
Sources : String_List_Id := Nil_String;
-- The list of all the source file names.
-- Set by Prj.Nmsc.Check_Naming_Scheme.
-- Set by Prj.Nmsc.Check_Ada_Naming_Scheme.
First_Other_Source : Other_Source_Id := No_Other_Source;
Last_Other_Source : Other_Source_Id := No_Other_Source;
@ -571,7 +568,7 @@ package Prj is
Source_Dirs : String_List_Id := Nil_String;
-- The list of all the source directories.
-- Set by Prj.Nmsc.Check_Naming_Scheme.
-- Set by Prj.Nmsc.Language_Independent_Check.
Known_Order_Of_Source_Dirs : Boolean := True;
-- False, if there is any /** in the Source_Dirs, because in this case
@ -580,14 +577,14 @@ package Prj is
Object_Directory : Name_Id := No_Name;
-- The object directory of this project file.
-- Set by Prj.Nmsc.Check_Naming_Scheme.
-- Set by Prj.Nmsc.Language_Independent_Check.
Display_Object_Dir : Name_Id := No_Name;
Exec_Directory : Name_Id := No_Name;
-- The exec directory of this project file.
-- Default is equal to Object_Directory.
-- Set by Prj.Nmsc.Check_Naming_Scheme.
-- Set by Prj.Nmsc.Language_Independent_Check.
Display_Exec_Dir : Name_Id := No_Name;
@ -661,7 +658,7 @@ package Prj is
Checked : Boolean := False;
-- A flag to avoid checking repetitively the naming scheme of
-- this project file.
-- Set by Prj.Nmsc.Check_Naming_Scheme.
-- Set by Prj.Nmsc.Check_Ada_Naming_Scheme.
Seen : Boolean := False;
Flag1 : Boolean := False;

50
gcc/ada/raise.c
View File

@ -467,33 +467,16 @@ db_phases (int phases)
*/
/* This is the structure of exception objects as built by the GNAT runtime
library (a-exexpr.adb). The layouts should exactly match, and the "common"
header is mandated by the exception handling ABI. */
/* This is an incomplete "proxy" of the structure of exception objects as
built by the GNAT runtime library. Accesses to other fields than the common
header are performed through subprogram calls to aleviate the need of an
exact counterpart here and potential alignment/size issues for the common
header. See a-exexpr.adb. */
typedef struct
{
_Unwind_Exception common;
/* ABI header, maximally aligned. */
_Unwind_Ptr id;
/* Id of the exception beeing propagated, filled by Propagate_Exception.
This is compared against the ttype entries associated with actions in the
examined context to see if one of these actions matches. */
int n_cleanups_to_trigger;
/* Number of cleanups on the propagation way for the occurrence. This is
initialized to 0 by Propagate_Exception and computed by the personality
routine during the first phase of the propagation (incremented for each
context in which only cleanup actions match).
This is used by Propagate_Exception when the occurrence is not handled,
to control a forced unwinding phase aimed at triggering all the cleanups
before calling Unhandled_Exception_Terminate.
This is also used by __gnat_eh_personality to identify the point at which
the notification routine shall be called for a handled occurrence. */
} _GNAT_Exception;
/* The two constants below are specific ttype identifiers for special
@ -846,21 +829,26 @@ get_call_site_action_for (_Unwind_Context *uw_context,
PROPAGATED_EXCEPTION is caught by the handling code controlled by CHOICE.
This takes care of the special Non_Ada_Error case on VMS. */
#define Is_Handled_By_Others __gnat_is_handled_by_others
#define Language_For __gnat_language_for
#define Import_Code_For __gnat_import_code_for
#define Is_Handled_By_Others __gnat_is_handled_by_others
#define Language_For __gnat_language_for
#define Import_Code_For __gnat_import_code_for
#define EID_For __gnat_eid_for
#define Adjust_N_Cleanups_For __gnat_adjust_n_cleanups_for
extern bool Is_Handled_By_Others (_Unwind_Ptr e);
extern char Language_For (_Unwind_Ptr e);
extern bool Is_Handled_By_Others (_Unwind_Ptr eid);
extern char Language_For (_Unwind_Ptr eid);
extern Exception_Code Import_Code_For (_Unwind_Ptr e);
extern Exception_Code Import_Code_For (_Unwind_Ptr eid);
extern Exception_Id EID_For (_GNAT_Exception * e);
extern void Adjust_N_Cleanups_For (_GNAT_Exception * e, int n);
static int
is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception)
{
/* Pointer to the GNAT exception data corresponding to the propagated
occurrence. */
_Unwind_Ptr E = propagated_exception->id;
_Unwind_Ptr E = (_Unwind_Ptr) EID_For (propagated_exception);
/* Base matching rules: An exception data (id) matches itself, "when
all_others" matches anything and "when others" matches anything unless
@ -1066,7 +1054,7 @@ __gnat_eh_personality (int uw_version,
{
if (action.kind == cleanup)
{
gnat_exception->n_cleanups_to_trigger ++;
Adjust_N_Cleanups_For (gnat_exception, 1);
return _URC_CONTINUE_UNWIND;
}
else
@ -1090,7 +1078,7 @@ __gnat_eh_personality (int uw_version,
Ada.Exceptions.Exception_Propagation to decide wether unwinding should
proceed further or Unhandled_Exception_Terminate should be called. */
if (action.kind == cleanup)
gnat_exception->n_cleanups_to_trigger --;
Adjust_N_Cleanups_For (gnat_exception, -1);
setup_to_install
(uw_context, uw_exception, action.landing_pad, action.ttype_filter);

6
gcc/ada/rtsfind.adb
View File

@ -1052,9 +1052,9 @@ package body Rtsfind is
function RTU_Loaded (U : RTU_Id) return Boolean is
begin
return True and Present (RT_Unit_Table (U).Entity);
-- Temp kludge, return True, deals with bug of loading unit with
-- WITH not being registered as a proper rtsfind load ???
return True or else Present (RT_Unit_Table (U).Entity);
-- Temporary kludge until we get proper interaction to ensure that
-- an explicit WITH of a unit is properly registered in rtsfind ???
end RTU_Loaded;
--------------------

73
gcc/ada/s-parame-mingw.adb Normal file
View File

@ -0,0 +1,73 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . P A R A M E T E R S --
-- --
-- B o d y --
-- --
-- Copyright (C) 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT 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 GNAT; 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. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the Windows (native) specific version
package body System.Parameters is
-------------------------
-- Adjust_Storage_Size --
-------------------------
function Adjust_Storage_Size (Size : Size_Type) return Size_Type is
begin
if Size = Unspecified_Size then
return Default_Stack_Size;
elsif Size < Minimum_Stack_Size then
return Minimum_Stack_Size;
else
return Size;
end if;
end Adjust_Storage_Size;
------------------------
-- Default_Stack_Size --
------------------------
function Default_Stack_Size return Size_Type is
begin
return 20 * 1024;
end Default_Stack_Size;
------------------------
-- Minimum_Stack_Size --
------------------------
function Minimum_Stack_Size return Size_Type is
begin
return 1024;
end Minimum_Stack_Size;
end System.Parameters;

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

@ -348,7 +348,7 @@ package System.Rident is
-- pragma Dispatching_Policy (FIFO_Within_Priorities);
-- pragma Locking_Policy (Ceiling_Locking);
-- pragma Detect_Blocking_Mode ???
-- pragma Detect_Blocking
Ravenscar =>

13
gcc/ada/s-taprop-mingw.adb
View File

@ -846,28 +846,17 @@ package body System.Task_Primitives.Operations is
hTask : HANDLE;
TaskId : aliased DWORD;
pTaskParameter : System.OS_Interface.PVOID;
dwStackSize : DWORD;
Result : DWORD;
Entry_Point : PTHREAD_START_ROUTINE;
begin
pTaskParameter := To_Address (T);
if Stack_Size = Unspecified_Size then
dwStackSize := DWORD (Default_Stack_Size);
elsif Stack_Size < Minimum_Stack_Size then
dwStackSize := DWORD (Minimum_Stack_Size);
else
dwStackSize := DWORD (Stack_Size);
end if;
Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
hTask := CreateThread
(null,
dwStackSize,
DWORD (Adjust_Storage_Size (Stack_Size)),
Entry_Point,
pTaskParameter,
DWORD (Create_Suspended),

5
gcc/ada/sem_attr.adb
View File

@ -3803,11 +3803,14 @@ package body Sem_Attr is
-- one attribute expression, and the check succeeds, we want to be able
-- to proceed securely assuming that an expression is in fact present.
-- Note: we set the attribute analyzed in this case to prevent any
-- attempt at reanalysis which could generate spurious error msgs.
exception
when Bad_Attribute =>
Set_Analyzed (N);
Set_Etype (N, Any_Type);
return;
end Analyze_Attribute;
--------------------

2
gcc/ada/sem_ch10.adb
View File

@ -1432,7 +1432,7 @@ package body Sem_Ch10 is
for J in reverse 1 .. Num_Scopes loop
U := Use_Clauses (J);
Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U;
Install_Use_Clauses (U);
Install_Use_Clauses (U, Force_Installation => True);
end loop;
end Re_Install_Use_Clauses;

10
gcc/ada/sem_ch13.adb
View File

@ -2092,7 +2092,6 @@ package body Sem_Ch13 is
-- tag to get an explicit position.
elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then
if Attribute_Name (Component_Name (CC)) = Name_Tag then
Error_Msg_N ("position of tag cannot be specified", CC);
else
@ -3422,10 +3421,7 @@ package body Sem_Ch13 is
-- Rep_Item_Too_Early --
------------------------
function Rep_Item_Too_Early
(T : Entity_Id;
N : Node_Id) return Boolean
is
function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is
begin
-- Cannot apply rep items that are not operational items
-- to generic types
@ -3646,6 +3642,10 @@ package body Sem_Ch13 is
-- CD1 and CD2 are either components or discriminants. This
-- function tests whether the two have the same representation
--------------
-- Same_Rep --
--------------
function Same_Rep return Boolean is
begin
if No (Component_Clause (CD1)) then

13
gcc/ada/sem_ch13.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- --
@ -46,8 +46,7 @@ package Sem_Ch13 is
function Minimum_Size
(T : Entity_Id;
Biased : Boolean := False)
return Nat;
Biased : Boolean := False) return Nat;
-- Given a primitive type, determines the minimum number of bits required
-- to represent all values of the type. This function may not be called
-- with any other types. If the flag Biased is set True, then the minimum
@ -96,10 +95,7 @@ package Sem_Ch13 is
-- definition clause that applies to type T. This procedure links
-- the node N onto the Rep_Item chain for the type T.
function Rep_Item_Too_Early
(T : Entity_Id;
N : Node_Id)
return Boolean;
function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean;
-- Called at the start of processing a representation clause or a
-- representation pragma. Used to check that the representation item
-- is not being applied to an incompleted type or to a generic formal
@ -110,8 +106,7 @@ package Sem_Ch13 is
function Rep_Item_Too_Late
(T : Entity_Id;
N : Node_Id;
FOnly : Boolean := False)
return Boolean;
FOnly : Boolean := False) return Boolean;
-- Called at the start of processing a representation clause or a
-- representation pragma. Used to check that a representation item
-- for entity T does not appear too late (according to the rules in

80
gcc/ada/sem_ch3.adb
View File

@ -762,7 +762,7 @@ package body Sem_Ch3 is
Formal : Entity_Id;
Desig_Type : constant Entity_Id :=
Create_Itype (E_Subprogram_Type, Parent (T_Def));
Create_Itype (E_Subprogram_Type, Parent (T_Def));
begin
if Nkind (T_Def) = N_Access_Function_Definition then
@ -5273,6 +5273,31 @@ package body Sem_Ch3 is
Next_Discriminant (Discrim);
end loop;
-- Check whether the constraints of the full view statically
-- match those imposed by the parent subtype [7.3(13)].
if Present (Stored_Constraint (Derived_Type)) then
declare
C1, C2 : Elmt_Id;
begin
C1 := First_Elmt (Discs);
C2 := First_Elmt (Stored_Constraint (Derived_Type));
while Present (C1) and then Present (C2) loop
if not
Fully_Conformant_Expressions (Node (C1), Node (C2))
then
Error_Msg_N (
"not conformant with previous declaration",
Node (C1));
end if;
Next_Elmt (C1);
Next_Elmt (C2);
end loop;
end;
end if;
end if;
-- STEP 2b: No new discriminants, inherit discriminants if any
@ -5280,8 +5305,9 @@ package body Sem_Ch3 is
else
if Private_Extension then
Set_Has_Unknown_Discriminants
(Derived_Type, Has_Unknown_Discriminants (Parent_Type)
or else Unknown_Discriminants_Present (N));
(Derived_Type,
Has_Unknown_Discriminants (Parent_Type)
or else Unknown_Discriminants_Present (N));
-- The partial view of the parent may have unknown discriminants,
-- but if the full view has discriminants and the parent type is
@ -8480,8 +8506,7 @@ package body Sem_Ch3 is
Is_Static : Boolean := True;
procedure Collect_Fixed_Components (Typ : Entity_Id);
-- Collect components of parent type that do not appear in a variant
-- part.
-- Collect parent type components that do not appear in a variant part
procedure Create_All_Components;
-- Iterate over Comp_List to create the components of the subtype.
@ -8679,8 +8704,8 @@ package body Sem_Ch3 is
-- If the tagged derivation has a type extension, collect all the
-- new components therein.
if Present (
Record_Extension_Part (Type_Definition (Parent (Typ))))
if Present
(Record_Extension_Part (Type_Definition (Parent (Typ))))
then
Old_C := First_Component (Typ);
@ -8894,9 +8919,6 @@ package body Sem_Ch3 is
is
Formal : Entity_Id;
New_Formal : Entity_Id;
Same_Subt : constant Boolean :=
Is_Scalar_Type (Parent_Type)
and then Subtypes_Statically_Compatible (Parent_Type, Derived_Type);
Visible_Subp : Entity_Id := Parent_Subp;
function Is_Private_Overriding return Boolean;
@ -8959,6 +8981,7 @@ package body Sem_Ch3 is
procedure Replace_Type (Id, New_Id : Entity_Id) is
Acc_Type : Entity_Id;
IR : Node_Id;
Par : constant Node_Id := Parent (Derived_Type);
begin
-- When the type is an anonymous access type, create a new access
@ -9001,7 +9024,7 @@ package body Sem_Ch3 is
Set_Etype (New_Id, Acc_Type);
Set_Scope (New_Id, New_Subp);
-- Create a reference to it.
-- Create a reference to it
IR := Make_Itype_Reference (Sloc (Parent (Derived_Type)));
Set_Itype (IR, Acc_Type);
@ -9011,14 +9034,14 @@ package body Sem_Ch3 is
Set_Etype (New_Id, Etype (Id));
end if;
end;
elsif Base_Type (Etype (Id)) = Base_Type (Parent_Type)
or else
(Ekind (Etype (Id)) = E_Record_Type_With_Private
and then Present (Full_View (Etype (Id)))
and then Base_Type (Full_View (Etype (Id))) =
Base_Type (Parent_Type))
and then
Base_Type (Full_View (Etype (Id))) = Base_Type (Parent_Type))
then
-- Constraint checks on formals are generated during expansion,
-- based on the signature of the original subprogram. The bounds
-- of the derived type are not relevant, and thus we can use
@ -9027,10 +9050,31 @@ package body Sem_Ch3 is
-- be used (a case statement, for example) and for those cases
-- we must use the derived type (first subtype), not its base.
if Etype (Id) = Parent_Type
and then Same_Subt
then
Set_Etype (New_Id, Derived_Type);
-- If the derived_type_definition has no constraints, we know that
-- the derived type has the same constraints as the first subtype
-- of the parent, and we can also use it rather than its base,
-- which can lead to more efficient code.
if Etype (Id) = Parent_Type then
if Is_Scalar_Type (Parent_Type)
and then
Subtypes_Statically_Compatible (Parent_Type, Derived_Type)
then
Set_Etype (New_Id, Derived_Type);
elsif Nkind (Par) = N_Full_Type_Declaration
and then
Nkind (Type_Definition (Par)) = N_Derived_Type_Definition
and then
Is_Entity_Name
(Subtype_Indication (Type_Definition (Par)))
then
Set_Etype (New_Id, Derived_Type);
else
Set_Etype (New_Id, Base_Type (Derived_Type));
end if;
else
Set_Etype (New_Id, Base_Type (Derived_Type));
end if;

14
gcc/ada/sem_ch8.adb
View File

@ -1800,6 +1800,12 @@ package body Sem_Ch8 is
if Form_Num > 2 then
Error_Msg_N ("too many formals for attribute", N);
-- Error if the attribute reference has expressions that look
-- like formal parameters.
elsif Present (Expressions (Nam)) then
Error_Msg_N ("illegal expressions in attribute reference", Nam);
elsif
Aname = Name_Compose or else
Aname = Name_Exponent or else
@ -4794,7 +4800,10 @@ package body Sem_Ch8 is
-- Install_Use_Clauses --
-------------------------
procedure Install_Use_Clauses (Clause : Node_Id) is
procedure Install_Use_Clauses
(Clause : Node_Id;
Force_Installation : Boolean := False)
is
U : Node_Id := Clause;
P : Node_Id;
Id : Entity_Id;
@ -4820,8 +4829,9 @@ package body Sem_Ch8 is
then
Set_Redundant_Use (P, True);
else
elsif Force_Installation or else Applicable_Use (P) then
Use_One_Package (Id, U);
end if;
end if;

16
gcc/ada/sem_ch8.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- --
@ -65,8 +65,8 @@ package Sem_Ch8 is
-- specifications, more specialized procedures are invoked.
procedure End_Use_Clauses (Clause : Node_Id);
-- Invoked on scope exit, to undo the effect of local use clauses. U is
-- the first Use clause of a scope being exited. This can be the current
-- Invoked on scope exit, to undo the effect of local use clauses. Clause
-- is the first use-clause of a scope being exited. This can be the current
-- scope, or some enclosing scopes when building a clean environment to
-- compile an instance body for inlining.
@ -108,11 +108,15 @@ package Sem_Ch8 is
-- Initializes data structures used for visibility analysis. Must be
-- called before analyzing each new main source program.
procedure Install_Use_Clauses (Clause : Node_Id);
-- applies the use clauses appearing in a given declarative part,
procedure Install_Use_Clauses
(Clause : Node_Id;
Force_Installation : Boolean := False);
-- Applies the use clauses appearing in a given declarative part,
-- when the corresponding scope has been placed back on the scope
-- stack after unstacking to compile a different context (subunit or
-- parent of generic body).
-- parent of generic body). Force_Installation is used when called from
-- Analyze_Subunit.Re_Install_Use_Clauses to insure that, after the
-- analysis of the subunit, the parent's environment is again identical.
function In_Open_Scopes (S : Entity_Id) return Boolean;
-- S is the entity of a scope. This function determines if this scope

32
gcc/ada/sem_dist.adb
View File

@ -291,7 +291,7 @@ package body Sem_Dist is
Remote_Subp_Decl : Node_Id;
RS_Pkg_Specif : Node_Id;
RS_Pkg_E : Entity_Id;
RAS_Type : Entity_Id;
RAS_Type : Entity_Id := New_Type;
Async_E : Entity_Id;
All_Calls_Remote_E : Entity_Id;
Attribute_Subp : Entity_Id;
@ -304,24 +304,14 @@ package body Sem_Dist is
if not Expander_Active then
return;
end if;
elsif Ekind (New_Type) = E_Record_Type then
RAS_Type := New_Type;
else
-- If the remote type has not been constructed yet, create
-- it and its attributes now.
Attribute_Subp := TSS (New_Type, TSS_RAS_Access);
if No (Attribute_Subp) then
Add_RAST_Features (Parent (New_Type));
end if;
RAS_Type := Equivalent_Type (New_Type);
if Ekind (RAS_Type) /= E_Record_Type then
RAS_Type := Equivalent_Type (RAS_Type);
end if;
Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access);
pragma Assert (Present (Attribute_Subp));
Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then
@ -457,9 +447,6 @@ package body Sem_Dist is
Loc : constant Source_Ptr := Sloc (Pref);
Call_Node : Node_Id;
New_Type : constant Entity_Id := Etype (Pref);
RAS : constant Entity_Id :=
Corresponding_Remote_Type (New_Type);
RAS_Decl : constant Node_Id := Parent (RAS);
Explicit_Deref : constant Node_Id := Parent (Pref);
Deref_Subp_Call : constant Node_Id := Parent (Explicit_Deref);
Deref_Proc : Entity_Id;
@ -491,16 +478,13 @@ package body Sem_Dist is
return;
end if;
Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
if not Expander_Active then
return;
elsif No (Deref_Proc) then
Add_RAST_Features (RAS_Decl);
Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
end if;
Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
pragma Assert (Present (Deref_Proc));
if Ekind (Deref_Proc) = E_Function then
Call_Node :=
Make_Function_Call (Loc,

2
gcc/ada/sem_eval.ads
View File

@ -100,7 +100,7 @@ package Sem_Eval is
-- When we are trying to perform compile time constant folding (for
-- instance for expressions such as 'C + 1', Is_Static_Expression or
-- Is_OK_Static_Expression are not the right functions to test to see
-- if folding is possible. Instead, we use Compile_Time_Know_Value.
-- if folding is possible. Instead, we use Compile_Time_Known_Value.
-- All static expressions that do not raise constraint error (i.e.
-- those for which Is_OK_Static_Expression is true) are known at
-- compile time, but as shown by the above example, there are cases

45
gcc/ada/sem_prag.adb
View File

@ -1652,6 +1652,27 @@ package body Sem_Prag is
K : Node_Kind;
Utyp : Entity_Id;
procedure Set_Atomic (E : Entity_Id);
-- Set given type as atomic, and if no explicit alignment was
-- given, set alignment to unknown, since back end knows what
-- the alignment requirements are for atomic arrays. Note that
-- this step is necessary for derived types.
----------------
-- Set_Atomic --
----------------
procedure Set_Atomic (E : Entity_Id) is
begin
Set_Is_Atomic (E);
if not Has_Alignment_Clause (E) then
Set_Alignment (E, Uint_0);
end if;
end Set_Atomic;
-- Start of processing for Process_Atomic_Shared_Volatile
begin
Check_Ada_83_Warning;
Check_No_Identifiers;
@ -1678,8 +1699,9 @@ package body Sem_Prag is
end if;
if Prag_Id /= Pragma_Volatile then
Set_Is_Atomic (E);
Set_Is_Atomic (Underlying_Type (E));
Set_Atomic (E);
Set_Atomic (Underlying_Type (E));
Set_Atomic (Base_Type (E));
end if;
-- Attribute belongs on the base type. If the
@ -3902,7 +3924,7 @@ package body Sem_Prag is
-- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
-- pragma Locking_Policy (Ceiling_Locking)
-- Set Detect_Blocking mode ???
-- Set Detect_Blocking mode
-- Set required restrictions (see System.Rident for detailed list)
@ -3948,7 +3970,9 @@ package body Sem_Prag is
end if;
end if;
-- ??? Detect_Blocking
-- pragma Detect_Blocking
Detect_Blocking := True;
-- Set the corresponding restrictions
@ -5239,6 +5263,18 @@ package body Sem_Prag is
end if;
end Debug;
---------------------
-- Detect_Blocking --
---------------------
-- pragma Detect_Blocking;
when Pragma_Detect_Blocking =>
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
Detect_Blocking := True;
-------------------
-- Discard_Names --
-------------------
@ -10188,6 +10224,7 @@ package body Sem_Prag is
Pragma_Convention => 0,
Pragma_Convention_Identifier => 0,
Pragma_Debug => -1,
Pragma_Detect_Blocking => -1,
Pragma_Discard_Names => 0,
Pragma_Elaborate => -1,
Pragma_Elaborate_All => -1,

2
gcc/ada/sinfo.ads
View File

@ -1383,7 +1383,7 @@ package Sinfo is
-- This is used to clarify output from the packed array cases.
-- Procedure_To_Call (Node4-Sem)
-- Present in N_Allocator. N_Free_Statement, and N_Return_Statement
-- Present in N_Allocator, N_Free_Statement, and N_Return_Statement
-- nodes. References the entity for the declaration of the procedure
-- to be called to accomplish the required operation (i.e. for the
-- Allocate procedure in the case of N_Allocator and N_Return_Statement

16
gcc/ada/sinput.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- --
@ -445,8 +445,7 @@ package Sinput is
-- represent the standard 1,9,17.. spacing pattern.
function Get_Logical_Line_Number
(P : Source_Ptr)
return Logical_Line_Number;
(P : Source_Ptr) return Logical_Line_Number;
-- The line number of the specified source position is obtained by
-- doing a binary search on the source positions in the lines table
-- for the unit containing the given source position. The returned
@ -457,8 +456,7 @@ package Sinput is
-- the same as the physical line number.
function Get_Physical_Line_Number
(P : Source_Ptr)
return Physical_Line_Number;
(P : Source_Ptr) return Physical_Line_Number;
-- The line number of the specified source position is obtained by
-- doing a binary search on the source positions in the lines table
-- for the unit containing the given source position. The returned
@ -478,9 +476,8 @@ package Sinput is
-- given source location.
function Line_Start
(L : Physical_Line_Number;
S : Source_File_Index)
return Source_Ptr;
(L : Physical_Line_Number;
S : Source_File_Index) return Source_Ptr;
-- Finds the source position of the start of the given line in the
-- given source file, using a physical line number to identify the line.
@ -525,8 +522,7 @@ package Sinput is
function Physical_To_Logical
(Line : Physical_Line_Number;
S : Source_File_Index)
return Logical_Line_Number;
S : Source_File_Index) return Logical_Line_Number;
-- Given a physical line number in source file whose source index is S,
-- return the corresponding logical line number. If the physical line
-- number is one containing a Source_Reference pragma, the result will

1
gcc/ada/snames.adb
View File

@ -171,6 +171,7 @@ package body Snames is
"compile_time_warning#" &
"component_alignment#" &
"convention_identifier#" &
"detect_blocking#" &
"discard_names#" &
"elaboration_checks#" &
"eliminate#" &

1054
gcc/ada/snames.ads
View File

File diff suppressed because it is too large Load Diff

275
gcc/ada/snames.h
View File

@ -203,149 +203,150 @@ extern unsigned char Get_Pragma_Id (int);
#define Pragma_Compile_Time_Warning 4
#define Pragma_Component_Alignment 5
#define Pragma_Convention_Identifier 6
#define Pragma_Discard_Names 7
#define Pragma_Elaboration_Checking 8
#define Pragma_Eliminate 9
#define Pragma_Explicit_Overriding 10
#define Pragma_Extend_System 11
#define Pragma_Extensions_Allowed 12
#define Pragma_External_Name_Casing 13
#define Pragma_Float_Representation 14
#define Pragma_Initialize_Scalars 15
#define Pragma_Interrupt_State 16
#define Pragma_License 17
#define Pragma_Locking_Policy 18
#define Pragma_Long_Float 19
#define Pragma_No_Run_Time 20
#define Pragma_No_Strict_Aliasing 21
#define Pragma_Normalize_Scalars 22
#define Pragma_Polling 23
#define Pragma_Persistent_Data 24
#define Pragma_Persistent_Object 25
#define Pragma_Profile 26
#define Pragma_Profile_Warnings 27
#define Pragma_Propagate_Exceptions 28
#define Pragma_Queuing_Policy 29
#define Pragma_Ravenscar 30
#define Pragma_Restricted_Run_Time 31
#define Pragma_Restrictions 32
#define Pragma_Restriction_Warnings 33
#define Pragma_Reviewable 34
#define Pragma_Source_File_Name 35
#define Pragma_Source_File_Name_Project 36
#define Pragma_Style_Checks 37
#define Pragma_Suppress 38
#define Pragma_Suppress_Exception_Locations 39
#define Pragma_Task_Dispatching_Policy 40
#define Pragma_Universal_Data 41
#define Pragma_Unsuppress 42
#define Pragma_Use_VADS_Size 43
#define Pragma_Validity_Checks 44
#define Pragma_Warnings 45
#define Pragma_Detect_Blocking 7
#define Pragma_Discard_Names 8
#define Pragma_Elaboration_Checking 9
#define Pragma_Eliminate 10
#define Pragma_Explicit_Overriding 11
#define Pragma_Extend_System 12
#define Pragma_Extensions_Allowed 13
#define Pragma_External_Name_Casing 14
#define Pragma_Float_Representation 15
#define Pragma_Initialize_Scalars 16
#define Pragma_Interrupt_State 17
#define Pragma_License 18
#define Pragma_Locking_Policy 19
#define Pragma_Long_Float 20
#define Pragma_No_Run_Time 21
#define Pragma_No_Strict_Aliasing 22
#define Pragma_Normalize_Scalars 23
#define Pragma_Polling 24
#define Pragma_Persistent_Data 25
#define Pragma_Persistent_Object 26
#define Pragma_Profile 27
#define Pragma_Profile_Warnings 28
#define Pragma_Propagate_Exceptions 29
#define Pragma_Queuing_Policy 30
#define Pragma_Ravenscar 31
#define Pragma_Restricted_Run_Time 32
#define Pragma_Restrictions 33
#define Pragma_Restriction_Warnings 34
#define Pragma_Reviewable 35
#define Pragma_Source_File_Name 36
#define Pragma_Source_File_Name_Project 37
#define Pragma_Style_Checks 38
#define Pragma_Suppress 39
#define Pragma_Suppress_Exception_Locations 40
#define Pragma_Task_Dispatching_Policy 41
#define Pragma_Universal_Data 42
#define Pragma_Unsuppress 43
#define Pragma_Use_VADS_Size 44
#define Pragma_Validity_Checks 45
#define Pragma_Warnings 46
/* Remaining pragmas */
#define Pragma_Abort_Defer 46
#define Pragma_All_Calls_Remote 47
#define Pragma_Annotate 48
#define Pragma_Assert 49
#define Pragma_Asynchronous 50
#define Pragma_Atomic 51
#define Pragma_Atomic_Components 52
#define Pragma_Attach_Handler 53
#define Pragma_Comment 54
#define Pragma_Common_Object 55
#define Pragma_Complex_Representation 56
#define Pragma_Controlled 57
#define Pragma_Convention 58
#define Pragma_CPP_Class 59
#define Pragma_CPP_Constructor 60
#define Pragma_CPP_Virtual 61
#define Pragma_CPP_Vtable 62
#define Pragma_Debug 63
#define Pragma_Elaborate 64
#define Pragma_Elaborate_All 65
#define Pragma_Elaborate_Body 66
#define Pragma_Export 67
#define Pragma_Export_Exception 68
#define Pragma_Export_Function 69
#define Pragma_Export_Object 70
#define Pragma_Export_Procedure 71
#define Pragma_Export_Value 72
#define Pragma_Export_Valued_Procedure 73
#define Pragma_External 74
#define Pragma_Finalize_Storage_Only 75
#define Pragma_Ident 76
#define Pragma_Import 77
#define Pragma_Import_Exception 78
#define Pragma_Import_Function 79
#define Pragma_Import_Object 80
#define Pragma_Import_Procedure 81
#define Pragma_Import_Valued_Procedure 82
#define Pragma_Inline 83
#define Pragma_Inline_Always 84
#define Pragma_Inline_Generic 85
#define Pragma_Inspection_Point 86
#define Pragma_Interface 87
#define Pragma_Interface_Name 88
#define Pragma_Interrupt_Handler 89
#define Pragma_Interrupt_Priority 90
#define Pragma_Java_Constructor 91
#define Pragma_Java_Interface 92
#define Pragma_Keep_Names 93
#define Pragma_Link_With 94
#define Pragma_Linker_Alias 95
#define Pragma_Linker_Options 96
#define Pragma_Linker_Section 97
#define Pragma_List 98
#define Pragma_Machine_Attribute 99
#define Pragma_Main 100
#define Pragma_Main_Storage 101
#define Pragma_Memory_Size 102
#define Pragma_No_Return 103
#define Pragma_Obsolescent 104
#define Pragma_Optimize 105
#define Pragma_Optional_Overriding 106
#define Pragma_Overriding 107
#define Pragma_Pack 108
#define Pragma_Page 109
#define Pragma_Passive 110
#define Pragma_Preelaborate 111
#define Pragma_Priority 112
#define Pragma_Psect_Object 113
#define Pragma_Pure 114
#define Pragma_Pure_Function 115
#define Pragma_Remote_Call_Interface 116
#define Pragma_Remote_Types 117
#define Pragma_Share_Generic 118
#define Pragma_Shared 119
#define Pragma_Shared_Passive 120
#define Pragma_Source_Reference 121
#define Pragma_Stream_Convert 122
#define Pragma_Subtitle 123
#define Pragma_Suppress_All 124
#define Pragma_Suppress_Debug_Info 125
#define Pragma_Suppress_Initialization 126
#define Pragma_System_Name 127
#define Pragma_Task_Info 128
#define Pragma_Task_Name 129
#define Pragma_Task_Storage 130
#define Pragma_Thread_Body 131
#define Pragma_Time_Slice 132
#define Pragma_Title 133
#define Pragma_Unchecked_Union 134
#define Pragma_Unimplemented_Unit 135
#define Pragma_Unreferenced 136
#define Pragma_Unreserve_All_Interrupts 137
#define Pragma_Volatile 138
#define Pragma_Volatile_Components 139
#define Pragma_Weak_External 140
#define Pragma_Abort_Defer 47
#define Pragma_All_Calls_Remote 48
#define Pragma_Annotate 49
#define Pragma_Assert 50
#define Pragma_Asynchronous 51
#define Pragma_Atomic 52
#define Pragma_Atomic_Components 53
#define Pragma_Attach_Handler 54
#define Pragma_Comment 55
#define Pragma_Common_Object 56
#define Pragma_Complex_Representation 57
#define Pragma_Controlled 58
#define Pragma_Convention 59
#define Pragma_CPP_Class 60
#define Pragma_CPP_Constructor 61
#define Pragma_CPP_Virtual 62
#define Pragma_CPP_Vtable 63
#define Pragma_Debug 64
#define Pragma_Elaborate 65
#define Pragma_Elaborate_All 66
#define Pragma_Elaborate_Body 67
#define Pragma_Export 68
#define Pragma_Export_Exception 69
#define Pragma_Export_Function 70
#define Pragma_Export_Object 71
#define Pragma_Export_Procedure 72
#define Pragma_Export_Value 73
#define Pragma_Export_Valued_Procedure 74
#define Pragma_External 75
#define Pragma_Finalize_Storage_Only 76
#define Pragma_Ident 77
#define Pragma_Import 78
#define Pragma_Import_Exception 79
#define Pragma_Import_Function 80
#define Pragma_Import_Object 81
#define Pragma_Import_Procedure 82
#define Pragma_Import_Valued_Procedure 83
#define Pragma_Inline 84
#define Pragma_Inline_Always 85
#define Pragma_Inline_Generic 86
#define Pragma_Inspection_Point 87
#define Pragma_Interface 88
#define Pragma_Interface_Name 89
#define Pragma_Interrupt_Handler 90
#define Pragma_Interrupt_Priority 91
#define Pragma_Java_Constructor 92
#define Pragma_Java_Interface 93
#define Pragma_Keep_Names 94
#define Pragma_Link_With 95
#define Pragma_Linker_Alias 96
#define Pragma_Linker_Options 97
#define Pragma_Linker_Section 98
#define Pragma_List 99
#define Pragma_Machine_Attribute 100
#define Pragma_Main 101
#define Pragma_Main_Storage 102
#define Pragma_Memory_Size 103
#define Pragma_No_Return 104
#define Pragma_Obsolescent 105
#define Pragma_Optimize 106
#define Pragma_Optional_Overriding 107
#define Pragma_Overriding 108
#define Pragma_Pack 109
#define Pragma_Page 110
#define Pragma_Passive 111
#define Pragma_Preelaborate 112
#define Pragma_Priority 113
#define Pragma_Psect_Object 114
#define Pragma_Pure 115
#define Pragma_Pure_Function 116
#define Pragma_Remote_Call_Interface 117
#define Pragma_Remote_Types 118
#define Pragma_Share_Generic 119
#define Pragma_Shared 120
#define Pragma_Shared_Passive 121
#define Pragma_Source_Reference 122
#define Pragma_Stream_Convert 123
#define Pragma_Subtitle 124
#define Pragma_Suppress_All 125
#define Pragma_Suppress_Debug_Info 126
#define Pragma_Suppress_Initialization 127
#define Pragma_System_Name 128
#define Pragma_Task_Info 129
#define Pragma_Task_Name 130
#define Pragma_Task_Storage 131
#define Pragma_Thread_Body 132
#define Pragma_Time_Slice 133
#define Pragma_Title 134
#define Pragma_Unchecked_Union 135
#define Pragma_Unimplemented_Unit 136
#define Pragma_Unreferenced 137
#define Pragma_Unreserve_All_Interrupts 138
#define Pragma_Volatile 139
#define Pragma_Volatile_Components 140
#define Pragma_Weak_External 141
/* The following are deliberately out of alphabetical order, see Snames */
#define Pragma_AST_Entry 141
#define Pragma_Storage_Size 142
#define Pragma_Storage_Unit 143
#define Pragma_AST_Entry 142
#define Pragma_Storage_Size 143
#define Pragma_Storage_Unit 144
/* Define the numeric values for the conventions. */

111
gcc/ada/stylesw.adb
View File

@ -34,23 +34,24 @@ package body Stylesw is
procedure Reset_Style_Check_Options is
begin
Style_Check_Indentation := 0;
Style_Check_Attribute_Casing := False;
Style_Check_Blanks_At_End := False;
Style_Check_Comments := False;
Style_Check_End_Labels := False;
Style_Check_Form_Feeds := False;
Style_Check_Horizontal_Tabs := False;
Style_Check_If_Then_Layout := False;
Style_Check_Keyword_Casing := False;
Style_Check_Layout := False;
Style_Check_Max_Line_Length := False;
Style_Check_Pragma_Casing := False;
Style_Check_References := False;
Style_Check_Specs := False;
Style_Check_Standard := False;
Style_Check_Subprogram_Order := False;
Style_Check_Tokens := False;
Style_Check_Indentation := 0;
Style_Check_Attribute_Casing := False;
Style_Check_Blanks_At_End := False;
Style_Check_Comments := False;
Style_Check_End_Labels := False;
Style_Check_Form_Feeds := False;
Style_Check_Horizontal_Tabs := False;
Style_Check_If_Then_Layout := False;
Style_Check_Keyword_Casing := False;
Style_Check_Layout := False;
Style_Check_Max_Line_Length := False;
Style_Check_Max_Nesting_Level := False;
Style_Check_Pragma_Casing := False;
Style_Check_References := False;
Style_Check_Specs := False;
Style_Check_Standard := False;
Style_Check_Subprogram_Order := False;
Style_Check_Tokens := False;
end Reset_Style_Check_Options;
------------------------------
@ -59,11 +60,17 @@ package body Stylesw is
procedure Save_Style_Check_Options (Options : out Style_Check_Options) is
P : Natural := 0;
J : Natural;
procedure Add (C : Character; S : Boolean);
-- Add given character C to string if switch S is true
procedure Add_Nat (N : Nat);
-- Add given natural number to string
---------
-- Add --
---------
procedure Add (C : Character; S : Boolean) is
begin
if S then
@ -72,6 +79,20 @@ package body Stylesw is
end if;
end Add;
-------------
-- Add_Nat --
-------------
procedure Add_Nat (N : Nat) is
begin
if N > 9 then
Add_Nat (N / 10);
end if;
P := P + 1;
Options (P) := Character'Val (Character'Pos ('0') + N mod 10);
end Add_Nat;
-- Start of processing for Save_Style_Check_Options
begin
@ -91,7 +112,6 @@ package body Stylesw is
Add ('i', Style_Check_If_Then_Layout);
Add ('k', Style_Check_Keyword_Casing);
Add ('l', Style_Check_Layout);
Add ('m', Style_Check_Max_Line_Length);
Add ('n', Style_Check_Standard);
Add ('o', Style_Check_Subprogram_Order);
Add ('p', Style_Check_Pragma_Casing);
@ -100,19 +120,23 @@ package body Stylesw is
Add ('t', Style_Check_Tokens);
if Style_Check_Max_Line_Length then
P := Options'Last;
J := Natural (Style_Max_Line_Length);
loop
Options (P) := Character'Val (J mod 10 + Character'Pos ('0'));
P := P - 1;
J := J / 10;
exit when J = 0;
end loop;
P := P + 1;
Options (P) := 'M';
Add_Nat (Style_Max_Line_Length);
end if;
if Style_Check_Max_Nesting_Level then
P := P + 1;
Options (P) := 'L';
Add_Nat (Style_Max_Nesting_Level);
end if;
pragma Assert (P <= Options'Last);
while P < Options'Last loop
P := P + 1;
Options (P) := ' ';
end loop;
end Save_Style_Check_Options;
-------------------------------------
@ -186,6 +210,35 @@ package body Stylesw is
when 'l' =>
Style_Check_Layout := True;
when 'L' =>
Style_Max_Nesting_Level := 0;
if J > Options'Last
or else Options (J) not in '0' .. '9'
then
OK := False;
Err_Col := J;
return;
end if;
loop
Style_Max_Nesting_Level :=
Style_Max_Nesting_Level * 10 +
Character'Pos (Options (J)) - Character'Pos ('0');
if Style_Max_Nesting_Level > 999 then
OK := False;
Err_Col := J;
return;
end if;
J := J + 1;
exit when J > Options'Last
or else Options (J) not in '0' .. '9';
end loop;
Style_Check_Max_Nesting_Level := Style_Max_Nesting_Level /= 0;
when 'm' =>
Style_Check_Max_Line_Length := True;
Style_Max_Line_Length := 79;

17
gcc/ada/stylesw.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- --
@ -140,6 +140,11 @@ package Stylesw is
-- If it is True, it activates checking for a maximum line length of
-- Style_Max_Line_Length characters.
Style_Check_Max_Nesting_Level : Boolean := False;
-- This can be set True by using -gnatyLnnn with a value other than
-- zero (a value of zero resets it to False). If True, it activates
-- checking the maximum nesting level against Style_Max_Nesting_Level.
Style_Check_Pragma_Casing : Boolean := False;
-- This can be set True by using the -gnatg or -gnatyp switches. If
-- it is True, then pragma names must use mixed case.
@ -218,7 +223,13 @@ package Stylesw is
Style_Max_Line_Length : Int := 0;
-- Value used to check maximum line length. Gets reset as a result of
-- use of -gnatym or -gnatyM switches (or by use of -gnatg).
-- use of -gnatym or -gnatyMnnn switches (or by use of -gnatg). This
-- value is only read if Style_Check_Max_Line_Length is True.
Style_Max_Nesting_Level : Int := 0;
-- Value used to check maximum nesting level. Gets reset as a result
-- of use of the -gnatyLnnn switch. This value is only read if
-- Style_Check_Max_Nesting_Level is True.
-----------------
-- Subprograms --
@ -250,7 +261,7 @@ package Stylesw is
procedure Reset_Style_Check_Options;
-- Sets all style check options to off
subtype Style_Check_Options is String (1 .. 32);
subtype Style_Check_Options is String (1 .. 64);
-- Long enough string to hold all options from Save call below
procedure Save_Style_Check_Options (Options : out Style_Check_Options);

5
gcc/ada/switch-c.adb
View File

@ -446,6 +446,11 @@ package body Switch.C is
return;
when 'z' =>
Store_Switch := False;
Disable_Switch_Storing;
Ptr := Ptr + 1;
-- All other -gnate? switches are unassigned
when others =>

17
gcc/ada/switch.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2002, 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- --
@ -32,15 +32,14 @@ package body Switch is
function Is_Front_End_Switch (Switch_Chars : String) return Boolean is
Ptr : constant Positive := Switch_Chars'First;
begin
return Is_Switch (Switch_Chars)
and then
(Switch_Chars (Ptr + 1) = 'I'
or else (Switch_Chars'Length >= 5
and then Switch_Chars (Ptr + 1 .. Ptr + 4) = "gnat")
or else (Switch_Chars'Length >= 5
and then Switch_Chars (Ptr + 1 .. Ptr + 4) = "fRTS"));
(Switch_Chars (Ptr + 1) = 'I'
or else (Switch_Chars'Length >= 5
and then Switch_Chars (Ptr + 1 .. Ptr + 4) = "gnat")
or else (Switch_Chars'Length >= 5
and then Switch_Chars (Ptr + 2 .. Ptr + 4) = "RTS"));
end Is_Front_End_Switch;
---------------
@ -90,8 +89,8 @@ package body Switch is
(Switch_Chars : String;
Max : Integer;
Ptr : in out Integer;
Result : out Pos) is
Result : out Pos)
is
Temp : Nat;
begin

7
gcc/ada/targparm.adb
View File

@ -374,6 +374,13 @@ package body Targparm is
Fatal := True;
Set_Standard_Output;
-- Test for pragma Detect_Blocking;
elsif System_Text (P .. P + 22) = "pragma Detect_Blocking;" then
P := P + 23;
Opt.Detect_Blocking := True;
goto Line_Loop_Continue;
-- Discard_Names
elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then

3
gcc/ada/targparm.ads
View File

@ -101,6 +101,9 @@ package Targparm is
-- If a pragma Polling (On) appears, then the flag Opt.Polling_Required
-- is set to True.
-- If a pragma Detect_Blocking appears, then the flag Opt.Detect_Blocking
-- is set to True.
-- if a pragma Suppress_Exception_Locations appears, then the flag
-- Opt.Exception_Locations_Suppressed is set to True.

65
gcc/ada/tracebak.c
View File

@ -60,17 +60,19 @@
extern int __gnat_backtrace (void **, int, void *, void *, int);
/* The point is to provide an implementation of the __gnat_bactrace function
above, called by the default implementation of the System.Traceback
package.
/* The point is to provide an implementation of the __gnat_backtrace function
above, called by the default implementation of the System.Traceback package.
We first have a series of target specific implementations, each included
from a separate C file for readability purposes.
Then comes a somewhat generic implementation based on a set of macro and
structure definitions which may be tailored on a per target basis. The
presence of a definition for one of these macros (PC_ADJUST) controls
wether or not the generic implementation is included.
Then come two flavors of a generic implementation: one relying on static
assumptions about the frame layout, and the other one using the GCC EH
infrastructure. The former uses a whole set of macros and structures which
may be tailored on a per target basis, and is activated as soon as
USE_GENERIC_UNWINDER is defined. The latter uses a small subset of the
macro definitions and is activated when USE_GCC_UNWINDER is defined. It is
only available post GCC 3.3.
Finally, there is a default dummy implementation, necessary to make the
linker happy on platforms where the feature is not supported, but where the
@ -192,6 +194,9 @@ extern void (*Unlock_Task) (void);
/*------------------------------ PPC AIX -------------------------------*/
#if defined (_AIX)
#define USE_GENERIC_UNWINDER
struct layout
{
struct layout *next;
@ -218,6 +223,9 @@ struct layout
/*---------------------------- PPC VxWorks------------------------------*/
#elif defined (_ARCH_PPC) && defined (__vxworks)
#define USE_GENERIC_UNWINDER
struct layout
{
struct layout *next;
@ -238,6 +246,8 @@ struct layout
#elif defined (sun) && defined (sparc)
#define USE_GENERIC_UNWINDER
/* These definitions are inspired from the Appendix D (Software
Considerations) of the SPARC V8 architecture manual. */
@ -267,6 +277,9 @@ struct layout
/*------------------------------- x86 ----------------------------------*/
#elif defined (i386)
#define USE_GENERIC_UNWINDER
struct layout
{
struct layout *next;
@ -310,13 +323,39 @@ extern unsigned int _image_base__;
|| ((*((ptr) - 1) & 0xff) == 0xff) \
|| (((*(ptr) & 0xd0ff) == 0xd0ff)))
/*------------------------------- mips-irix -------------------------------*/
#elif defined (__mips) && defined (__sgi)
#define USE_GCC_UNWINDER
#define PC_ADJUST -8
#endif
/*---------------------------------------*
*-- The generic implementation per se --*
*---------------------------------------*/
#if defined (PC_ADJUST)
/*---------------------------------------------------------------------*
*-- The post GCC 3.3 infrastructure based implementation --*
*---------------------------------------------------------------------*/
#if defined (USE_GCC_UNWINDER) && (__GNUC__ * 10 + __GNUC_MINOR__ > 33)
/* Conditioning the inclusion on the GCC version is useful to avoid bootstrap
path problems, since the included file refers to post 3.3 functions in
libgcc, and the stage1 compiler is unlikely to be linked against a post 3.3
library. It actually disables the support for backtraces in this compiler
for targets defining USE_GCC_UNWINDER, which is OK since we don't use the
traceback capablity in the compiler anyway.
The condition is expressed the way above because we cannot reliably rely on
any other macro from the base compiler when compiling stage1. */
#include "tb-gcc.c"
/*------------------------------------------------------------------*
*-- The generic implementation based on frame layout assumptions --*
*------------------------------------------------------------------*/
#elif defined (USE_GENERIC_UNWINDER)
#ifndef CURRENT_STACK_FRAME
# define CURRENT_STACK_FRAME ({ char __csf; &__csf; })
@ -398,7 +437,9 @@ __gnat_backtrace (void **array,
}
#else
/* No target specific implementation and PC_ADJUST not defined. */
/* No target specific implementation and neither USE_GCC_UNWINDER not
USE_GCC_UNWINDER defined. */
/*------------------------------*
*-- The dummy implementation --*

1
gcc/ada/usage.adb
View File

@ -436,6 +436,7 @@ begin
Write_Line (" i check if-then layout");
Write_Line (" k check casing rules for keywords");
Write_Line (" l check reference manual layout");
Write_Line (" Lnnn check max nest level < nnn");
Write_Line (" m check line length <= 79 characters");
Write_Line (" n check casing of package Standard identifiers");
Write_Line (" Mnnn check line length <= nnn characters");

128
gcc/ada/vms_data.ads
View File

@ -1505,6 +1505,15 @@ package VMS_Data is
-- HIGH A great number of messages are output, most of them not
-- being useful for the user.
S_GCC_Nesting : aliased constant S := "/MAX_NESTING=#" &
"-gnatyL#";
-- /MAX_NESTING=nnn
--
-- Set maximum level of nesting of constructs (including subprograms,
-- loops, blocks, packages, and conditionals).
-- The level of nesting must not exceed the given value nnn.
-- A value of zero disable this style check (not enabled by default).
S_GCC_Noadc : aliased constant S := "/NO_GNAT_ADC " &
"-gnatA";
-- /NO_GNAT_ADC
@ -2830,6 +2839,7 @@ package VMS_Data is
S_GCC_List 'Access,
S_GCC_Mapping 'Access,
S_GCC_Mess 'Access,
S_GCC_Nesting 'Access,
S_GCC_Noadc 'Access,
S_GCC_Noload 'Access,
S_GCC_Nostinc 'Access,
@ -3432,6 +3442,13 @@ package VMS_Data is
-- Example:
-- /EXTERNAL_REFERENCE="DEBUG=TRUE"
S_List_Files : aliased constant S := "/FILES=@" &
"-files=@";
-- /FILES=filename
--
-- Take as arguments the files that are listed in the specified
-- text file.
S_List_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
"DEFAULT " &
"-vP0 " &
@ -3522,6 +3539,7 @@ package VMS_Data is
S_List_Current 'Access,
S_List_Depend 'Access,
S_List_Ext 'Access,
S_List_Files 'Access,
S_List_Mess 'Access,
S_List_Nostinc 'Access,
S_List_Object 'Access,
@ -4042,6 +4060,15 @@ package VMS_Data is
S_Metric_Debug : aliased constant S := "/DEBUG_OUTPUT " &
"-dv";
-- /DEBUG_OUTPUT
--
-- Generate the debug information
S_Metric_Direct : aliased constant S := "/DIRECTORY=@" &
"-d=@";
-- /DIRECTORY=pathname
--
-- Put the files with detailed metric information into the specified
-- directory
S_Metric_Element : aliased constant S := "/ELEMENT_METRICS=" &
"ALL " &
@ -4064,6 +4091,24 @@ package VMS_Data is
"PROGRAM_NESTING_MAX " &
"-enu";
-- /ELEMENT_METRICS=(option, option ...)
--
-- Specifies the element metrics to be computed (if not set, all the
-- element metrics are set on, otherwise only specified metrics are
-- computed and reported)
--
-- option may be one of the following:
--
-- ALL (D) All the element metrics are computed
-- DECLARATION_TOTAL Compute the total number of declarations
-- STATEMENT_TOTAL Compute the total number of statements
-- LOOP_NESTING_MAX Compute the maximal loop nesting level
-- INT_SUBPROGRAMS Compute the number of interface subprograms
-- SUBPROGRAMS_ALL Compute the number of all the subprograms
-- INT_TYPES Compute the number of interface types
-- TYPES_ALL Compute the number of all the types
-- PROGRAM_NESTING_MAX Compute the maximal program unit nesting level
--
-- All combinations of element metrics options are allowed.
S_Metric_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
"-X" & '"';
@ -4075,6 +4120,13 @@ package VMS_Data is
-- Example:
-- /EXTERNAL_REFERENCE="DEBUG=TRUE"
S_Metric_Files : aliased constant S := "/FILES=@" &
"-files=@";
-- /FILES=filename
--
-- Take as arguments the files that are listed in the specified
-- text file.
S_Metric_Format : aliased constant S := "/FORMAT_OUTPUT=" &
"DEFAULT " &
"!-x,!-nt,!-sfn " &
@ -4085,10 +4137,22 @@ package VMS_Data is
"SHORT_SOURCE_FILE_NAME " &
"-sfn";
-- /FORMAT_OUTPUT=(option, option ...)
--
-- Specifies the details of the tool output
--
-- option may be one of the following:
--
-- DEFAULT (D) Generate the text output only, use full
-- argument source names in global information
-- XML Generate the output in XML format
-- NO_TEXT Do not generate the text output (implies XML)
-- SHORT_SOURCE_FILE_NAME Use short argument source names in output
S_Metric_Globout : aliased constant S := "/GLOBAL_OUTPUT=@" &
"-og@";
-- /GLOBAL_OUTPUT=filename
--
-- Put the textual global metric information into the specified file
S_Metric_Line : aliased constant S := "/LINE_METRICS=" &
"ALL " &
@ -4106,6 +4170,22 @@ package VMS_Data is
"-lb ";
-- /LINE_METRICS=(option, option ...)
-- Specifies the line metrics to be computed (if not set, all the line
-- metrics are set on, otherwise only specified metrics are computed and
-- reported)
--
-- option may be one of the following:
--
-- ALL (D) All the line metrics are computed
-- LINES_ALL All lines are computed
-- CODE_LINES Lines with Ada code are computed
-- COMENT_LINES All comment lines are computed
-- MIXED_CODE_COMMENTS All lines containing both code and comment are
-- computed
-- BLANK_LINES Blank lines are computed
--
-- All combinations of line metrics options are allowed.
S_Metric_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
"DEFAULT " &
"-vP0 " &
@ -4135,15 +4215,25 @@ package VMS_Data is
S_Metric_Quiet : aliased constant S := "/QUIET " &
"-q";
-- /QUIET
-- /NOQUIET (D)
-- /QUIET
--
-- Quiet mode: by default GNAT METRIC outputs to the standard error stream
-- the number of program units left to be processed. This option turns
-- this trace off.
S_Metric_Search : aliased constant S := "/SEARCH=*" &
"-I*";
-- /SEARCH=(directory[,...])
-- /SEARCH=(directory, ...)
--
-- When looking for source files also look in the specified directories.
S_Metric_Suffix : aliased constant S := "/SUFFIX_DETAILS=" & '"' &
"-o" & '"';
-- /SUFFIX_DETAILS=suffix
--
-- Use the given suffix as the suffix for the name of the file to place
-- the detailed metrics into.
S_Metric_Suppress : aliased constant S := "/SUPPRESS=" &
"NOTHING " &
@ -4160,21 +4250,43 @@ package VMS_Data is
"LOCAL_DETAILS " &
"-nolocal ";
-- /SUPPRESS=(option, option ...)
--
-- Specifies the metric that should not be computed
--
-- option may be one of the following:
--
-- NOTHING (D) Do not suppress computation of any metric
-- CYCLOMATIC_COMPLEXITY Do not compute the Cyclomatic Complexity
-- ESSENTIAL_COMPLEXITY Do not compute the Essential Complexity
-- MAXIMAL_LOOP_NESTING Do not compute the maximal loop nesting
-- EXITS_AS_GOTOS Do not count EXIT statements as GOTOs when
-- computing the Essential Complexity
-- LOCAL_DETAILS Do not compute the detailed metrics for local
-- program units
--
-- All combinations of options are allowed.
S_Metric_Verbose : aliased constant S := "/VERBOSE " &
"-v";
-- /VERBOSE
-- /NOVERBOSE (D)
-- /VERBOSE
--
-- Verbose mode.
S_Metric_XMLout : aliased constant S := "/XML_OUTPUT=@" &
"-ox@";
-- /XML_OUTPUT=filename
--
-- Place the XML output into the specified file
Metric_Switches : aliased constant Switches :=
(S_Metric_Config 'Access,
S_Metric_Current 'Access,
S_Metric_Debug 'Access,
S_Metric_Direct 'Access,
S_Metric_Element 'Access,
S_Metric_Ext 'Access,
S_Metric_Files 'Access,
S_Metric_Format 'Access,
S_Metric_Globout 'Access,
S_Metric_Line 'Access,
@ -4434,7 +4546,7 @@ package VMS_Data is
-- Set the comment layout. By default, comments use the GNAT style
-- comment line indentation.
--
-- layout-option is be one of the following:
-- layout-option may be one of the following:
--
-- UNTOUCHED           All the comments remain unchanged
-- DEFAULT (D) GNAT style comment line indentation
@ -4577,6 +4689,13 @@ package VMS_Data is
-- used in the default dictionary file, are defined in the GNAT User's
-- Guide.
S_Pretty_Files : aliased constant S := "/FILES=@" &
"-files=@";
-- /FILES=filename
--
-- Take as arguments the files that are listed in the specified
-- text file.
S_Pretty_Forced : aliased constant S := "/FORCED_OUTPUT=@" &
"-of@";
-- /FORCED_OUTPUT=file
@ -4799,6 +4918,7 @@ package VMS_Data is
S_Pretty_Ext 'Access,
S_Pretty_Current 'Access,
S_Pretty_Dico 'Access,
S_Pretty_Files 'Access,
S_Pretty_Forced 'Access,
S_Pretty_Formfeed 'Access,
S_Pretty_Indent 'Access,

4
gcc/ada/xtreeprs.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- --
@ -303,7 +303,7 @@ begin
loop
Sp := 79 - 4 - Length (Prefix);
exit when (Size (S) <= Sp);
exit when Size (S) <= Sp;
Match (S, Chop_SP, "");
Put_Line (OutS, Prefix & '"' & S1 & """ &");
Prefix := V (" ");