diff options
| author | Arnaud Charlet <charlet@gcc.gnu.org> | 2004-06-25 18:39:33 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2004-06-25 18:39:33 +0200 |
| commit | 0da2c8ac77a61f9149fcbf3da36f7656aff96a4c (patch) | |
| tree | 7773949d835bb70e525203ff86961e0f04f2c02c /gcc | |
| parent | 29357d8b9417cf74ce10fc868e4774d4c77d6889 (diff) | |
| download | gcc-0da2c8ac77a61f9149fcbf3da36f7656aff96a4c.zip gcc-0da2c8ac77a61f9149fcbf3da36f7656aff96a4c.tar.gz gcc-0da2c8ac77a61f9149fcbf3da36f7656aff96a4c.tar.bz2 | |
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
Diffstat (limited to 'gcc')
89 files changed, 4910 insertions, 3187 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e1464ed..38108d9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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. diff --git a/gcc/ada/Makefile.generic b/gcc/ada/Makefile.generic index 7ecd218..a758e52 100644 --- a/gcc/ada/Makefile.generic +++ b/gcc/ada/Makefile.generic @@ -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 diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 9754429..84d12a6 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -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 \ diff --git a/gcc/ada/a-exexpr.adb b/gcc/ada/a-exexpr.adb index 0d0eb09..41fb21d 100644 --- a/gcc/ada/a-exexpr.adb +++ b/gcc/ada/a-exexpr.adb @@ -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 diff --git a/gcc/ada/a-ngelfu.adb b/gcc/ada/a-ngelfu.adb index c7c526e..cddf9a8 100644 --- a/gcc/ada/a-ngelfu.adb +++ b/gcc/ada/a-ngelfu.adb @@ -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; diff --git a/gcc/ada/a-storio.adb b/gcc/ada/a-storio.adb index 689a22a..3a08392 100644 --- a/gcc/ada/a-storio.adb +++ b/gcc/ada/a-storio.adb @@ -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; diff --git a/gcc/ada/a-strmap.ads b/gcc/ada/a-strmap.ads index 31a966c..41cedea 100644 --- a/gcc/ada/a-strmap.ads +++ b/gcc/ada/a-strmap.ads @@ -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 diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 92573fd..bf6454e 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -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 diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 565cf53..b9c4004 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -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) - or else - Raises_Constraint_Error (Hi) - then - Uintp.Release (Umark); + if Size_Known_At_Compile_Time (Typ) then return; end if; - -- Otherwise get bounds values + -- No problem on 64-bit machines, we just don't bother with + -- the case where the size in bytes overflows 64-bits. - if Is_Static_Expression (Lo) then - Lob := Expr_Value (Lo); - else - Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp))); - Static := False; + if System_Address_Size = 64 then + return; end if; + 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; + -- Following code is temporarily deleted, since GCC 3 is returning + -- zero for size in bits of large dynamic arrays. ??? - Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0); - Next_Index (Indx); - end loop; +-- -- 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); - -- 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. + -- GCC 2 case (for now this is for GCC 3 dynamic case as well) - if Is_Subprogram (Scope (Ent)) then - Check_Siz := Uint_2 ** 27; - else - Check_Siz := Uint_2 ** 31; - end if; + 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) + then + Uintp.Release (Umark); + return; + 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 + -- Otherwise get bounds values - 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; + if Is_Static_Expression (Lo) then + Lob := Expr_Value (Lo); + else + Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp))); + Static := False; + 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 Is_Static_Expression (Hi) then + Hib := Expr_Value (Hi); + else + Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp))); + Static := False; + end if; - if Known_Esize (Ctyp) - and then Siz * Esize (Ctyp) < Check_Siz - then - Uintp.Release (Umark); - return; - end if; + Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0); + Next_Index (Indx); + end loop; - -- Here if a dynamic check is required + -- 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. - -- 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_Subprogram (Scope (Ent)) then + Check_Siz := Uint_2 ** 27; + else + Check_Siz := Uint_2 ** 31; + end if; - Uintp.Release (Umark); + -- 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 - Sizx := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ctyp, Loc), - Attribute_Name => Name_Size); + 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; - Indx := First_Index (Typ); + -- Case of component size known at compile time. If the array + -- size is definitely in range, then we do not need a check. - for J in 1 .. Number_Dimensions (Typ) loop - if Sloc (Etype (Indx)) = Sloc (N) then - Ensure_Defined (Etype (Indx), N); + 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_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; ---------------------------- diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 53f82d0..4a38950 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -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 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 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 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 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 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); + end if; - if Obj_Dir (Obj_Dir'Last) /= Dir_Separator then - Put (Dir_Separator); + 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); - end if; + if Is_Regular_File (Obj) then + Delete (Obj_Dir, Obj); + end if; - -- Assembly file + -- Assembly file - if Is_Regular_File (Asm) then - Delete (Obj_Dir, Asm); - end if; + if Is_Regular_File (Asm) then + Delete (Obj_Dir, Asm); + end if; - -- Tree file + -- Tree file - if Is_Regular_File (Adt) then - Delete (Obj_Dir, Adt); - end if; + if Is_Regular_File (Adt) then + Delete (Obj_Dir, Adt); + end if; - -- First expanded source file + -- First expanded source file - if Is_Regular_File (Deb) then - Delete (Obj_Dir, Deb); - end if; + if Is_Regular_File (Deb) then + Delete (Obj_Dir, Deb); + end if; - -- Repinfo file + -- Repinfo file - if Is_Regular_File (Rep) then - Delete (Obj_Dir, Rep); + 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; - -- Second expanded source file + -- Check if a global archive and it dependency file could have + -- been created and, if they exist, delete them. - 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 Project = Main_Project and then not Data.Library then + Global_Archive := False; - if Is_Regular_File (Rep) then - Delete (Obj_Dir, Rep); - end if; - end; - end if; - end if; - end; + for Proj in 1 .. Projects.Last loop + if Projects.Table (Proj).Other_Sources_Present then + Global_Archive := True; + exit; + end if; + end loop; + + if Global_Archive then + Clean_Archive (Project); end if; - end loop; + end if; + + if Data.Other_Sources_Present then + -- There is non-Ada code: delete the object files and + -- the dependency files, if they exist. - if Verbose_Mode then - New_Line; + 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 & diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 61f2018..3782c75 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -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 diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index df32596..b45279f 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 7327be8..ca5d69d 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 1eddfd3..1eab6ef 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index d59e0b9..e0d5f7c 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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))), - - 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)), - - Make_Exit_Statement (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => New_Reference_To (An, Loc), - Right_Opnd => Arr_Attr (A, Name_Last, N))), - - 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)))), - - 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 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; + + 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)))); + + -- If separate indexes, need a declare block to declare Bn + + 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))); + + -- 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; - 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. + Owner : Entity_Id := PtrT; + -- The entity whose finalisation list must be used to attach the + -- allocated object. + begin 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. + + 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)))); - Build_Final_List (N, Acc); - Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Acc)); - return Find_Final_List (Acc); + Build_Final_List (N, Owner); + Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner)); - else - return Find_Final_List (PtrT); + 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; ------------------------------- diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 951d272..1842996 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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 diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index 63026d9..e541758 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -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; diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 6b4ced7..dd8b095 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -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 diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index b86d353..364b4d7 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -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; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index e38bcce..e90c491 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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; diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb index fd3e92e..a688564 100644 --- a/gcc/ada/fname.adb +++ b/gcc/ada/fname.adb @@ -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; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index bb4b3f9..6e2d126 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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); + + 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 - if Bytes_Big_Endian 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); - end if; - - -- Case where field fits in one storage unit + -- Give warning if suspicious component clause - 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; + 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: + -- 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 + -- 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 + -- 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 + -- 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. + -- 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_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; + Set_Normalized_First_Bit + (Comp, + Component_Bit_Offset (Comp) mod + System_Storage_Unit); + end if; + end; + end if; + end; end if; Next_Entity (Comp); @@ -2543,27 +2564,43 @@ package body Freeze is Set_Has_Non_Standard_Rep (Base_Type (E)); Set_Is_Packed (Base_Type (E)); end if; - end; - Set_Component_Alignment_If_Not_Set (E); + 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 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); + 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. + -- 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; + 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; -- 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 diff --git a/gcc/ada/g-debpoo.ads b/gcc/ada/g-debpoo.ads index 0d458f4..1ac0e56 100644 --- a/gcc/ada/g-debpoo.ads +++ b/gcc/ada/g-debpoo.ads @@ -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; diff --git a/gcc/ada/g-os_lib.adb b/gcc/ada/g-os_lib.adb index 48963fb..a3d63d9 100644 --- a/gcc/ada/g-os_lib.adb +++ b/gcc/ada/g-os_lib.adb @@ -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 + -- Resolve directory names for VMS and Windows + + -- On VMS, if we have a Unix path 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. - if OpenVMS and then Path_Buffer (1) = '/' then + -- 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; diff --git a/gcc/ada/g-traceb.ads b/gcc/ada/g-traceb.ads index 761e480..c7ad394 100644 --- a/gcc/ada/g-traceb.ads +++ b/gcc/ada/g-traceb.ads @@ -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 diff --git a/gcc/ada/g-trasym.ads b/gcc/ada/g-trasym.ads index 3ff38b0..aa899d9 100644 --- a/gcc/ada/g-trasym.ads +++ b/gcc/ada/g-trasym.ads @@ -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 diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 17daf35..c3753d1 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -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 diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 2b5ff08..ff9358d 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -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} diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 0352d7c..3a0e5e4 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -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; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 41ef0a2..ef35b931 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -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 diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index 1e491f2..3035605 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -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; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 9d79b6c..9fe4aa1 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -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 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 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 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 diff --git a/gcc/ada/lang-specs.h b/gcc/ada/lang-specs.h index 1de5f4e..7b6aa52 100644 --- a/gcc/ada/lang-specs.h +++ b/gcc/ada/lang-specs.h @@ -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} \ diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index 722f563..e64db77 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -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; diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index f0f09ef..9ec0278 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -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. diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 7035854..0f3fc50 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -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 (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; + if Args (J).all /= "-gnatez" then - -- Do not display the -F=mapping_file switch for gnatbind, - -- if -dn is not specified. + -- Do not display the mapping file argument automatically + -- created when using a project file. - elsif Debug.Debug_Flag_N - or else Args (J)'Length < 4 - or else Args (J)(Args (J)'First .. Args (J)'First + 2) /= - "-F=" + 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 - Write_Str (" "); - Write_Str (Args (J).all); + -- 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 (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; + + -- 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; diff --git a/gcc/ada/makegpr.adb b/gcc/ada/makegpr.adb index 5947f19..d818ff2 100644 --- a/gcc/ada/makegpr.adb +++ b/gcc/ada/makegpr.adb @@ -66,15 +66,14 @@ package body Makegpr is -- sources and the C++ compiler is not g++. No_Argument : constant Argument_List := (1 .. 0 => null); + -- Null argument list representing case of no arguments FD : Process_Descriptor; -- The process descriptor used when invoking a non GNU compiler with -M -- and getting the output with GNAT.Expect. - Line_Matcher : constant Pattern_Matcher := - Compile ("^.*?\n", Single_Line); - -- The pattern when using GNAT.Expect for the invocation of a non GNU - -- compiler with -M. + Line_Matcher : constant Pattern_Matcher := Compile ("^.*?\n", Single_Line); + -- Pattern for GNAT.Expect for the invocation of a non GNU compiler with -M Name_Ide : Name_Id; Name_Compiler_Command : Name_Id; @@ -85,11 +84,11 @@ package body Makegpr is -- True when switch -u is used on the command line type Source_Index_Rec is record - Id : Other_Source_Id; - Found : Boolean := False; + Project : Project_Id; + Id : Other_Source_Id; + Found : Boolean := False; end record; - -- Used as component of Source_Indexes, to check if an archive need to - -- be rebuilt. + -- Used as Source_Indexes component to check if archive needs to be rebuilt type Source_Index_Array is array (Positive range <>) of Source_Index_Rec; type Source_Indexes_Ref is access Source_Index_Array; @@ -127,8 +126,7 @@ package body Makegpr is Copyright_Output : Boolean := False; Usage_Output : Boolean := False; - -- Flags to avoid multiple displays of the Copyright notice and of the - -- Usage. + -- Flags to avoid multiple displays of Copyright notice and of Usage Output_File_Name : String_Access := null; -- The name given after a switch -o @@ -156,8 +154,7 @@ package body Makegpr is Binder_String 'Access, Linker_String 'Access); Packages_To_Check : constant String_List_Access := List_Of_Packages'Access; - -- List of the packages to be checked when parsing/processing project - -- files. + -- List of the packages to be checked when parsing/processing project files Main_Project : Project_Id; -- The project id of the main project @@ -300,6 +297,8 @@ package body Makegpr is -- Used when Keep_Going is True (switch -k) to keep the total number -- of compilation/linking errors, to report at the end of execution. + Need_To_Rebuild_Global_Archive : Boolean := False; + Error_Header : constant String := "*** ERROR: "; -- The beginning of error message, when Keep_Going is True @@ -335,12 +334,13 @@ package body Makegpr is -- Current_Processor and Current_Language. procedure Add_Search_Directories - (Data : Project_Data; Language : Programming_Language); + (Data : Project_Data; + Language : Programming_Language); -- Either add to the Arguments the necessary -I switches needed to -- compile, or, when compiler is gcc/g++, set up the C*INCLUDE_PATH -- environment variable, if necessary. - procedure Add_Source_Id (Id : Other_Source_Id); + procedure Add_Source_Id (Project : Project_Id; Id : Other_Source_Id); -- Add a source id to Source_Indexes, with Found set to False procedure Add_Switches @@ -352,11 +352,21 @@ package body Makegpr is -- or language (attribute Default_Switches), coming from package Compiler -- or Linker (depending on Proc) of a specified project file. - procedure Build_Archive (Project : Project_Id; Unconditionally : Boolean); - -- Build the archive for a specified project. If Unconditionally is - -- False, first check if the archive is up to date, and build it only + procedure Build_Global_Archive; + -- Build the archive for the main project + + procedure Build_Library (Project : Project_Id; Unconditionally : Boolean); + -- Build the library for a library project. If Unconditionally is + -- False, first check if the library is up to date, and build it only -- if it is not. + procedure Check (Option : String); + -- Check that a switch coming from a project file is not the concatenation + -- of several valid switch, for example "-g -v". If it is, issue a warning. + + procedure Check_Archive_Builder; + -- Check if the archive builder (ar) is there + procedure Check_Compilation_Needed (Source : Other_Source; Need_To_Compile : out Boolean); @@ -370,6 +380,7 @@ package body Makegpr is (Source_Id : Other_Source_Id; Data : Project_Data; Local_Errors : in out Boolean); + -- Compile one non-Ada source procedure Compile_Individual_Sources; -- Compile the sources specified on the command line, when in @@ -390,7 +401,10 @@ package body Makegpr is procedure Create_Archive_Dependency_File (Name : String; First_Source : Other_Source_Id); - -- ??? needs comment + -- Create the archive dependency file for a library project + + procedure Create_Global_Archive_Dependency_File (Name : String); + -- Create the archive depenency file for the main project procedure Display_Command (Name : String; @@ -419,6 +433,12 @@ package body Makegpr is -- Do the necessary package initialization and process the command line -- arguments. + function Is_Included_In_Global_Archive + (Object_Name : Name_Id; + Project : Project_Id) return Boolean; + -- Return True if the object Object_Name is not overridden by a source + -- in a project extending project Project. + procedure Link_Executables; -- Link executables @@ -434,7 +454,7 @@ package body Makegpr is -- Process one command line argument function Strip_CR_LF (Text : String) return String; - -- Needs comment ??? + -- Remove characters ASCII.CR and ASCII.LF from a String procedure Usage; -- Display the usage @@ -462,6 +482,103 @@ package body Makegpr is Imported : Project_List; Prj : Project_Id; + procedure Add_Archive_Path; + -- For a library project or the main project, add the archive + -- path to the arguments. + + ---------------------- + -- Add_Archive_Path -- + ---------------------- + + procedure Add_Archive_Path is + Increment : Positive; + Prev_Last : Positive; + + begin + if Data.Library then + + -- If it is a library project file, nothing to do if + -- gnatmake will be invoked, because gnatmake will take + -- care of it, even if the library is not an Ada library. + + if not For_Gnatmake then + if Data.Library_Kind = Static then + Add_Argument + (Get_Name_String (Data.Library_Dir) & + Directory_Separator & + "lib" & Get_Name_String (Data.Library_Name) & + '.' & Archive_Ext, + Verbose_Mode); + + else + -- As we first insert in the reverse order, + -- -L<dir> is put after -l<lib> + + Add_Argument + ("-l" & Get_Name_String (Data.Library_Name), + Verbose_Mode); + + Get_Name_String (Data.Library_Dir); + + Add_Argument + ("-L" & Name_Buffer (1 .. Name_Len), + Verbose_Mode); + + -- If there is a run path option, prepend this + -- directory to the library path. It is probable + -- that the order of the directories in the path + -- option is not important, but just in case + -- put the directories in the same order as the + -- libraries. + + if Path_Option /= null then + + -- If it is not the first directory, make room + -- at the beginning of the table, including + -- for a path separator. + + if Lib_Path.Last > 0 then + Increment := Name_Len + 1; + Prev_Last := Lib_Path.Last; + Lib_Path.Set_Last (Prev_Last + Increment); + + for Index in reverse 1 .. Prev_Last loop + Lib_Path.Table (Index + Increment) := + Lib_Path.Table (Index); + end loop; + + Lib_Path.Table (Increment) := Path_Separator; + + else + -- If it is the first directory, just set + -- Last to the length of the directory. + + Lib_Path.Set_Last (Name_Len); + end if; + + -- Put the directory at the beginning of the + -- table. + + for Index in 1 .. Name_Len loop + Lib_Path.Table (Index) := Name_Buffer (Index); + end loop; + end if; + end if; + end if; + + -- For a non-library project, the only archive needed + -- is the one for the main project. + + elsif Project = Main_Project then + Add_Argument + (Get_Name_String (Data.Object_Directory) & + Directory_Separator & + "lib" & Get_Name_String (Data.Name) & + '.' & Archive_Ext, + Verbose_Mode); + end if; + end Add_Archive_Path; + begin -- Nothing to do when there is no project specified @@ -499,100 +616,17 @@ package body Makegpr is -- If there is sources of language other than Ada in this -- project, add the path of the archive to Arguments. - if Data.Sources_Present then - if Data.Library then - - -- If it is a library project file, nothing to do if - -- gnatmake will be invoked, because gnatmake will take - -- care of it, even if the library is not an Ada library. - - if not For_Gnatmake then - if Data.Library_Kind = Static then - Add_Argument - (Get_Name_String (Data.Library_Dir) & - Directory_Separator & - "lib" & Get_Name_String (Data.Library_Name) & - '.' & Archive_Ext, - Verbose_Mode); - - else - -- As we first insert in the reverse order, - -- -L<dir> is put after -l<lib> - - Add_Argument - ("-l" & Get_Name_String (Data.Library_Name), - Verbose_Mode); - - Get_Name_String (Data.Library_Dir); - - Add_Argument - ("-L" & Name_Buffer (1 .. Name_Len), - Verbose_Mode); - - -- If there is a run path option, prepend this - -- directory to the library path. It is probable - -- that the order of the directories in the path - -- option is not important, but just in case - -- put the directories in the same order as the - -- libraries. - - if Path_Option /= null then - -- If it is not the first directory, make room - -- at the beginning of the table, including - -- for a path separator. - - if Lib_Path.Last > 0 then - declare - Increment : constant Positive := - Name_Len + 1; - Prev_Last : constant Positive := - Lib_Path.Last; - - begin - Lib_Path.Set_Last (Prev_Last + Increment); - - for Index in reverse 1 .. Prev_Last loop - Lib_Path.Table (Index + Increment) := - Lib_Path.Table (Index); - end loop; - - Lib_Path.Table (Increment) := - Path_Separator; - end; - - else - -- If it is the first directory, just set - -- Last to the length of the directory. - - Lib_Path.Set_Last (Name_Len); - end if; - - -- Put the directory at the beginning of the - -- table. - - for Index in 1 .. Name_Len loop - Lib_Path.Table (Index) := Name_Buffer (Index); - end loop; - end if; - end if; - end if; - - else - -- For a non library project, just add the path name of - -- the archive. - - Add_Argument - (Get_Name_String (Data.Object_Directory) & - Directory_Separator & - "lib" & Get_Name_String (Data.Name) & - '.' & Archive_Ext, - Verbose_Mode); - end if; + if Project = Main_Project + or else Data.Other_Sources_Present + then + Add_Archive_Path; end if; end if; end if; end Recursive_Add_Archives; + -- Start of processing for Add_Archives + begin -- First, mark all projects as not processed @@ -723,11 +757,15 @@ package body Makegpr is if Last_Argument + Args'Length > Arguments'Last then declare New_Arguments : constant Argument_List_Access := - new Argument_List - (1 .. Last_Argument + Args'Length + Initial_Argument_Count); + new Argument_List + (1 .. Last_Argument + Args'Length + + Initial_Argument_Count); + New_Arguments_Displayed : constant Booleans := - new Boolean_Array - (1 .. Last_Argument + Args'Length + Initial_Argument_Count); + new Boolean_Array + (1 .. Last_Argument + + Args'Length + + Initial_Argument_Count); begin New_Arguments (1 .. Last_Argument) := @@ -790,7 +828,7 @@ package body Makegpr is -- Add_Source_Id -- ------------------- - procedure Add_Source_Id (Id : Other_Source_Id) is + procedure Add_Source_Id (Project : Project_Id; Id : Other_Source_Id) is begin -- Reallocate the array, if necessary @@ -808,7 +846,7 @@ package body Makegpr is end if; Last_Source := Last_Source + 1; - Source_Indexes (Last_Source) := (Id, False); + Source_Indexes (Last_Source) := (Project, Id, False); end Add_Source_Id; ---------------------------- @@ -902,12 +940,22 @@ package body Makegpr is if Switches /= Nil_Variable_Value then Element_Id := Switches.Values; - while Element_Id /= Nil_String loop Element := String_Elements.Table (Element_Id); if Element.Value /= No_Name then - Add_Argument (Get_Name_String (Element.Value), True); + Get_Name_String (Element.Value); + + if not Quiet_Output then + + -- When not in quiet output (no -q), check that the switch + -- is not the concatenation of several valid switches, + -- such as "-g -v". If it is, issue a warning. + + Check (Option => Name_Buffer (1 .. Name_Len)); + end if; + + Add_Argument (Name_Buffer (1 .. Name_Len), True); end if; Element_Id := Element.Next; @@ -915,12 +963,12 @@ package body Makegpr is end if; end Add_Switches; - ------------------- - -- Build_Archive -- - ------------------- + -------------------------- + -- Build_Global_Archive -- + -------------------------- - procedure Build_Archive (Project : Project_Id; Unconditionally : Boolean) is - Data : constant Project_Data := Projects.Table (Project); + procedure Build_Global_Archive is + Data : Project_Data := Projects.Table (Main_Project); Source_Id : Other_Source_Id; Source : Other_Source; Success : Boolean; @@ -933,36 +981,344 @@ package body Makegpr is "lib" & Get_Name_String (Data.Name) & ".deps"; -- The name of the archive dependency file for this project - Need_To_Rebuild : Boolean := Unconditionally; + Need_To_Rebuild : Boolean := Need_To_Rebuild_Global_Archive; -- When True, archive will be rebuilt File : Prj.Util.Text_File; - Object_Name : Name_Id; - Time_Stamp : Time_Stamp_Type; + Object_Path : Name_Id; + Time_Stamp : Time_Stamp_Type; Saved_Last_Argument : Natural; + First_Object : Natural; + + Discard : Boolean; begin - -- First, make sure that the archive builder (ar) is on the path + Check_Archive_Builder; - if Archive_Builder_Path = null then - Archive_Builder_Path := Locate_Exec_On_Path (Archive_Builder); + Change_Dir (Get_Name_String (Data.Object_Directory)); - if Archive_Builder_Path = null then - Osint.Fail - ("unable to locate archive builder """, - Archive_Builder, - """"); + if not Need_To_Rebuild then + if Verbose_Mode then + Write_Str (" Checking "); + Write_Line (Archive_Name); end if; - -- If there is an archive indexer (ranlib), try to locate it on the - -- path. Don't fail if it is not found. + -- If the archive does not exist, of course it needs to be built - if Archive_Indexer /= "" then - Archive_Indexer_Path := Locate_Exec_On_Path (Archive_Indexer); + if not Is_Regular_File (Archive_Name) then + Need_To_Rebuild := True; + + if Verbose_Mode then + Write_Line (" -> archive does not exist"); + end if; + + -- Archive does exist + + else + -- Check the archive dependency file + + Open (File, Archive_Dep_Name); + + -- If the archive dependency file does not exist, we need to + -- to rebuild the archive and to create its dependency file. + + if not Is_Valid (File) then + Need_To_Rebuild := True; + + if Verbose_Mode then + Write_Str (" -> archive dependency file "); + Write_Str (Archive_Dep_Name); + Write_Line (" does not exist"); + end if; + + else + -- Put all sources of language other than Ada in + -- Source_Indexes. + + for Proj in 1 .. Projects.Last loop + Data := Projects.Table (Proj); + + if not Data.Library then + Last_Source := 0; + Source_Id := Data.First_Other_Source; + + while Source_Id /= No_Other_Source loop + Add_Source_Id (Proj, Source_Id); + Source_Id := Other_Sources.Table (Source_Id).Next; + end loop; + end if; + end loop; + + -- Read the dependency file, line by line + + while not End_Of_File (File) loop + Get_Line (File, Name_Buffer, Name_Len); + + -- First line is the path of the object file + + Object_Path := Name_Find; + Source_Id := No_Other_Source; + + -- Check if this object file is for a source of this project + + for S in 1 .. Last_Source loop + Source_Id := Source_Indexes (S).Id; + Source := Other_Sources.Table (Source_Id); + + if (not Source_Indexes (S).Found) + and then Source.Object_Path = Object_Path + then + -- We have found the object file: get the source + -- data, and mark it as found. + + Source_Indexes (S).Found := True; + exit; + end if; + end loop; + + -- If it is not for a source of this project, then the + -- archive needs to be rebuilt. + + if Source_Id = No_Other_Source then + Need_To_Rebuild := True; + if Verbose_Mode then + Write_Str (" -> "); + Write_Str (Get_Name_String (Object_Path)); + Write_Line (" is not an object of any project"); + end if; + + exit; + end if; + + -- The second line is the time stamp of the object file. + -- If there is no next line, then the dependency file is + -- truncated, and the archive need to be rebuilt. + + if End_Of_File (File) then + Need_To_Rebuild := True; + + if Verbose_Mode then + Write_Str (" -> archive dependency file "); + Write_Line (" is truncated"); + end if; + + exit; + end if; + + Get_Line (File, Name_Buffer, Name_Len); + + -- If the line has the wrong number of characters, then + -- the dependency file is incorrectly formatted, and the + -- archive needs to be rebuilt. + + if Name_Len /= Time_Stamp_Length then + Need_To_Rebuild := True; + + if Verbose_Mode then + Write_Str (" -> archive dependency file "); + Write_Line (" is incorrectly formatted (time stamp)"); + end if; + + exit; + end if; + + Time_Stamp := Time_Stamp_Type (Name_Buffer (1 .. Name_Len)); + + -- If the time stamp in the dependency file is different + -- from the time stamp of the object file, then the archive + -- needs to be rebuilt. + + if Time_Stamp /= Source.Object_TS then + Need_To_Rebuild := True; + + if Verbose_Mode then + Write_Str (" -> time stamp of "); + Write_Str (Get_Name_String (Object_Path)); + Write_Str (" is incorrect in the archive"); + Write_Line (" dependency file"); + end if; + + exit; + end if; + end loop; + + Close (File); + end if; + end if; + end if; + + if not Need_To_Rebuild then + if Verbose_Mode then + Write_Line (" -> up to date"); + end if; + + -- Archive needs to be rebuilt + + else + -- If the archive is built, then linking will need to occur + -- unconditionally. + + Need_To_Relink := True; + + -- If archive already exists, first delete it + + -- Comment needed on why we discard result??? + + if Is_Regular_File (Archive_Name) then + Delete_File (Archive_Name, Discard); + end if; + + Last_Argument := 0; + + -- Start with the options found in MLib.Tgt (usually just "rc") + + Add_Arguments (Archive_Builder_Options.all, True); + + -- Followed by the archive name + + Add_Argument (Archive_Name, True); + + First_Object := Last_Argument; + + -- Followed by all the object files of the non library projects + + for Proj in 1 .. Projects.Last loop + Data := Projects.Table (Proj); + + if not Data.Library then + Source_Id := Data.First_Other_Source; + + while Source_Id /= No_Other_Source loop + Source := Other_Sources.Table (Source_Id); + + -- Only include object file name that have not been + -- overriden in extending projects. + + if Is_Included_In_Global_Archive + (Source.Object_Name, Proj) + then + Add_Argument + (Get_Name_String (Source.Object_Path), Verbose_Mode); + end if; + + Source_Id := Source.Next; + end loop; + end if; + end loop; + + -- Spawn the archive builder (ar) + + Saved_Last_Argument := Last_Argument; + + Last_Argument := First_Object + Max_In_Archives; + + loop + if Last_Argument > Saved_Last_Argument then + Last_Argument := Saved_Last_Argument; + end if; + + Display_Command (Archive_Builder, Archive_Builder_Path); + + Spawn + (Archive_Builder_Path.all, + Arguments (1 .. Last_Argument), + Success); + + exit when not Success; + + exit when Last_Argument = Saved_Last_Argument; + + Arguments (1) := r; + Arguments (3 .. Saved_Last_Argument - Last_Argument + 2) := + Arguments (Last_Argument + 1 .. Saved_Last_Argument); + Saved_Last_Argument := Saved_Last_Argument - Last_Argument + 2; + end loop; + + -- If the archive was built, run the archive indexer (ranlib) + -- if there is one. + + if Success then + + -- If the archive was built, run the archive indexer (ranlib), + -- if there is one. + + if Archive_Indexer_Path /= null then + Last_Argument := 0; + Add_Argument (Archive_Name, True); + + Display_Command (Archive_Indexer, Archive_Indexer_Path); + + Spawn (Archive_Indexer_Path.all, Arguments (1 .. 1), Success); + + if not Success then + + -- Running ranlib failed, delete the dependency file, + -- if it exists. + + if Is_Regular_File (Archive_Dep_Name) then + Delete_File (Archive_Dep_Name, Success); + end if; + + -- And report the error + + Report_Error + ("running" & Archive_Indexer & " for project """, + Get_Name_String (Data.Name), + """ failed"); + return; + end if; + end if; + + -- The archive was correctly built, create its dependency file + + Create_Global_Archive_Dependency_File (Archive_Dep_Name); + + -- Building the archive failed, delete dependency file if one exists + + else + if Is_Regular_File (Archive_Dep_Name) then + Delete_File (Archive_Dep_Name, Success); + end if; + + -- And report the error + + Report_Error + ("building archive for project """, + Get_Name_String (Data.Name), + """ failed"); end if; end if; + end Build_Global_Archive; + + ------------------- + -- Build_Library -- + ------------------- + + procedure Build_Library (Project : Project_Id; Unconditionally : Boolean) is + Data : constant Project_Data := Projects.Table (Project); + Source_Id : Other_Source_Id; + Source : Other_Source; + + 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 + + Need_To_Rebuild : Boolean := Unconditionally; + -- When True, archive will be rebuilt + + File : Prj.Util.Text_File; + + Object_Name : Name_Id; + Time_Stamp : Time_Stamp_Type; + + begin + Check_Archive_Builder; -- If Unconditionally is False, check if the archive need to be built @@ -1001,14 +1357,13 @@ package body Makegpr is end if; else - -- Put all sources of language other than Ada in - -- Source_Indexes. + -- Put all sources of language other than Ada in Source_Indexes Last_Source := 0; Source_Id := Data.First_Other_Source; while Source_Id /= No_Other_Source loop - Add_Source_Id (Source_Id); + Add_Source_Id (Project, Source_Id); Source_Id := Other_Sources.Table (Source_Id).Next; end loop; @@ -1045,6 +1400,7 @@ package body Makegpr is if Source_Id = No_Other_Source then Need_To_Rebuild := True; + if Verbose_Mode then Write_Str (" -> "); Write_Str (Get_Name_String (Object_Name)); @@ -1139,22 +1495,17 @@ package body Makegpr is end if; end if; - -- Build the archive if necessary + -- Build the library if necessary if Need_To_Rebuild then - -- If an archive is built, then linking will need to occur + -- If a library is built, then linking will need to occur -- unconditionally. Need_To_Relink := True; Last_Argument := 0; - -- If it is a library project file, we need to build the library - -- in the library directory. - - if Data.Library then - -- If there are sources in Ada, then gnatmake will build the -- library, so nothing to do. @@ -1192,9 +1543,7 @@ package body Makegpr is Lib_Dir => Get_Name_String (Data.Library_Dir), Symbol_Data => No_Symbols, Driver_Name => No_Name, - Lib_Address => "", Lib_Version => "", - Relocatable => Data.Library_Kind = Relocatable, Auto_Init => False); end if; end if; @@ -1212,109 +1561,88 @@ package body Makegpr is Create_Archive_Dependency_File (Archive_Dep_Name, Data.First_Other_Source); - return; - end if; - - -- Start with the options found in MLib.Tgt (usually just "rc") - - Add_Arguments (Archive_Builder_Options.all, True); - - -- Followed by the archive name - - Add_Argument (Archive_Name, True); - - -- Followed by all the object files of the project - - Source_Id := Data.First_Other_Source; - - while Source_Id /= No_Other_Source loop - Source := Other_Sources.Table (Source_Id); - Add_Argument (Get_Name_String (Source.Object_Name), Verbose_Mode); - Source_Id := Source.Next; - end loop; - - -- Spawn the archive builder (ar) - - Saved_Last_Argument := Last_Argument; - - Last_Argument := Max_In_Archives; - - loop - if Last_Argument > Saved_Last_Argument then - Last_Argument := Saved_Last_Argument; - end if; - - Display_Command (Archive_Builder, Archive_Builder_Path); - - Spawn - (Archive_Builder_Path.all, - Arguments (1 .. Last_Argument), - Success); - - exit when not Success; - - exit when Last_Argument = Saved_Last_Argument; - - Arguments (1) := r; - Arguments (3 .. Saved_Last_Argument - Last_Argument + 2) := - Arguments (Last_Argument + 1 .. Saved_Last_Argument); - Saved_Last_Argument := Saved_Last_Argument - Last_Argument + 2; - end loop; + end if; + end Build_Library; - if Success then + ----------- + -- Check -- + ----------- - -- If the archive was built, run the archive indexer (ranlib), - -- if there is one. + procedure Check (Option : String) is + First : Positive := Option'First; + Last : Natural; - if Archive_Indexer_Path /= null then - Last_Argument := 0; - Add_Argument (Archive_Name, True); + begin + for Index in Option'First + 1 .. Option'Last - 1 loop + if Option (Index) = ' ' and then Option (Index + 1) = '-' then + Write_Str ("warning: switch """); + Write_Str (Option); + Write_Str (""" is suspicious; consider using "); + + Last := First; + while Last <= Option'Last loop + if Option (Last) = ' ' then + if First /= Option'First then + Write_Str (", "); + end if; - Display_Command (Archive_Indexer, Archive_Indexer_Path); + Write_Char ('"'); + Write_Str (Option (First .. Last - 1)); + Write_Char ('"'); - Spawn (Archive_Indexer_Path.all, Arguments (1 .. 1), Success); + while Last <= Option'Last and then Option (Last) = ' ' loop + Last := Last + 1; + end loop; - if not Success then + First := Last; - -- Running ranlib failed, delete the dependency file, - -- if it exists. + else + if Last = Option'Last then + if First /= Option'First then + Write_Str (", "); + end if; - if Is_Regular_File (Archive_Dep_Name) then - Delete_File (Archive_Dep_Name, Success); + Write_Char ('"'); + Write_Str (Option (First .. Last)); + Write_Char ('"'); end if; - -- And report the error - - Report_Error - ("running" & Archive_Indexer & " for project """, - Get_Name_String (Data.Name), - """ failed"); - return; + Last := Last + 1; end if; - end if; + end loop; - -- The archive was correctly built, create its dependency file + Write_Line (" instead"); + exit; + end if; + end loop; + end Check; - Create_Archive_Dependency_File - (Archive_Dep_Name, Data.First_Other_Source); + --------------------------- + -- Check_Archive_Builder -- + --------------------------- - else - -- Building the archive failed, delete the dependency file, if - -- one exists. + procedure Check_Archive_Builder is + begin + -- First, make sure that the archive builder (ar) is on the path - if Is_Regular_File (Archive_Dep_Name) then - Delete_File (Archive_Dep_Name, Success); - end if; + if Archive_Builder_Path = null then + Archive_Builder_Path := Locate_Exec_On_Path (Archive_Builder); - -- And report the error + if Archive_Builder_Path = null then + Osint.Fail + ("unable to locate archive builder """, + Archive_Builder, + """"); + end if; - Report_Error - ("building archive for project """, - Get_Name_String (Data.Name), - """ failed"); + -- If there is an archive indexer (ranlib), try to locate it on the + -- path. Don't fail if it is not found. + + if Archive_Indexer /= "" then + Archive_Indexer_Path := Locate_Exec_On_Path (Archive_Indexer); end if; end if; - end Build_Archive; + end Check_Archive_Builder; ------------------------------ -- Check_Compilation_Needed -- @@ -1330,8 +1658,7 @@ package body Makegpr is Dep_Name : constant String := Get_Name_String (Source.Dep_Name); Source_In_Dependencies : Boolean := False; - -- Set to True if the source was find in the dependency file of its - -- object file. + -- Set True if source was found in dependency file of its object file Dep_File : Prj.Util.Text_File; Start : Natural; @@ -1349,8 +1676,7 @@ package body Makegpr is Write_Line (" ... "); end if; - -- If the object file does not exist, of course the source need to be - -- compiled. + -- If object file does not exist, of course source need to be compiled if Source.Object_TS = Empty_Time_Stamp then if Verbose_Mode then @@ -1432,8 +1758,7 @@ package body Makegpr is end loop; -- If dependency file contains only empty lines or comments, then - -- the dependencies are unknown, and the source needs to be - -- recompiled. + -- dependencies are unknown, and the source needs to be recompiled. if End_Of_File_Reached then if Verbose_Mode then @@ -1450,8 +1775,7 @@ package body Makegpr is Start := 1; Finish := Index (Name_Buffer (1 .. Name_Len), ": "); - -- The first line must start with the name of the object file, followed - -- by a colon (:). + -- First line must start with name of object file, followed by colon if Finish = 0 or else Name_Buffer (1 .. Finish - 1) /= Object_Name then if Verbose_Mode then @@ -1470,7 +1794,7 @@ package body Makegpr is Line_Loop : loop declare - Line : constant String := Name_Buffer (1 .. Name_Len); + Line : constant String := Name_Buffer (1 .. Name_Len); Last : constant Natural := Name_Len; begin @@ -1631,13 +1955,13 @@ package body Makegpr is CPATH : String_Access := null; begin - -- If the compiler is not know yet, get its path name + -- If the compiler is not known yet, get its path name if Compiler_Names (Source.Language) = null then Get_Compiler (Source.Language); end if; - -- For non GCC compilers, get the dependency file, calling first the + -- For non GCC compilers, get the dependency file, first calling the -- compiler with the switch -M. if not Compiler_Is_Gcc (Source.Language) then @@ -1663,8 +1987,7 @@ package body Makegpr is Add_Argument (Options (Source.Language).Table (J), True); end loop; - -- Finally, add the imported directory switches for this - -- project file. + -- Finally, add imported directory switches for this project file Add_Search_Directories (Data, Source.Language); @@ -1800,9 +2123,7 @@ package body Makegpr is -- Add the compiling switches for the language specified -- on the command line, if any. - for - J in 1 .. Comp_Opts.Last (Options (Source.Language)) - loop + for J in 1 .. Comp_Opts.Last (Options (Source.Language)) loop Add_Argument (Options (Source.Language).Table (J), True); end loop; @@ -1830,10 +2151,11 @@ package body Makegpr is Arguments (1 .. Last_Argument), Success); + -- Case of successful compilation + if Success then - -- Compilation was successful, update the time stamp - -- of the object file. + -- Update the time stamp of the object file Source.Object_TS := File_Stamp (Source.Object_Name); @@ -1859,6 +2181,8 @@ package body Makegpr is Other_Sources.Table (Source_Id) := Source; end if; + -- Compilation failed + else Local_Errors := True; Report_Error @@ -1884,9 +2208,7 @@ package body Makegpr is begin Ada_Mains.Init; - To_Mixed (Project_Name); - Compile_Only := True; Get_Imported_Directories (Main_Project, Data); @@ -1896,7 +2218,7 @@ package body Makegpr is Change_Dir (Get_Name_String (Data.Object_Directory)); - if not Data.Sources_Present then + if not Data.Other_Sources_Present then if Ada_Is_A_Language then Mains.Reset; @@ -1930,7 +2252,6 @@ package body Makegpr is if not Sources_Compiled.Get (Source_Name) then Sources_Compiled.Set (Source_Name, True); - Source_Id := Data.First_Other_Source; while Source_Id /= No_Other_Source loop @@ -1942,8 +2263,7 @@ package body Makegpr is if Source_Id = No_Other_Source then if Ada_Is_A_Language then Ada_Mains.Increment_Last; - Ada_Mains.Table (Ada_Mains.Last) := - new String'(Main); + Ada_Mains.Table (Ada_Mains.Last) := new String'(Main); else Report_Error @@ -1962,10 +2282,9 @@ package body Makegpr is if Ada_Mains.Last > 0 then - -- Invoke gnatmake for all sources that are not of a non Ada language + -- Invoke gnatmake for all Ada sources Last_Argument := 0; - Add_Argument (Dash_u, True); for Index in 1 .. Ada_Mains.Last loop @@ -2019,7 +2338,7 @@ package body Makegpr is Add_Argument (Output_File_Name, True); end if; - -- Transmit to gnatmake some switches + -- Transmit some switches to gnatmake -- -c @@ -2075,8 +2394,9 @@ package body Makegpr is end if; if not Compile_Only then - -- If there are linking options from the command line, transmit them - -- to gnatmake. + + -- If there are linking options from the command line, + -- transmit them to gnatmake. if Linker_Options.Last /= 0 then Add_Argument (Dash_largs, True); @@ -2133,7 +2453,7 @@ package body Makegpr is -- True when the archive needs to be built/rebuilt unconditionally begin - -- For each project file + -- Loop through project files for Project in 1 .. Projects.Last loop Local_Errors := False; @@ -2141,7 +2461,7 @@ package body Makegpr is -- Nothing to do when no sources of language other than Ada - if (not Data.Virtual) and then Data.Sources_Present then + if (not Data.Virtual) and then Data.Other_Sources_Present then -- If the imported directory switches are unknown, compute them @@ -2187,11 +2507,18 @@ package body Makegpr is Source_Id := Source.Next; end loop; + if Need_To_Rebuild_Archive and then (not Data.Library) then + Need_To_Rebuild_Global_Archive := True; + end if; + -- If there was no compilation error, build/rebuild the archive -- if necessary. - if not Local_Errors then - Build_Archive (Project, Need_To_Rebuild_Archive); + if not Local_Errors + and then Data.Library + and then not Data.Languages (Lang_Ada) + then + Build_Library (Project, Need_To_Rebuild_Archive); end if; end if; end loop; @@ -2229,7 +2556,10 @@ package body Makegpr is use Ada.Text_IO; begin - Create (Dep_File, Out_File, Name); + -- Create the file in Append mode, to avoid automatic insertion of + -- an end of line if file is empty. + + Create (Dep_File, Append_File, Name); while Source_Id /= No_Other_Source loop Source := Other_Sources.Table (Source_Id); @@ -2247,6 +2577,55 @@ package body Makegpr is end if; end Create_Archive_Dependency_File; + ------------------------------------------- + -- Create_Global_Archive_Dependency_File -- + ------------------------------------------- + + procedure Create_Global_Archive_Dependency_File (Name : String) is + Source_Id : Other_Source_Id; + Source : Other_Source; + Dep_File : Ada.Text_IO.File_Type; + + use Ada.Text_IO; + + begin + -- Create the file in Append mode, to avoid automatic insertion of + -- an end of line if file is empty. + + Create (Dep_File, Append_File, Name); + + -- Get all the object files of non-Ada sources in non-library projects + + for Project in 1 .. Projects.Last loop + if not Projects.Table (Project).Library then + Source_Id := Projects.Table (Project).First_Other_Source; + + while Source_Id /= No_Other_Source loop + Source := Other_Sources.Table (Source_Id); + + -- Put only those object files that are in the global archive + + if Is_Included_In_Global_Archive + (Source.Object_Name, Project) + then + Put_Line (Dep_File, Get_Name_String (Source.Object_Path)); + Put_Line (Dep_File, String (Source.Object_TS)); + end if; + + Source_Id := Source.Next; + end loop; + end if; + end loop; + + Close (Dep_File); + + exception + when others => + if Is_Open (Dep_File) then + Close (Dep_File); + end if; + end Create_Global_Archive_Dependency_File; + --------------------- -- Display_Command -- --------------------- @@ -2261,6 +2640,7 @@ package body Makegpr is -- not in Quiet Output (no -q). if Verbose_Mode or (not Quiet_Output) then + -- In Verbose Mode output the full path of the spawned process if Verbose_Mode then @@ -2391,9 +2771,9 @@ package body Makegpr is Element_Id : String_List_Id := Source_Dirs; Element : String_Element; Add_Arg : Boolean := True; + begin - -- Add each source directory path name, preceded by "-I" to - -- Arguments. + -- Add each source directory path name, preceded by "-I" to Arguments while Element_Id /= Nil_String loop Element := String_Elements.Table (Element_Id); @@ -2476,6 +2856,8 @@ package body Makegpr is end if; end Recursive_Get_Dirs; + -- Start of processing for Get_Imported_Directories + begin -- First, mark all project as not processed @@ -2538,8 +2920,7 @@ package body Makegpr is Write_Eol; end if; - -- Parse and process the project files for other languages - -- (not for Ada). + -- Parse and process project files for other languages (not for Ada) Prj.Pars.Parse (Project => Main_Project, @@ -2570,14 +2951,14 @@ package body Makegpr is if Mains.Number_Of_Mains = 0 then Osint.Fail ("No source specified to compile in 'unique compile' mode"); - else Compile_Individual_Sources; Report_Total_Errors ("compilation"); end if; else - -- First compile sources and build archives, if necessary + -- First compile sources and build archives for library project, + -- if necessary. Compile_Sources; @@ -2590,6 +2971,7 @@ package body Makegpr is -- If -c was not specified, link the executables, if there are any. if not Compile_Only then + Build_Global_Archive; Check_For_C_Plus_Plus; Link_Executables; end if; @@ -2655,6 +3037,34 @@ package body Makegpr is Osint.Add_Default_Search_Dirs; end Initialize; + ----------------------------------- + -- Is_Included_In_Global_Archive -- + ----------------------------------- + + function Is_Included_In_Global_Archive + (Object_Name : Name_Id; + Project : Project_Id) return Boolean + is + Data : Project_Data := Projects.Table (Project); + Source : Other_Source_Id; + + begin + while Data.Extended_By /= No_Project loop + Data := Projects.Table (Data.Extended_By); + Source := Data.First_Other_Source; + + while Source /= No_Other_Source loop + if Other_Sources.Table (Source).Object_Name = Object_Name then + return False; + else + Source := Other_Sources.Table (Source).Next; + end if; + end loop; + end loop; + + return True; + end Is_Included_In_Global_Archive; + ---------------------- -- Link_Executables -- ---------------------- @@ -2684,9 +3094,19 @@ package body Makegpr is procedure Add_C_Plus_Plus_Link_For_Gnatmake; -- Add the --LINK= switch for gnatlink, depending on the C++ compiler + procedure Check_Time_Stamps (Exec_Time_Stamp : Time_Stamp_Type); + -- Check if there is an archive that is more recent than the executable + -- to decide if we need to relink. + procedure Choose_C_Plus_Plus_Link_Process; -- If the C++ compiler is not g++, create the correct script to link + procedure Link_Foreign + (Main : String; + Main_Id : Name_Id; + Source : Other_Source); + -- Link a non-Ada main, when there is no Ada code + --------------------------------------- -- Add_C_Plus_Plus_Link_For_Gnatmake -- --------------------------------------- @@ -2707,6 +3127,61 @@ package body Makegpr is end if; end Add_C_Plus_Plus_Link_For_Gnatmake; + ----------------------- + -- Check_Time_Stamps -- + ----------------------- + + procedure Check_Time_Stamps (Exec_Time_Stamp : Time_Stamp_Type) is + Prj_Data : Project_Data; + + begin + for Prj in 1 .. Projects.Last loop + Prj_Data := Projects.Table (Prj); + + -- There is an archive only in project + -- files with sources other than Ada + -- sources. + + if Data.Other_Sources_Present then + declare + Archive_Path : constant String := + Get_Name_String + (Prj_Data.Object_Directory) & + Directory_Separator & + "lib" & + Get_Name_String (Prj_Data.Name) & + '.' & Archive_Ext; + Archive_TS : Time_Stamp_Type; + begin + Name_Len := 0; + Add_Str_To_Name_Buffer + (Archive_Path); + Archive_TS := File_Stamp (Name_Find); + + -- If the archive is later than the + -- executable, we need to relink. + + if Archive_TS /= Empty_Time_Stamp + and then + Exec_Time_Stamp < Archive_TS + then + Need_To_Relink := True; + + if Verbose_Mode then + Write_Str (" -> "); + Write_Str (Archive_Path); + Write_Str (" has time stamp "); + Write_Str ("later than "); + Write_Line ("executable"); + end if; + + exit; + end if; + end; + end if; + end loop; + end Check_Time_Stamps; + ------------------------------------- -- Choose_C_Plus_Plus_Link_Process -- ------------------------------------- @@ -2747,6 +3222,159 @@ package body Makegpr is end if; end Choose_C_Plus_Plus_Link_Process; + ------------------ + -- Link_Foreign -- + ------------------ + + procedure Link_Foreign + (Main : String; + Main_Id : Name_Id; + Source : Other_Source) + is + Executable_Name : constant String := + Get_Name_String + (Executable_Of + (Project => Main_Project, + Main => Main_Id, + Index => 0, + Ada_Main => False)); + -- File name of the executable + + Executable_Path : constant String := + Get_Name_String + (Data.Exec_Directory) & + Directory_Separator & + Executable_Name; + -- Path name of the executable + + Exec_Time_Stamp : Time_Stamp_Type; + + begin + -- Now, check if the executable is up to date. It is considered + -- up to date if its time stamp is not earlier that the time stamp + -- of any archive. Only do that if we don't know if we need to link. + + if not Need_To_Relink then + + -- Get the time stamp of the executable + + Name_Len := 0; + Add_Str_To_Name_Buffer (Executable_Path); + Exec_Time_Stamp := File_Stamp (Name_Find); + + if Verbose_Mode then + Write_Str (" Checking executable "); + Write_Line (Executable_Name); + end if; + + -- If executable does not exist, we need to link + + if Exec_Time_Stamp = Empty_Time_Stamp then + Need_To_Relink := True; + + if Verbose_Mode then + Write_Line (" -> not found"); + end if; + + -- Otherwise, get the time stamps of each archive. If one of + -- them is found later than the executable, we need to relink. + + else + Check_Time_Stamps (Exec_Time_Stamp); + end if; + + -- If Need_To_Relink is False, we are done + + if Verbose_Mode and (not Need_To_Relink) then + Write_Line (" -> up to date"); + end if; + end if; + + -- Prepare to link + + if Need_To_Relink then + Link_Done := True; + + Last_Argument := 0; + + -- Specify the executable path name + + Add_Argument (Dash_o, True); + Add_Argument + (Get_Name_String (Data.Exec_Directory) & + Directory_Separator & + Get_Name_String + (Executable_Of + (Project => Main_Project, + Main => Main_Id, + Index => 0, + Ada_Main => False)), + True); + + -- Specify the object file of the main source + + Add_Argument + (Object_Dir & Directory_Separator & + Get_Name_String (Source.Object_Name), + True); + + -- Add the switches specified in package Linker of + -- the main project. + + Add_Switches + (Data => Data, + Proc => Linker, + Language => Source.Language, + File_Name => Main_Id); + + -- Add the switches specified in attribute + -- Linker_Options of packages Linker. + + if Link_Options_Switches = null then + Link_Options_Switches := + new Argument_List' + (Linker_Options_Switches (Main_Project)); + end if; + + Add_Arguments (Link_Options_Switches.all, True); + + -- Add the linking options specified on the + -- command line. + + for Arg in 1 .. Linker_Options.Last loop + Add_Argument (Linker_Options.Table (Arg), True); + end loop; + + -- Add all the archives, in a correct order + + Add_Archives (For_Gnatmake => False); + + -- If there are shared libraries and the run path + -- option is supported, add the run path switch. + + if Lib_Path.Last > 0 then + Add_Argument + (Path_Option.all & + String (Lib_Path.Table (1 .. Lib_Path.Last)), + Verbose_Mode); + end if; + + -- And invoke the linker + + Display_Command (Linker_Name.all, Linker_Path); + Spawn + (Linker_Path.all, + Arguments (1 .. Last_Argument), + Success); + + if not Success then + Report_Error ("could not link ", Main); + end if; + end if; + end Link_Foreign; + + -- Start of processing of Link_Executables + begin -- If no mains specified, get mains from attribute Main, if it exists @@ -2769,6 +3397,7 @@ package body Makegpr is end if; if Mains.Number_Of_Mains = 0 then + -- If the attribute Main is an empty list or not specified, -- there is nothing to do. @@ -2786,10 +3415,12 @@ package body Makegpr is -- Check how we are going to do the link - if not Data.Sources_Present then + if not Data.Other_Sources_Present then + -- Only Ada sources in the main project, and even maybe not if not Data.Languages (Lang_Ada) then + -- Fail if the main project has no source of any language Osint.Fail @@ -2802,8 +3433,7 @@ package body Makegpr is Last_Argument := 0; - -- Choose the correct linker if there is C++ code in other - -- projects. + -- Choose correct linker if there is C++ code in other projects if C_Plus_Plus_Is_Used then Choose_C_Plus_Plus_Link_Process; @@ -2820,10 +3450,11 @@ package body Makegpr is -- sources in Ada. if Data.Languages (Lang_Ada) then + -- There is a mix of Ada and other language sources in the main -- project. Any main that is not a source of the other languages -- will be deemed to be an Ada main. - -- + -- Find the mains of the other languages and the Ada mains. Mains.Reset; @@ -2834,8 +3465,9 @@ package body Makegpr is loop declare - Main : constant String := Mains.Next_Main; + Main : constant String := Mains.Next_Main; Main_Id : Name_Id; + begin exit when Main'Length = 0; @@ -2883,6 +3515,7 @@ package body Makegpr is for Main in 1 .. Other_Mains.Last loop declare Source : constant Other_Source := Other_Mains.Table (Main); + begin Last_Argument := 0; @@ -3007,200 +3640,7 @@ package body Makegpr is Get_Name_String (Data.Name)); else - declare - Executable_Name : constant String := - Get_Name_String - (Executable_Of - (Project => Main_Project, - Main => Main_Id, - Index => 0, - Ada_Main => False)); - -- File name of the executable - - Executable_Path : constant String := - Get_Name_String - (Data.Exec_Directory) & - Directory_Separator & - Executable_Name; - -- Path name of the executable - - Exec_Time_Stamp : Time_Stamp_Type; - - begin - -- Now, check if the executable is up to date. - -- It is considered up to date if its time stamp is - -- not earlier that the time stamp of any archive. - -- Only do that if we don't know if we need to link. - - if not Need_To_Relink then - - -- Get the time stamp of the executable - - Name_Len := 0; - Add_Str_To_Name_Buffer (Executable_Path); - Exec_Time_Stamp := File_Stamp (Name_Find); - - if Verbose_Mode then - Write_Str (" Checking executable "); - Write_Line (Executable_Name); - end if; - - -- If executable does not exist, we need to link - - if Exec_Time_Stamp = Empty_Time_Stamp then - Need_To_Relink := True; - - if Verbose_Mode then - Write_Line (" -> not found"); - end if; - - else - -- Otherwise, get the time stamps of each - -- archive. If one of them is found later than - -- the executable, we need to relink. - - declare - Prj_Data : Project_Data; - - begin - for Prj in 1 .. Projects.Last loop - Prj_Data := Projects.Table (Prj); - - -- There is an archive only in project - -- files with sources other than Ada - -- sources. - - if Data.Sources_Present then - declare - Archive_Path : constant String := - Get_Name_String - (Prj_Data.Object_Directory) & - Directory_Separator & - "lib" & - Get_Name_String (Prj_Data.Name) & - '.' & Archive_Ext; - Archive_TS : Time_Stamp_Type; - begin - Name_Len := 0; - Add_Str_To_Name_Buffer - (Archive_Path); - Archive_TS := File_Stamp (Name_Find); - - -- If the archive is later than the - -- executable, we need to relink. - - if Archive_TS /= Empty_Time_Stamp - and then - Exec_Time_Stamp < Archive_TS - then - Need_To_Relink := True; - - if Verbose_Mode then - Write_Str (" -> "); - Write_Str (Archive_Path); - Write_Str (" has time stamp "); - Write_Str ("later than "); - Write_Line ("executable"); - end if; - - exit; - end if; - end; - end if; - end loop; - end; - end if; - - -- If Need_To_Relink is False, we are done - - if Verbose_Mode and (not Need_To_Relink) then - Write_Line (" -> up to date"); - end if; - - end if; - - -- Prepare to link - - if Need_To_Relink then - Link_Done := True; - - Last_Argument := 0; - - -- Specify the executable path name - - Add_Argument (Dash_o, True); - Add_Argument - (Get_Name_String (Data.Exec_Directory) & - Directory_Separator & - Get_Name_String - (Executable_Of - (Project => Main_Project, - Main => Main_Id, - Index => 0, - Ada_Main => False)), - True); - - -- Specify the object file of the main source - - Add_Argument - (Object_Dir & Directory_Separator & - Get_Name_String (Source.Object_Name), - True); - - -- Add the switches specified in package Linker of - -- the main project. - - Add_Switches - (Data => Data, - Proc => Linker, - Language => Source.Language, - File_Name => Main_Id); - - -- Add the switches specified in attribute - -- Linker_Options of packages Linker. - - if Link_Options_Switches = null then - Link_Options_Switches := - new Argument_List' - (Linker_Options_Switches (Main_Project)); - end if; - - Add_Arguments (Link_Options_Switches.all, True); - - -- Add the linking options specified on the - -- command line. - - for Arg in 1 .. Linker_Options.Last loop - Add_Argument (Linker_Options.Table (Arg), True); - end loop; - - -- Add all the archives, in a correct order - - Add_Archives (For_Gnatmake => False); - - -- If there are shared libraries and the run path - -- option is supported, add the run path switch. - - if Lib_Path.Last > 0 then - Add_Argument - (Path_Option.all & - String (Lib_Path.Table (1 .. Lib_Path.Last)), - Verbose_Mode); - end if; - - -- And invoke the linker - - Display_Command (Linker_Name.all, Linker_Path); - Spawn - (Linker_Path.all, - Arguments (1 .. Last_Argument), - Success); - - if not Success then - Report_Error ("could not link ", Main); - end if; - end if; - end; + Link_Foreign (Main, Main_Id, Source); end if; end; end loop; @@ -3211,13 +3651,14 @@ package body Makegpr is Osint.Write_Program_Name; if Mains.Number_Of_Mains = 1 then + -- If there is only one executable, report its name too Write_Str (": """); Mains.Reset; declare - Main : constant String := Mains.Next_Main; + Main : constant String := Mains.Next_Main; Main_Id : Name_Id; begin Name_Len := 0; @@ -3251,8 +3692,7 @@ package body Makegpr is S3 : String := "") is begin - -- If Keep_Going is True, output the error message, preceded by the - -- error header. + -- If Keep_Going is True, output error message preceded by error header if Keep_Going then Total_Number_Of_Errors := Total_Number_Of_Errors + 1; @@ -3262,9 +3702,9 @@ package body Makegpr is Write_Str (S3); Write_Eol; - else - -- Otherwise, just fail + -- Otherwise just fail + else Osint.Fail (S1, S2, S3); end if; end Report_Error; @@ -3300,8 +3740,8 @@ package body Makegpr is return; end if; - -- If preceding switch was -P, a project file name need to be specified, - -- not a switch. + -- If preceding switch was -P, a project file name need to be + -- specified, not a switch. if Project_File_Name_Expected then if Arg (1) = '-' then @@ -3311,8 +3751,8 @@ package body Makegpr is Project_File_Name := new String'(Arg); end if; - -- If preceding switch was -o, an executable name need to be specidied, - -- not a switch. + -- If preceding switch was -o, an executable name need to be + -- specified, not a switch. elsif Output_File_Name_Expected then if Arg (1) = '-' then @@ -3326,10 +3766,9 @@ package body Makegpr is -- -c???args: Compiler arguments - elsif Arg'Length >= 6 and then - Arg (Arg'First .. Arg'First + 1) = "-c" and then - Arg (Arg'Last - 3 .. Arg'Last) = "args" - + elsif Arg'Length >= 6 + and then Arg (Arg'First .. Arg'First + 1) = "-c" + and then Arg (Arg'Last - 3 .. Arg'Last) = "args" then declare OK : Boolean := False; @@ -3347,7 +3786,6 @@ package body Makegpr is if OK then Current_Processor := Compiler; - else Osint.Fail ("illegal option """, Arg, """"); end if; @@ -3417,6 +3855,7 @@ package body Makegpr is elsif Arg = "-v" then Verbose_Mode := True; + Copyright; elsif Arg'Length = 4 and then Arg (1 .. 3) = "-vP" and then Arg (4) in '0' .. '2' @@ -3435,8 +3874,7 @@ package body Makegpr is elsif Arg'Length >= 3 and then Arg (2) = 'X' and then Is_External_Assignment (Arg) then - -- Is_External_Assignment has side effects - -- when it returns True; + -- Is_External_Assignment has side effects when it returns True null; @@ -3456,8 +3894,7 @@ package body Makegpr is ----------------- function Strip_CR_LF (Text : String) return String is - - To : String (1 .. Text'Length); + To : String (1 .. Text'Length); Index_To : Natural := 0; begin diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 97dee95..8cce3e8 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -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 => diff --git a/gcc/ada/mlib-tgt-aix.adb b/gcc/ada/mlib-tgt-aix.adb index c95d648..033ca6a 100644 --- a/gcc/ada/mlib-tgt-aix.adb +++ b/gcc/ada/mlib-tgt-aix.adb @@ -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 -- ------------- diff --git a/gcc/ada/mlib-tgt-hpux.adb b/gcc/ada/mlib-tgt-hpux.adb index 4eb2934..f295b38 100644 --- a/gcc/ada/mlib-tgt-hpux.adb +++ b/gcc/ada/mlib-tgt-hpux.adb @@ -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 -- ------------- diff --git a/gcc/ada/mlib-tgt-irix.adb b/gcc/ada/mlib-tgt-irix.adb index c188199..2f09a14 100644 --- a/gcc/ada/mlib-tgt-irix.adb +++ b/gcc/ada/mlib-tgt-irix.adb @@ -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 -- ------------- diff --git a/gcc/ada/mlib-tgt-linux.adb b/gcc/ada/mlib-tgt-linux.adb index 00ab392..7901f63 100644 --- a/gcc/ada/mlib-tgt-linux.adb +++ b/gcc/ada/mlib-tgt-linux.adb @@ -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 -- ------------- diff --git a/gcc/ada/mlib-tgt-mingw.adb b/gcc/ada/mlib-tgt-mingw.adb index a47ff42..79aeab5 100644 --- a/gcc/ada/mlib-tgt-mingw.adb +++ b/gcc/ada/mlib-tgt-mingw.adb @@ -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 -- ------------- diff --git a/gcc/ada/mlib-tgt-solaris.adb b/gcc/ada/mlib-tgt-solaris.adb index ac5e4b9..d409285 100644 --- a/gcc/ada/mlib-tgt-solaris.adb +++ b/gcc/ada/mlib-tgt-solaris.adb @@ -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 -- ------------- diff --git a/gcc/ada/mlib-tgt-tru64.adb b/gcc/ada/mlib-tgt-tru64.adb index 2474da3..13417e8 100644 --- a/gcc/ada/mlib-tgt-tru64.adb +++ b/gcc/ada/mlib-tgt-tru64.adb @@ -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 -- ------------- diff --git a/gcc/ada/mlib-tgt-vms-alpha.adb b/gcc/ada/mlib-tgt-vms-alpha.adb index b3b7172..285f2bd 100644 --- a/gcc/ada/mlib-tgt-vms-alpha.adb +++ b/gcc/ada/mlib-tgt-vms-alpha.adb @@ -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 -- ------------- diff --git a/gcc/ada/mlib-tgt-vms-ia64.adb b/gcc/ada/mlib-tgt-vms-ia64.adb index 5ce66cc..e279a51 100644 --- a/gcc/ada/mlib-tgt-vms-ia64.adb +++ b/gcc/ada/mlib-tgt-vms-ia64.adb @@ -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 -- ------------- diff --git a/gcc/ada/mlib-tgt-vxworks.adb b/gcc/ada/mlib-tgt-vxworks.adb index 9fa24c5..6eaa882 100644 --- a/gcc/ada/mlib-tgt-vxworks.adb +++ b/gcc/ada/mlib-tgt-vxworks.adb @@ -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 -- ------------- diff --git a/gcc/ada/mlib-tgt.adb b/gcc/ada/mlib-tgt.adb index dc13773..c18dec8 100644 --- a/gcc/ada/mlib-tgt.adb +++ b/gcc/ada/mlib-tgt.adb @@ -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 -- ------------- diff --git a/gcc/ada/mlib-tgt.ads b/gcc/ada/mlib-tgt.ads index 5d142ae..971325f 100644 --- a/gcc/ada/mlib-tgt.ads +++ b/gcc/ada/mlib-tgt.ads @@ -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. -- diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 0bd4336..0e9f7c4 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -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 diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 112170b..c07c39b 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -928,6 +928,7 @@ begin Pragma_Component_Alignment | Pragma_Controlled | Pragma_Convention | + Pragma_Detect_Blocking | Pragma_Discard_Names | Pragma_Eliminate | Pragma_Elaborate | diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index 508877c..19d9130 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -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; diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index b8e3fc7..a736641 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -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; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index c87b7e3..6ae4755 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -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 diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 8c89aae..aaf45ac 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -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 diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 9d034a1..7cc17fd 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -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; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 5552343..747e7f8 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -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, diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 0edac39..d742bbf 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -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; diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c index 2d7c61a..77f3937 100644 --- a/gcc/ada/raise.c +++ b/gcc/ada/raise.c @@ -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 eid); +extern char Language_For (_Unwind_Ptr eid); -extern bool Is_Handled_By_Others (_Unwind_Ptr e); -extern char Language_For (_Unwind_Ptr e); +extern Exception_Code Import_Code_For (_Unwind_Ptr eid); -extern Exception_Code Import_Code_For (_Unwind_Ptr e); +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); diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 720ad25..b36ee59 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -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; -------------------- diff --git a/gcc/ada/s-parame-mingw.adb b/gcc/ada/s-parame-mingw.adb new file mode 100644 index 0000000..d77ebdb --- /dev/null +++ b/gcc/ada/s-parame-mingw.adb @@ -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; diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index f0fbc49..409adc6 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -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 => diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index 7d7299f..049a63d 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -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), diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index f7aa92b..4e04afc 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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; -------------------- diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 31ddc65..b8f3001 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -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; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 69e324b..2030b30 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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 diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 3abdffb..cc573ef 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index ea0991f..a85d8c5 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 78aceb6..ea64e37 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -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; diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads index bdd3d53..3c6eacf 100644 --- a/gcc/ada/sem_ch8.ads +++ b/gcc/ada/sem_ch8.ads @@ -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 diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index c483610..aee306d 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -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, diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 404ba58..0945a4d 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0d8c1e1..e4689a6 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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, diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 04853f2..84f22c5 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -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 diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index fb085cd..90f388d 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -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 diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index 272801b..2e2aeb5 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -171,6 +171,7 @@ package body Snames is "compile_time_warning#" & "component_alignment#" & "convention_identifier#" & + "detect_blocking#" & "discard_names#" & "elaboration_checks#" & "eliminate#" & diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index 153ea27..bcd5793 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -323,52 +323,53 @@ package Snames is Name_Compile_Time_Warning : constant Name_Id := N + 111; -- GNAT Name_Component_Alignment : constant Name_Id := N + 112; -- GNAT Name_Convention_Identifier : constant Name_Id := N + 113; -- GNAT - Name_Discard_Names : constant Name_Id := N + 114; - Name_Elaboration_Checks : constant Name_Id := N + 115; -- GNAT - Name_Eliminate : constant Name_Id := N + 116; -- GNAT - Name_Explicit_Overriding : constant Name_Id := N + 117; - Name_Extend_System : constant Name_Id := N + 118; -- GNAT - Name_Extensions_Allowed : constant Name_Id := N + 119; -- GNAT - Name_External_Name_Casing : constant Name_Id := N + 120; -- GNAT - Name_Float_Representation : constant Name_Id := N + 121; -- GNAT - Name_Initialize_Scalars : constant Name_Id := N + 122; -- GNAT - Name_Interrupt_State : constant Name_Id := N + 123; -- GNAT - Name_License : constant Name_Id := N + 124; -- GNAT - Name_Locking_Policy : constant Name_Id := N + 125; - Name_Long_Float : constant Name_Id := N + 126; -- VMS - Name_No_Run_Time : constant Name_Id := N + 127; -- GNAT - Name_No_Strict_Aliasing : constant Name_Id := N + 128; -- GNAT - Name_Normalize_Scalars : constant Name_Id := N + 129; - Name_Polling : constant Name_Id := N + 130; -- GNAT - Name_Persistent_Data : constant Name_Id := N + 131; -- GNAT - Name_Persistent_Object : constant Name_Id := N + 132; -- GNAT - Name_Profile : constant Name_Id := N + 133; -- Ada05 - Name_Profile_Warnings : constant Name_Id := N + 134; -- GNAT - Name_Propagate_Exceptions : constant Name_Id := N + 135; -- GNAT - Name_Queuing_Policy : constant Name_Id := N + 136; - Name_Ravenscar : constant Name_Id := N + 137; - Name_Restricted_Run_Time : constant Name_Id := N + 138; - Name_Restrictions : constant Name_Id := N + 139; - Name_Restriction_Warnings : constant Name_Id := N + 140; -- GNAT - Name_Reviewable : constant Name_Id := N + 141; - Name_Source_File_Name : constant Name_Id := N + 142; -- GNAT - Name_Source_File_Name_Project : constant Name_Id := N + 143; -- GNAT - Name_Style_Checks : constant Name_Id := N + 144; -- GNAT - Name_Suppress : constant Name_Id := N + 145; - Name_Suppress_Exception_Locations : constant Name_Id := N + 146; -- GNAT - Name_Task_Dispatching_Policy : constant Name_Id := N + 147; - Name_Universal_Data : constant Name_Id := N + 148; -- AAMP - Name_Unsuppress : constant Name_Id := N + 149; -- GNAT - Name_Use_VADS_Size : constant Name_Id := N + 150; -- GNAT - Name_Validity_Checks : constant Name_Id := N + 151; -- GNAT - Name_Warnings : constant Name_Id := N + 152; -- GNAT - Last_Configuration_Pragma_Name : constant Name_Id := N + 152; + Name_Detect_Blocking : constant Name_Id := N + 114; -- Ada05 + Name_Discard_Names : constant Name_Id := N + 115; + Name_Elaboration_Checks : constant Name_Id := N + 116; -- GNAT + Name_Eliminate : constant Name_Id := N + 117; -- GNAT + Name_Explicit_Overriding : constant Name_Id := N + 118; + Name_Extend_System : constant Name_Id := N + 119; -- GNAT + Name_Extensions_Allowed : constant Name_Id := N + 120; -- GNAT + Name_External_Name_Casing : constant Name_Id := N + 121; -- GNAT + Name_Float_Representation : constant Name_Id := N + 122; -- GNAT + Name_Initialize_Scalars : constant Name_Id := N + 123; -- GNAT + Name_Interrupt_State : constant Name_Id := N + 124; -- GNAT + Name_License : constant Name_Id := N + 125; -- GNAT + Name_Locking_Policy : constant Name_Id := N + 126; + Name_Long_Float : constant Name_Id := N + 127; -- VMS + Name_No_Run_Time : constant Name_Id := N + 128; -- GNAT + Name_No_Strict_Aliasing : constant Name_Id := N + 129; -- GNAT + Name_Normalize_Scalars : constant Name_Id := N + 130; + Name_Polling : constant Name_Id := N + 131; -- GNAT + Name_Persistent_Data : constant Name_Id := N + 132; -- GNAT + Name_Persistent_Object : constant Name_Id := N + 133; -- GNAT + Name_Profile : constant Name_Id := N + 134; -- Ada05 + Name_Profile_Warnings : constant Name_Id := N + 135; -- GNAT + Name_Propagate_Exceptions : constant Name_Id := N + 136; -- GNAT + Name_Queuing_Policy : constant Name_Id := N + 137; + Name_Ravenscar : constant Name_Id := N + 138; + Name_Restricted_Run_Time : constant Name_Id := N + 139; + Name_Restrictions : constant Name_Id := N + 140; + Name_Restriction_Warnings : constant Name_Id := N + 141; -- GNAT + Name_Reviewable : constant Name_Id := N + 142; + Name_Source_File_Name : constant Name_Id := N + 143; -- GNAT + Name_Source_File_Name_Project : constant Name_Id := N + 144; -- GNAT + Name_Style_Checks : constant Name_Id := N + 145; -- GNAT + Name_Suppress : constant Name_Id := N + 146; + Name_Suppress_Exception_Locations : constant Name_Id := N + 147; -- GNAT + Name_Task_Dispatching_Policy : constant Name_Id := N + 148; + Name_Universal_Data : constant Name_Id := N + 149; -- AAMP + Name_Unsuppress : constant Name_Id := N + 150; -- GNAT + Name_Use_VADS_Size : constant Name_Id := N + 151; -- GNAT + Name_Validity_Checks : constant Name_Id := N + 152; -- GNAT + Name_Warnings : constant Name_Id := N + 153; -- GNAT + Last_Configuration_Pragma_Name : constant Name_Id := N + 153; -- Remaining pragma names - Name_Abort_Defer : constant Name_Id := N + 153; -- GNAT - Name_All_Calls_Remote : constant Name_Id := N + 154; - Name_Annotate : constant Name_Id := N + 155; -- GNAT + Name_Abort_Defer : constant Name_Id := N + 154; -- GNAT + Name_All_Calls_Remote : constant Name_Id := N + 155; + Name_Annotate : constant Name_Id := N + 156; -- GNAT -- Note: AST_Entry is not in this list because its name matches the -- name of the corresponding attribute. However, it is included in the @@ -376,78 +377,78 @@ package Snames is -- and Check_Pragma_Id correctly recognize and process Name_AST_Entry. -- AST_Entry is a VMS specific pragma. - Name_Assert : constant Name_Id := N + 156; -- GNAT - Name_Asynchronous : constant Name_Id := N + 157; - Name_Atomic : constant Name_Id := N + 158; - Name_Atomic_Components : constant Name_Id := N + 159; - Name_Attach_Handler : constant Name_Id := N + 160; - Name_Comment : constant Name_Id := N + 161; -- GNAT - Name_Common_Object : constant Name_Id := N + 162; -- GNAT - Name_Complex_Representation : constant Name_Id := N + 163; -- GNAT - Name_Controlled : constant Name_Id := N + 164; - Name_Convention : constant Name_Id := N + 165; - Name_CPP_Class : constant Name_Id := N + 166; -- GNAT - Name_CPP_Constructor : constant Name_Id := N + 167; -- GNAT - Name_CPP_Virtual : constant Name_Id := N + 168; -- GNAT - Name_CPP_Vtable : constant Name_Id := N + 169; -- GNAT - Name_Debug : constant Name_Id := N + 170; -- GNAT - Name_Elaborate : constant Name_Id := N + 171; -- Ada 83 - Name_Elaborate_All : constant Name_Id := N + 172; - Name_Elaborate_Body : constant Name_Id := N + 173; - Name_Export : constant Name_Id := N + 174; - Name_Export_Exception : constant Name_Id := N + 175; -- VMS - Name_Export_Function : constant Name_Id := N + 176; -- GNAT - Name_Export_Object : constant Name_Id := N + 177; -- GNAT - Name_Export_Procedure : constant Name_Id := N + 178; -- GNAT - Name_Export_Value : constant Name_Id := N + 179; -- GNAT - Name_Export_Valued_Procedure : constant Name_Id := N + 180; -- GNAT - Name_External : constant Name_Id := N + 181; -- GNAT - Name_Finalize_Storage_Only : constant Name_Id := N + 182; -- GNAT - Name_Ident : constant Name_Id := N + 183; -- VMS - Name_Import : constant Name_Id := N + 184; - Name_Import_Exception : constant Name_Id := N + 185; -- VMS - Name_Import_Function : constant Name_Id := N + 186; -- GNAT - Name_Import_Object : constant Name_Id := N + 187; -- GNAT - Name_Import_Procedure : constant Name_Id := N + 188; -- GNAT - Name_Import_Valued_Procedure : constant Name_Id := N + 189; -- GNAT - Name_Inline : constant Name_Id := N + 190; - Name_Inline_Always : constant Name_Id := N + 191; -- GNAT - Name_Inline_Generic : constant Name_Id := N + 192; -- GNAT - Name_Inspection_Point : constant Name_Id := N + 193; - Name_Interface : constant Name_Id := N + 194; -- Ada 83 - Name_Interface_Name : constant Name_Id := N + 195; -- GNAT - Name_Interrupt_Handler : constant Name_Id := N + 196; - Name_Interrupt_Priority : constant Name_Id := N + 197; - Name_Java_Constructor : constant Name_Id := N + 198; -- GNAT - Name_Java_Interface : constant Name_Id := N + 199; -- GNAT - Name_Keep_Names : constant Name_Id := N + 200; -- GNAT - Name_Link_With : constant Name_Id := N + 201; -- GNAT - Name_Linker_Alias : constant Name_Id := N + 202; -- GNAT - Name_Linker_Options : constant Name_Id := N + 203; - Name_Linker_Section : constant Name_Id := N + 204; -- GNAT - Name_List : constant Name_Id := N + 205; - Name_Machine_Attribute : constant Name_Id := N + 206; -- GNAT - Name_Main : constant Name_Id := N + 207; -- GNAT - Name_Main_Storage : constant Name_Id := N + 208; -- GNAT - Name_Memory_Size : constant Name_Id := N + 209; -- Ada 83 - Name_No_Return : constant Name_Id := N + 210; -- GNAT - Name_Obsolescent : constant Name_Id := N + 211; -- GNAT - Name_Optimize : constant Name_Id := N + 212; - Name_Optional_Overriding : constant Name_Id := N + 213; - Name_Overriding : constant Name_Id := N + 214; - Name_Pack : constant Name_Id := N + 215; - Name_Page : constant Name_Id := N + 216; - Name_Passive : constant Name_Id := N + 217; -- GNAT - Name_Preelaborate : constant Name_Id := N + 218; - Name_Priority : constant Name_Id := N + 219; - Name_Psect_Object : constant Name_Id := N + 220; -- VMS - Name_Pure : constant Name_Id := N + 221; - Name_Pure_Function : constant Name_Id := N + 222; -- GNAT - Name_Remote_Call_Interface : constant Name_Id := N + 223; - Name_Remote_Types : constant Name_Id := N + 224; - Name_Share_Generic : constant Name_Id := N + 225; -- GNAT - Name_Shared : constant Name_Id := N + 226; -- Ada 83 - Name_Shared_Passive : constant Name_Id := N + 227; + Name_Assert : constant Name_Id := N + 157; -- GNAT + Name_Asynchronous : constant Name_Id := N + 158; + Name_Atomic : constant Name_Id := N + 159; + Name_Atomic_Components : constant Name_Id := N + 160; + Name_Attach_Handler : constant Name_Id := N + 161; + Name_Comment : constant Name_Id := N + 162; -- GNAT + Name_Common_Object : constant Name_Id := N + 163; -- GNAT + Name_Complex_Representation : constant Name_Id := N + 164; -- GNAT + Name_Controlled : constant Name_Id := N + 165; + Name_Convention : constant Name_Id := N + 166; + Name_CPP_Class : constant Name_Id := N + 167; -- GNAT + Name_CPP_Constructor : constant Name_Id := N + 168; -- GNAT + Name_CPP_Virtual : constant Name_Id := N + 169; -- GNAT + Name_CPP_Vtable : constant Name_Id := N + 170; -- GNAT + Name_Debug : constant Name_Id := N + 171; -- GNAT + Name_Elaborate : constant Name_Id := N + 172; -- Ada 83 + Name_Elaborate_All : constant Name_Id := N + 173; + Name_Elaborate_Body : constant Name_Id := N + 174; + Name_Export : constant Name_Id := N + 175; + Name_Export_Exception : constant Name_Id := N + 176; -- VMS + Name_Export_Function : constant Name_Id := N + 177; -- GNAT + Name_Export_Object : constant Name_Id := N + 178; -- GNAT + Name_Export_Procedure : constant Name_Id := N + 179; -- GNAT + Name_Export_Value : constant Name_Id := N + 180; -- GNAT + Name_Export_Valued_Procedure : constant Name_Id := N + 181; -- GNAT + Name_External : constant Name_Id := N + 182; -- GNAT + Name_Finalize_Storage_Only : constant Name_Id := N + 183; -- GNAT + Name_Ident : constant Name_Id := N + 184; -- VMS + Name_Import : constant Name_Id := N + 185; + Name_Import_Exception : constant Name_Id := N + 186; -- VMS + Name_Import_Function : constant Name_Id := N + 187; -- GNAT + Name_Import_Object : constant Name_Id := N + 188; -- GNAT + Name_Import_Procedure : constant Name_Id := N + 189; -- GNAT + Name_Import_Valued_Procedure : constant Name_Id := N + 190; -- GNAT + Name_Inline : constant Name_Id := N + 191; + Name_Inline_Always : constant Name_Id := N + 192; -- GNAT + Name_Inline_Generic : constant Name_Id := N + 193; -- GNAT + Name_Inspection_Point : constant Name_Id := N + 194; + Name_Interface : constant Name_Id := N + 195; -- Ada 83 + Name_Interface_Name : constant Name_Id := N + 196; -- GNAT + Name_Interrupt_Handler : constant Name_Id := N + 197; + Name_Interrupt_Priority : constant Name_Id := N + 198; + Name_Java_Constructor : constant Name_Id := N + 199; -- GNAT + Name_Java_Interface : constant Name_Id := N + 200; -- GNAT + Name_Keep_Names : constant Name_Id := N + 201; -- GNAT + Name_Link_With : constant Name_Id := N + 202; -- GNAT + Name_Linker_Alias : constant Name_Id := N + 203; -- GNAT + Name_Linker_Options : constant Name_Id := N + 204; + Name_Linker_Section : constant Name_Id := N + 205; -- GNAT + Name_List : constant Name_Id := N + 206; + Name_Machine_Attribute : constant Name_Id := N + 207; -- GNAT + Name_Main : constant Name_Id := N + 208; -- GNAT + Name_Main_Storage : constant Name_Id := N + 209; -- GNAT + Name_Memory_Size : constant Name_Id := N + 210; -- Ada 83 + Name_No_Return : constant Name_Id := N + 211; -- GNAT + Name_Obsolescent : constant Name_Id := N + 212; -- GNAT + Name_Optimize : constant Name_Id := N + 213; + Name_Optional_Overriding : constant Name_Id := N + 214; + Name_Overriding : constant Name_Id := N + 215; + Name_Pack : constant Name_Id := N + 216; + Name_Page : constant Name_Id := N + 217; + Name_Passive : constant Name_Id := N + 218; -- GNAT + Name_Preelaborate : constant Name_Id := N + 219; + Name_Priority : constant Name_Id := N + 220; + Name_Psect_Object : constant Name_Id := N + 221; -- VMS + Name_Pure : constant Name_Id := N + 222; + Name_Pure_Function : constant Name_Id := N + 223; -- GNAT + Name_Remote_Call_Interface : constant Name_Id := N + 224; + Name_Remote_Types : constant Name_Id := N + 225; + Name_Share_Generic : constant Name_Id := N + 226; -- GNAT + Name_Shared : constant Name_Id := N + 227; -- Ada 83 + Name_Shared_Passive : constant Name_Id := N + 228; -- Note: Storage_Size is not in this list because its name matches the -- name of the corresponding attribute. However, it is included in the @@ -457,27 +458,27 @@ package Snames is -- Note: Storage_Unit is also omitted from the list because of a clash -- with an attribute name, and is treated similarly. - Name_Source_Reference : constant Name_Id := N + 228; -- GNAT - Name_Stream_Convert : constant Name_Id := N + 229; -- GNAT - Name_Subtitle : constant Name_Id := N + 230; -- GNAT - Name_Suppress_All : constant Name_Id := N + 231; -- GNAT - Name_Suppress_Debug_Info : constant Name_Id := N + 232; -- GNAT - Name_Suppress_Initialization : constant Name_Id := N + 233; -- GNAT - Name_System_Name : constant Name_Id := N + 234; -- Ada 83 - Name_Task_Info : constant Name_Id := N + 235; -- GNAT - Name_Task_Name : constant Name_Id := N + 236; -- GNAT - Name_Task_Storage : constant Name_Id := N + 237; -- VMS - Name_Thread_Body : constant Name_Id := N + 238; -- GNAT - Name_Time_Slice : constant Name_Id := N + 239; -- GNAT - Name_Title : constant Name_Id := N + 240; -- GNAT - Name_Unchecked_Union : constant Name_Id := N + 241; -- GNAT - Name_Unimplemented_Unit : constant Name_Id := N + 242; -- GNAT - Name_Unreferenced : constant Name_Id := N + 243; -- GNAT - Name_Unreserve_All_Interrupts : constant Name_Id := N + 244; -- GNAT - Name_Volatile : constant Name_Id := N + 245; - Name_Volatile_Components : constant Name_Id := N + 246; - Name_Weak_External : constant Name_Id := N + 247; -- GNAT - Last_Pragma_Name : constant Name_Id := N + 247; + Name_Source_Reference : constant Name_Id := N + 229; -- GNAT + Name_Stream_Convert : constant Name_Id := N + 230; -- GNAT + Name_Subtitle : constant Name_Id := N + 231; -- GNAT + Name_Suppress_All : constant Name_Id := N + 232; -- GNAT + Name_Suppress_Debug_Info : constant Name_Id := N + 233; -- GNAT + Name_Suppress_Initialization : constant Name_Id := N + 234; -- GNAT + Name_System_Name : constant Name_Id := N + 235; -- Ada 83 + Name_Task_Info : constant Name_Id := N + 236; -- GNAT + Name_Task_Name : constant Name_Id := N + 237; -- GNAT + Name_Task_Storage : constant Name_Id := N + 238; -- VMS + Name_Thread_Body : constant Name_Id := N + 239; -- GNAT + Name_Time_Slice : constant Name_Id := N + 240; -- GNAT + Name_Title : constant Name_Id := N + 241; -- GNAT + Name_Unchecked_Union : constant Name_Id := N + 242; -- GNAT + Name_Unimplemented_Unit : constant Name_Id := N + 243; -- GNAT + Name_Unreferenced : constant Name_Id := N + 244; -- GNAT + Name_Unreserve_All_Interrupts : constant Name_Id := N + 245; -- GNAT + Name_Volatile : constant Name_Id := N + 246; + Name_Volatile_Components : constant Name_Id := N + 247; + Name_Weak_External : constant Name_Id := N + 248; -- GNAT + Last_Pragma_Name : constant Name_Id := N + 248; -- Language convention names for pragma Convention/Export/Import/Interface -- Note that Name_C is not included in this list, since it was already @@ -488,105 +489,105 @@ package Snames is -- Entry and Protected, this is because these conventions cannot be -- specified by a pragma. - First_Convention_Name : constant Name_Id := N + 248; - Name_Ada : constant Name_Id := N + 248; - Name_Assembler : constant Name_Id := N + 249; - Name_COBOL : constant Name_Id := N + 250; - Name_CPP : constant Name_Id := N + 251; - Name_Fortran : constant Name_Id := N + 252; - Name_Intrinsic : constant Name_Id := N + 253; - Name_Java : constant Name_Id := N + 254; - Name_Stdcall : constant Name_Id := N + 255; - Name_Stubbed : constant Name_Id := N + 256; - Last_Convention_Name : constant Name_Id := N + 256; + First_Convention_Name : constant Name_Id := N + 249; + Name_Ada : constant Name_Id := N + 249; + Name_Assembler : constant Name_Id := N + 250; + Name_COBOL : constant Name_Id := N + 251; + Name_CPP : constant Name_Id := N + 252; + Name_Fortran : constant Name_Id := N + 253; + Name_Intrinsic : constant Name_Id := N + 254; + Name_Java : constant Name_Id := N + 255; + Name_Stdcall : constant Name_Id := N + 256; + Name_Stubbed : constant Name_Id := N + 257; + Last_Convention_Name : constant Name_Id := N + 257; -- The following names are preset as synonyms for Assembler - Name_Asm : constant Name_Id := N + 257; - Name_Assembly : constant Name_Id := N + 258; + Name_Asm : constant Name_Id := N + 258; + Name_Assembly : constant Name_Id := N + 259; -- The following names are preset as synonyms for C - Name_Default : constant Name_Id := N + 259; + Name_Default : constant Name_Id := N + 260; -- Name_Exernal (previously defined as pragma) -- The following names are present as synonyms for Stdcall - Name_DLL : constant Name_Id := N + 260; - Name_Win32 : constant Name_Id := N + 261; + Name_DLL : constant Name_Id := N + 261; + Name_Win32 : constant Name_Id := N + 262; -- Other special names used in processing pragmas - Name_As_Is : constant Name_Id := N + 262; - Name_Body_File_Name : constant Name_Id := N + 263; - Name_Boolean_Entry_Barriers : constant Name_Id := N + 264; - Name_Casing : constant Name_Id := N + 265; - Name_Code : constant Name_Id := N + 266; - Name_Component : constant Name_Id := N + 267; - Name_Component_Size_4 : constant Name_Id := N + 268; - Name_Copy : constant Name_Id := N + 269; - Name_D_Float : constant Name_Id := N + 270; - Name_Descriptor : constant Name_Id := N + 271; - Name_Dot_Replacement : constant Name_Id := N + 272; - Name_Dynamic : constant Name_Id := N + 273; - Name_Entity : constant Name_Id := N + 274; - Name_External_Name : constant Name_Id := N + 275; - Name_First_Optional_Parameter : constant Name_Id := N + 276; - Name_Form : constant Name_Id := N + 277; - Name_G_Float : constant Name_Id := N + 278; - Name_Gcc : constant Name_Id := N + 279; - Name_Gnat : constant Name_Id := N + 280; - Name_GPL : constant Name_Id := N + 281; - Name_IEEE_Float : constant Name_Id := N + 282; - Name_Internal : constant Name_Id := N + 283; - Name_Link_Name : constant Name_Id := N + 284; - Name_Lowercase : constant Name_Id := N + 285; - Name_Max_Entry_Queue_Depth : constant Name_Id := N + 286; - Name_Max_Entry_Queue_Length : constant Name_Id := N + 287; - Name_Max_Size : constant Name_Id := N + 288; - Name_Mechanism : constant Name_Id := N + 289; - Name_Mixedcase : constant Name_Id := N + 290; - Name_Modified_GPL : constant Name_Id := N + 291; - Name_Name : constant Name_Id := N + 292; - Name_NCA : constant Name_Id := N + 293; - Name_No : constant Name_Id := N + 294; - Name_On : constant Name_Id := N + 295; - Name_Parameter_Types : constant Name_Id := N + 296; - Name_Reference : constant Name_Id := N + 297; - Name_No_Dynamic_Attachment : constant Name_Id := N + 298; - Name_No_Dynamic_Interrupts : constant Name_Id := N + 299; - Name_No_Requeue : constant Name_Id := N + 300; - Name_No_Requeue_Statements : constant Name_Id := N + 301; - Name_No_Task_Attributes : constant Name_Id := N + 302; - Name_No_Task_Attributes_Package : constant Name_Id := N + 303; - Name_Restricted : constant Name_Id := N + 304; - Name_Result_Mechanism : constant Name_Id := N + 305; - Name_Result_Type : constant Name_Id := N + 306; - Name_Runtime : constant Name_Id := N + 307; - Name_SB : constant Name_Id := N + 308; - Name_Secondary_Stack_Size : constant Name_Id := N + 309; - Name_Section : constant Name_Id := N + 310; - Name_Semaphore : constant Name_Id := N + 311; - Name_Simple_Barriers : constant Name_Id := N + 312; - Name_Spec_File_Name : constant Name_Id := N + 313; - Name_Static : constant Name_Id := N + 314; - Name_Stack_Size : constant Name_Id := N + 315; - Name_Subunit_File_Name : constant Name_Id := N + 316; - Name_Task_Stack_Size_Default : constant Name_Id := N + 317; - Name_Task_Type : constant Name_Id := N + 318; - Name_Time_Slicing_Enabled : constant Name_Id := N + 319; - Name_Top_Guard : constant Name_Id := N + 320; - Name_UBA : constant Name_Id := N + 321; - Name_UBS : constant Name_Id := N + 322; - Name_UBSB : constant Name_Id := N + 323; - Name_Unit_Name : constant Name_Id := N + 324; - Name_Unknown : constant Name_Id := N + 325; - Name_Unrestricted : constant Name_Id := N + 326; - Name_Uppercase : constant Name_Id := N + 327; - Name_User : constant Name_Id := N + 328; - Name_VAX_Float : constant Name_Id := N + 329; - Name_VMS : constant Name_Id := N + 330; - Name_Working_Storage : constant Name_Id := N + 331; + Name_As_Is : constant Name_Id := N + 263; + Name_Body_File_Name : constant Name_Id := N + 264; + Name_Boolean_Entry_Barriers : constant Name_Id := N + 265; + Name_Casing : constant Name_Id := N + 266; + Name_Code : constant Name_Id := N + 267; + Name_Component : constant Name_Id := N + 268; + Name_Component_Size_4 : constant Name_Id := N + 269; + Name_Copy : constant Name_Id := N + 270; + Name_D_Float : constant Name_Id := N + 271; + Name_Descriptor : constant Name_Id := N + 272; + Name_Dot_Replacement : constant Name_Id := N + 273; + Name_Dynamic : constant Name_Id := N + 274; + Name_Entity : constant Name_Id := N + 275; + Name_External_Name : constant Name_Id := N + 276; + Name_First_Optional_Parameter : constant Name_Id := N + 277; + Name_Form : constant Name_Id := N + 278; + Name_G_Float : constant Name_Id := N + 279; + Name_Gcc : constant Name_Id := N + 280; + Name_Gnat : constant Name_Id := N + 281; + Name_GPL : constant Name_Id := N + 282; + Name_IEEE_Float : constant Name_Id := N + 283; + Name_Internal : constant Name_Id := N + 284; + Name_Link_Name : constant Name_Id := N + 285; + Name_Lowercase : constant Name_Id := N + 286; + Name_Max_Entry_Queue_Depth : constant Name_Id := N + 287; + Name_Max_Entry_Queue_Length : constant Name_Id := N + 288; + Name_Max_Size : constant Name_Id := N + 289; + Name_Mechanism : constant Name_Id := N + 290; + Name_Mixedcase : constant Name_Id := N + 291; + Name_Modified_GPL : constant Name_Id := N + 292; + Name_Name : constant Name_Id := N + 293; + Name_NCA : constant Name_Id := N + 294; + Name_No : constant Name_Id := N + 295; + Name_On : constant Name_Id := N + 296; + Name_Parameter_Types : constant Name_Id := N + 297; + Name_Reference : constant Name_Id := N + 298; + Name_No_Dynamic_Attachment : constant Name_Id := N + 299; + Name_No_Dynamic_Interrupts : constant Name_Id := N + 300; + Name_No_Requeue : constant Name_Id := N + 301; + Name_No_Requeue_Statements : constant Name_Id := N + 302; + Name_No_Task_Attributes : constant Name_Id := N + 303; + Name_No_Task_Attributes_Package : constant Name_Id := N + 304; + Name_Restricted : constant Name_Id := N + 305; + Name_Result_Mechanism : constant Name_Id := N + 306; + Name_Result_Type : constant Name_Id := N + 307; + Name_Runtime : constant Name_Id := N + 308; + Name_SB : constant Name_Id := N + 309; + Name_Secondary_Stack_Size : constant Name_Id := N + 310; + Name_Section : constant Name_Id := N + 311; + Name_Semaphore : constant Name_Id := N + 312; + Name_Simple_Barriers : constant Name_Id := N + 313; + Name_Spec_File_Name : constant Name_Id := N + 314; + Name_Static : constant Name_Id := N + 315; + Name_Stack_Size : constant Name_Id := N + 316; + Name_Subunit_File_Name : constant Name_Id := N + 317; + Name_Task_Stack_Size_Default : constant Name_Id := N + 318; + Name_Task_Type : constant Name_Id := N + 319; + Name_Time_Slicing_Enabled : constant Name_Id := N + 320; + Name_Top_Guard : constant Name_Id := N + 321; + Name_UBA : constant Name_Id := N + 322; + Name_UBS : constant Name_Id := N + 323; + Name_UBSB : constant Name_Id := N + 324; + Name_Unit_Name : constant Name_Id := N + 325; + Name_Unknown : constant Name_Id := N + 326; + Name_Unrestricted : constant Name_Id := N + 327; + Name_Uppercase : constant Name_Id := N + 328; + Name_User : constant Name_Id := N + 329; + Name_VAX_Float : constant Name_Id := N + 330; + Name_VMS : constant Name_Id := N + 331; + Name_Working_Storage : constant Name_Id := N + 332; -- Names of recognized attributes. The entries with the comment "Ada 83" -- are attributes that are defined in Ada 83, but not in Ada 95. These @@ -600,158 +601,158 @@ package Snames is -- The entries marked VMS are recognized only in OpenVMS implementations -- of GNAT, and are treated as illegal in all other contexts. - First_Attribute_Name : constant Name_Id := N + 332; - Name_Abort_Signal : constant Name_Id := N + 332; -- GNAT - Name_Access : constant Name_Id := N + 333; - Name_Address : constant Name_Id := N + 334; - Name_Address_Size : constant Name_Id := N + 335; -- GNAT - Name_Aft : constant Name_Id := N + 336; - Name_Alignment : constant Name_Id := N + 337; - Name_Asm_Input : constant Name_Id := N + 338; -- GNAT - Name_Asm_Output : constant Name_Id := N + 339; -- GNAT - Name_AST_Entry : constant Name_Id := N + 340; -- VMS - Name_Bit : constant Name_Id := N + 341; -- GNAT - Name_Bit_Order : constant Name_Id := N + 342; - Name_Bit_Position : constant Name_Id := N + 343; -- GNAT - Name_Body_Version : constant Name_Id := N + 344; - Name_Callable : constant Name_Id := N + 345; - Name_Caller : constant Name_Id := N + 346; - Name_Code_Address : constant Name_Id := N + 347; -- GNAT - Name_Component_Size : constant Name_Id := N + 348; - Name_Compose : constant Name_Id := N + 349; - Name_Constrained : constant Name_Id := N + 350; - Name_Count : constant Name_Id := N + 351; - Name_Default_Bit_Order : constant Name_Id := N + 352; -- GNAT - Name_Definite : constant Name_Id := N + 353; - Name_Delta : constant Name_Id := N + 354; - Name_Denorm : constant Name_Id := N + 355; - Name_Digits : constant Name_Id := N + 356; - Name_Elaborated : constant Name_Id := N + 357; -- GNAT - Name_Emax : constant Name_Id := N + 358; -- Ada 83 - Name_Enum_Rep : constant Name_Id := N + 359; -- GNAT - Name_Epsilon : constant Name_Id := N + 360; -- Ada 83 - Name_Exponent : constant Name_Id := N + 361; - Name_External_Tag : constant Name_Id := N + 362; - Name_First : constant Name_Id := N + 363; - Name_First_Bit : constant Name_Id := N + 364; - Name_Fixed_Value : constant Name_Id := N + 365; -- GNAT - Name_Fore : constant Name_Id := N + 366; - Name_Has_Discriminants : constant Name_Id := N + 367; -- GNAT - Name_Identity : constant Name_Id := N + 368; - Name_Img : constant Name_Id := N + 369; -- GNAT - Name_Integer_Value : constant Name_Id := N + 370; -- GNAT - Name_Large : constant Name_Id := N + 371; -- Ada 83 - Name_Last : constant Name_Id := N + 372; - Name_Last_Bit : constant Name_Id := N + 373; - Name_Leading_Part : constant Name_Id := N + 374; - Name_Length : constant Name_Id := N + 375; - Name_Machine_Emax : constant Name_Id := N + 376; - Name_Machine_Emin : constant Name_Id := N + 377; - Name_Machine_Mantissa : constant Name_Id := N + 378; - Name_Machine_Overflows : constant Name_Id := N + 379; - Name_Machine_Radix : constant Name_Id := N + 380; - Name_Machine_Rounds : constant Name_Id := N + 381; - Name_Machine_Size : constant Name_Id := N + 382; -- GNAT - Name_Mantissa : constant Name_Id := N + 383; -- Ada 83 - Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 384; - Name_Maximum_Alignment : constant Name_Id := N + 385; -- GNAT - Name_Mechanism_Code : constant Name_Id := N + 386; -- GNAT - Name_Model_Emin : constant Name_Id := N + 387; - Name_Model_Epsilon : constant Name_Id := N + 388; - Name_Model_Mantissa : constant Name_Id := N + 389; - Name_Model_Small : constant Name_Id := N + 390; - Name_Modulus : constant Name_Id := N + 391; - Name_Null_Parameter : constant Name_Id := N + 392; -- GNAT - Name_Object_Size : constant Name_Id := N + 393; -- GNAT - Name_Partition_ID : constant Name_Id := N + 394; - Name_Passed_By_Reference : constant Name_Id := N + 395; -- GNAT - Name_Pool_Address : constant Name_Id := N + 396; - Name_Pos : constant Name_Id := N + 397; - Name_Position : constant Name_Id := N + 398; - Name_Range : constant Name_Id := N + 399; - Name_Range_Length : constant Name_Id := N + 400; -- GNAT - Name_Round : constant Name_Id := N + 401; - Name_Safe_Emax : constant Name_Id := N + 402; -- Ada 83 - Name_Safe_First : constant Name_Id := N + 403; - Name_Safe_Large : constant Name_Id := N + 404; -- Ada 83 - Name_Safe_Last : constant Name_Id := N + 405; - Name_Safe_Small : constant Name_Id := N + 406; -- Ada 83 - Name_Scale : constant Name_Id := N + 407; - Name_Scaling : constant Name_Id := N + 408; - Name_Signed_Zeros : constant Name_Id := N + 409; - Name_Size : constant Name_Id := N + 410; - Name_Small : constant Name_Id := N + 411; - Name_Storage_Size : constant Name_Id := N + 412; - Name_Storage_Unit : constant Name_Id := N + 413; -- GNAT - Name_Tag : constant Name_Id := N + 414; - Name_Target_Name : constant Name_Id := N + 415; -- GNAT - Name_Terminated : constant Name_Id := N + 416; - Name_To_Address : constant Name_Id := N + 417; -- GNAT - Name_Type_Class : constant Name_Id := N + 418; -- GNAT - Name_UET_Address : constant Name_Id := N + 419; -- GNAT - Name_Unbiased_Rounding : constant Name_Id := N + 420; - Name_Unchecked_Access : constant Name_Id := N + 421; - Name_Unconstrained_Array : constant Name_Id := N + 422; - Name_Universal_Literal_String : constant Name_Id := N + 423; -- GNAT - Name_Unrestricted_Access : constant Name_Id := N + 424; -- GNAT - Name_VADS_Size : constant Name_Id := N + 425; -- GNAT - Name_Val : constant Name_Id := N + 426; - Name_Valid : constant Name_Id := N + 427; - Name_Value_Size : constant Name_Id := N + 428; -- GNAT - Name_Version : constant Name_Id := N + 429; - Name_Wchar_T_Size : constant Name_Id := N + 430; -- GNAT - Name_Wide_Width : constant Name_Id := N + 431; - Name_Width : constant Name_Id := N + 432; - Name_Word_Size : constant Name_Id := N + 433; -- GNAT + First_Attribute_Name : constant Name_Id := N + 333; + Name_Abort_Signal : constant Name_Id := N + 333; -- GNAT + Name_Access : constant Name_Id := N + 334; + Name_Address : constant Name_Id := N + 335; + Name_Address_Size : constant Name_Id := N + 336; -- GNAT + Name_Aft : constant Name_Id := N + 337; + Name_Alignment : constant Name_Id := N + 338; + Name_Asm_Input : constant Name_Id := N + 339; -- GNAT + Name_Asm_Output : constant Name_Id := N + 340; -- GNAT + Name_AST_Entry : constant Name_Id := N + 341; -- VMS + Name_Bit : constant Name_Id := N + 342; -- GNAT + Name_Bit_Order : constant Name_Id := N + 343; + Name_Bit_Position : constant Name_Id := N + 344; -- GNAT + Name_Body_Version : constant Name_Id := N + 345; + Name_Callable : constant Name_Id := N + 346; + Name_Caller : constant Name_Id := N + 347; + Name_Code_Address : constant Name_Id := N + 348; -- GNAT + Name_Component_Size : constant Name_Id := N + 349; + Name_Compose : constant Name_Id := N + 350; + Name_Constrained : constant Name_Id := N + 351; + Name_Count : constant Name_Id := N + 352; + Name_Default_Bit_Order : constant Name_Id := N + 353; -- GNAT + Name_Definite : constant Name_Id := N + 354; + Name_Delta : constant Name_Id := N + 355; + Name_Denorm : constant Name_Id := N + 356; + Name_Digits : constant Name_Id := N + 357; + Name_Elaborated : constant Name_Id := N + 358; -- GNAT + Name_Emax : constant Name_Id := N + 359; -- Ada 83 + Name_Enum_Rep : constant Name_Id := N + 360; -- GNAT + Name_Epsilon : constant Name_Id := N + 361; -- Ada 83 + Name_Exponent : constant Name_Id := N + 362; + Name_External_Tag : constant Name_Id := N + 363; + Name_First : constant Name_Id := N + 364; + Name_First_Bit : constant Name_Id := N + 365; + Name_Fixed_Value : constant Name_Id := N + 366; -- GNAT + Name_Fore : constant Name_Id := N + 367; + Name_Has_Discriminants : constant Name_Id := N + 368; -- GNAT + Name_Identity : constant Name_Id := N + 369; + Name_Img : constant Name_Id := N + 370; -- GNAT + Name_Integer_Value : constant Name_Id := N + 371; -- GNAT + Name_Large : constant Name_Id := N + 372; -- Ada 83 + Name_Last : constant Name_Id := N + 373; + Name_Last_Bit : constant Name_Id := N + 374; + Name_Leading_Part : constant Name_Id := N + 375; + Name_Length : constant Name_Id := N + 376; + Name_Machine_Emax : constant Name_Id := N + 377; + Name_Machine_Emin : constant Name_Id := N + 378; + Name_Machine_Mantissa : constant Name_Id := N + 379; + Name_Machine_Overflows : constant Name_Id := N + 380; + Name_Machine_Radix : constant Name_Id := N + 381; + Name_Machine_Rounds : constant Name_Id := N + 382; + Name_Machine_Size : constant Name_Id := N + 383; -- GNAT + Name_Mantissa : constant Name_Id := N + 384; -- Ada 83 + Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 385; + Name_Maximum_Alignment : constant Name_Id := N + 386; -- GNAT + Name_Mechanism_Code : constant Name_Id := N + 387; -- GNAT + Name_Model_Emin : constant Name_Id := N + 388; + Name_Model_Epsilon : constant Name_Id := N + 389; + Name_Model_Mantissa : constant Name_Id := N + 390; + Name_Model_Small : constant Name_Id := N + 391; + Name_Modulus : constant Name_Id := N + 392; + Name_Null_Parameter : constant Name_Id := N + 393; -- GNAT + Name_Object_Size : constant Name_Id := N + 394; -- GNAT + Name_Partition_ID : constant Name_Id := N + 395; + Name_Passed_By_Reference : constant Name_Id := N + 396; -- GNAT + Name_Pool_Address : constant Name_Id := N + 397; + Name_Pos : constant Name_Id := N + 398; + Name_Position : constant Name_Id := N + 399; + Name_Range : constant Name_Id := N + 400; + Name_Range_Length : constant Name_Id := N + 401; -- GNAT + Name_Round : constant Name_Id := N + 402; + Name_Safe_Emax : constant Name_Id := N + 403; -- Ada 83 + Name_Safe_First : constant Name_Id := N + 404; + Name_Safe_Large : constant Name_Id := N + 405; -- Ada 83 + Name_Safe_Last : constant Name_Id := N + 406; + Name_Safe_Small : constant Name_Id := N + 407; -- Ada 83 + Name_Scale : constant Name_Id := N + 408; + Name_Scaling : constant Name_Id := N + 409; + Name_Signed_Zeros : constant Name_Id := N + 410; + Name_Size : constant Name_Id := N + 411; + Name_Small : constant Name_Id := N + 412; + Name_Storage_Size : constant Name_Id := N + 413; + Name_Storage_Unit : constant Name_Id := N + 414; -- GNAT + Name_Tag : constant Name_Id := N + 415; + Name_Target_Name : constant Name_Id := N + 416; -- GNAT + Name_Terminated : constant Name_Id := N + 417; + Name_To_Address : constant Name_Id := N + 418; -- GNAT + Name_Type_Class : constant Name_Id := N + 419; -- GNAT + Name_UET_Address : constant Name_Id := N + 420; -- GNAT + Name_Unbiased_Rounding : constant Name_Id := N + 421; + Name_Unchecked_Access : constant Name_Id := N + 422; + Name_Unconstrained_Array : constant Name_Id := N + 423; + Name_Universal_Literal_String : constant Name_Id := N + 424; -- GNAT + Name_Unrestricted_Access : constant Name_Id := N + 425; -- GNAT + Name_VADS_Size : constant Name_Id := N + 426; -- GNAT + Name_Val : constant Name_Id := N + 427; + Name_Valid : constant Name_Id := N + 428; + Name_Value_Size : constant Name_Id := N + 429; -- GNAT + Name_Version : constant Name_Id := N + 430; + Name_Wchar_T_Size : constant Name_Id := N + 431; -- GNAT + Name_Wide_Width : constant Name_Id := N + 432; + Name_Width : constant Name_Id := N + 433; + Name_Word_Size : constant Name_Id := N + 434; -- GNAT -- Attributes that designate attributes returning renamable functions, -- i.e. functions that return other than a universal value. - First_Renamable_Function_Attribute : constant Name_Id := N + 434; - Name_Adjacent : constant Name_Id := N + 434; - Name_Ceiling : constant Name_Id := N + 435; - Name_Copy_Sign : constant Name_Id := N + 436; - Name_Floor : constant Name_Id := N + 437; - Name_Fraction : constant Name_Id := N + 438; - Name_Image : constant Name_Id := N + 439; - Name_Input : constant Name_Id := N + 440; - Name_Machine : constant Name_Id := N + 441; - Name_Max : constant Name_Id := N + 442; - Name_Min : constant Name_Id := N + 443; - Name_Model : constant Name_Id := N + 444; - Name_Pred : constant Name_Id := N + 445; - Name_Remainder : constant Name_Id := N + 446; - Name_Rounding : constant Name_Id := N + 447; - Name_Succ : constant Name_Id := N + 448; - Name_Truncation : constant Name_Id := N + 449; - Name_Value : constant Name_Id := N + 450; - Name_Wide_Image : constant Name_Id := N + 451; - Name_Wide_Value : constant Name_Id := N + 452; - Last_Renamable_Function_Attribute : constant Name_Id := N + 452; + First_Renamable_Function_Attribute : constant Name_Id := N + 435; + Name_Adjacent : constant Name_Id := N + 435; + Name_Ceiling : constant Name_Id := N + 436; + Name_Copy_Sign : constant Name_Id := N + 437; + Name_Floor : constant Name_Id := N + 438; + Name_Fraction : constant Name_Id := N + 439; + Name_Image : constant Name_Id := N + 440; + Name_Input : constant Name_Id := N + 441; + Name_Machine : constant Name_Id := N + 442; + Name_Max : constant Name_Id := N + 443; + Name_Min : constant Name_Id := N + 444; + Name_Model : constant Name_Id := N + 445; + Name_Pred : constant Name_Id := N + 446; + Name_Remainder : constant Name_Id := N + 447; + Name_Rounding : constant Name_Id := N + 448; + Name_Succ : constant Name_Id := N + 449; + Name_Truncation : constant Name_Id := N + 450; + Name_Value : constant Name_Id := N + 451; + Name_Wide_Image : constant Name_Id := N + 452; + Name_Wide_Value : constant Name_Id := N + 453; + Last_Renamable_Function_Attribute : constant Name_Id := N + 453; -- Attributes that designate procedures - First_Procedure_Attribute : constant Name_Id := N + 453; - Name_Output : constant Name_Id := N + 453; - Name_Read : constant Name_Id := N + 454; - Name_Write : constant Name_Id := N + 455; - Last_Procedure_Attribute : constant Name_Id := N + 455; + First_Procedure_Attribute : constant Name_Id := N + 454; + Name_Output : constant Name_Id := N + 454; + Name_Read : constant Name_Id := N + 455; + Name_Write : constant Name_Id := N + 456; + Last_Procedure_Attribute : constant Name_Id := N + 456; -- Remaining attributes are ones that return entities - First_Entity_Attribute_Name : constant Name_Id := N + 456; - Name_Elab_Body : constant Name_Id := N + 456; -- GNAT - Name_Elab_Spec : constant Name_Id := N + 457; -- GNAT - Name_Storage_Pool : constant Name_Id := N + 458; + First_Entity_Attribute_Name : constant Name_Id := N + 457; + Name_Elab_Body : constant Name_Id := N + 457; -- GNAT + Name_Elab_Spec : constant Name_Id := N + 458; -- GNAT + Name_Storage_Pool : constant Name_Id := N + 459; -- These attributes are the ones that return types - First_Type_Attribute_Name : constant Name_Id := N + 459; - Name_Base : constant Name_Id := N + 459; - Name_Class : constant Name_Id := N + 460; - Last_Type_Attribute_Name : constant Name_Id := N + 460; - Last_Entity_Attribute_Name : constant Name_Id := N + 460; - Last_Attribute_Name : constant Name_Id := N + 460; + First_Type_Attribute_Name : constant Name_Id := N + 460; + Name_Base : constant Name_Id := N + 460; + Name_Class : constant Name_Id := N + 461; + Last_Type_Attribute_Name : constant Name_Id := N + 461; + Last_Entity_Attribute_Name : constant Name_Id := N + 461; + Last_Attribute_Name : constant Name_Id := N + 461; -- Names of recognized locking policy identifiers @@ -759,10 +760,10 @@ package Snames is -- name (e.g. C for Ceiling_Locking). If new policy names are added, -- the first character must be distinct. - First_Locking_Policy_Name : constant Name_Id := N + 461; - Name_Ceiling_Locking : constant Name_Id := N + 461; - Name_Inheritance_Locking : constant Name_Id := N + 462; - Last_Locking_Policy_Name : constant Name_Id := N + 462; + First_Locking_Policy_Name : constant Name_Id := N + 462; + Name_Ceiling_Locking : constant Name_Id := N + 462; + Name_Inheritance_Locking : constant Name_Id := N + 463; + Last_Locking_Policy_Name : constant Name_Id := N + 463; -- Names of recognized queuing policy identifiers. @@ -770,10 +771,10 @@ package Snames is -- name (e.g. F for FIFO_Queuing). If new policy names are added, -- the first character must be distinct. - First_Queuing_Policy_Name : constant Name_Id := N + 463; - Name_FIFO_Queuing : constant Name_Id := N + 463; - Name_Priority_Queuing : constant Name_Id := N + 464; - Last_Queuing_Policy_Name : constant Name_Id := N + 464; + First_Queuing_Policy_Name : constant Name_Id := N + 464; + Name_FIFO_Queuing : constant Name_Id := N + 464; + Name_Priority_Queuing : constant Name_Id := N + 465; + Last_Queuing_Policy_Name : constant Name_Id := N + 465; -- Names of recognized task dispatching policy identifiers @@ -781,194 +782,194 @@ package Snames is -- name (e.g. F for FIFO_WIthinn_Priorities). If new policy names -- are added, the first character must be distinct. - First_Task_Dispatching_Policy_Name : constant Name_Id := N + 465; - Name_FIFO_Within_Priorities : constant Name_Id := N + 465; - Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 465; + First_Task_Dispatching_Policy_Name : constant Name_Id := N + 466; + Name_FIFO_Within_Priorities : constant Name_Id := N + 466; + Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 466; -- Names of recognized checks for pragma Suppress - First_Check_Name : constant Name_Id := N + 466; - Name_Access_Check : constant Name_Id := N + 466; - Name_Accessibility_Check : constant Name_Id := N + 467; - Name_Discriminant_Check : constant Name_Id := N + 468; - Name_Division_Check : constant Name_Id := N + 469; - Name_Elaboration_Check : constant Name_Id := N + 470; - Name_Index_Check : constant Name_Id := N + 471; - Name_Length_Check : constant Name_Id := N + 472; - Name_Overflow_Check : constant Name_Id := N + 473; - Name_Range_Check : constant Name_Id := N + 474; - Name_Storage_Check : constant Name_Id := N + 475; - Name_Tag_Check : constant Name_Id := N + 476; - Name_All_Checks : constant Name_Id := N + 477; - Last_Check_Name : constant Name_Id := N + 477; + First_Check_Name : constant Name_Id := N + 467; + Name_Access_Check : constant Name_Id := N + 467; + Name_Accessibility_Check : constant Name_Id := N + 468; + Name_Discriminant_Check : constant Name_Id := N + 469; + Name_Division_Check : constant Name_Id := N + 470; + Name_Elaboration_Check : constant Name_Id := N + 471; + Name_Index_Check : constant Name_Id := N + 472; + Name_Length_Check : constant Name_Id := N + 473; + Name_Overflow_Check : constant Name_Id := N + 474; + Name_Range_Check : constant Name_Id := N + 475; + Name_Storage_Check : constant Name_Id := N + 476; + Name_Tag_Check : constant Name_Id := N + 477; + Name_All_Checks : constant Name_Id := N + 478; + Last_Check_Name : constant Name_Id := N + 478; -- Names corresponding to reserved keywords, excluding those already -- declared in the attribute list (Access, Delta, Digits, Range). - Name_Abort : constant Name_Id := N + 478; - Name_Abs : constant Name_Id := N + 479; - Name_Accept : constant Name_Id := N + 480; - Name_And : constant Name_Id := N + 481; - Name_All : constant Name_Id := N + 482; - Name_Array : constant Name_Id := N + 483; - Name_At : constant Name_Id := N + 484; - Name_Begin : constant Name_Id := N + 485; - Name_Body : constant Name_Id := N + 486; - Name_Case : constant Name_Id := N + 487; - Name_Constant : constant Name_Id := N + 488; - Name_Declare : constant Name_Id := N + 489; - Name_Delay : constant Name_Id := N + 490; - Name_Do : constant Name_Id := N + 491; - Name_Else : constant Name_Id := N + 492; - Name_Elsif : constant Name_Id := N + 493; - Name_End : constant Name_Id := N + 494; - Name_Entry : constant Name_Id := N + 495; - Name_Exception : constant Name_Id := N + 496; - Name_Exit : constant Name_Id := N + 497; - Name_For : constant Name_Id := N + 498; - Name_Function : constant Name_Id := N + 499; - Name_Generic : constant Name_Id := N + 500; - Name_Goto : constant Name_Id := N + 501; - Name_If : constant Name_Id := N + 502; - Name_In : constant Name_Id := N + 503; - Name_Is : constant Name_Id := N + 504; - Name_Limited : constant Name_Id := N + 505; - Name_Loop : constant Name_Id := N + 506; - Name_Mod : constant Name_Id := N + 507; - Name_New : constant Name_Id := N + 508; - Name_Not : constant Name_Id := N + 509; - Name_Null : constant Name_Id := N + 510; - Name_Of : constant Name_Id := N + 511; - Name_Or : constant Name_Id := N + 512; - Name_Others : constant Name_Id := N + 513; - Name_Out : constant Name_Id := N + 514; - Name_Package : constant Name_Id := N + 515; - Name_Pragma : constant Name_Id := N + 516; - Name_Private : constant Name_Id := N + 517; - Name_Procedure : constant Name_Id := N + 518; - Name_Raise : constant Name_Id := N + 519; - Name_Record : constant Name_Id := N + 520; - Name_Rem : constant Name_Id := N + 521; - Name_Renames : constant Name_Id := N + 522; - Name_Return : constant Name_Id := N + 523; - Name_Reverse : constant Name_Id := N + 524; - Name_Select : constant Name_Id := N + 525; - Name_Separate : constant Name_Id := N + 526; - Name_Subtype : constant Name_Id := N + 527; - Name_Task : constant Name_Id := N + 528; - Name_Terminate : constant Name_Id := N + 529; - Name_Then : constant Name_Id := N + 530; - Name_Type : constant Name_Id := N + 531; - Name_Use : constant Name_Id := N + 532; - Name_When : constant Name_Id := N + 533; - Name_While : constant Name_Id := N + 534; - Name_With : constant Name_Id := N + 535; - Name_Xor : constant Name_Id := N + 536; + Name_Abort : constant Name_Id := N + 479; + Name_Abs : constant Name_Id := N + 480; + Name_Accept : constant Name_Id := N + 481; + Name_And : constant Name_Id := N + 482; + Name_All : constant Name_Id := N + 483; + Name_Array : constant Name_Id := N + 484; + Name_At : constant Name_Id := N + 485; + Name_Begin : constant Name_Id := N + 486; + Name_Body : constant Name_Id := N + 487; + Name_Case : constant Name_Id := N + 488; + Name_Constant : constant Name_Id := N + 489; + Name_Declare : constant Name_Id := N + 490; + Name_Delay : constant Name_Id := N + 491; + Name_Do : constant Name_Id := N + 492; + Name_Else : constant Name_Id := N + 493; + Name_Elsif : constant Name_Id := N + 494; + Name_End : constant Name_Id := N + 495; + Name_Entry : constant Name_Id := N + 496; + Name_Exception : constant Name_Id := N + 497; + Name_Exit : constant Name_Id := N + 498; + Name_For : constant Name_Id := N + 499; + Name_Function : constant Name_Id := N + 500; + Name_Generic : constant Name_Id := N + 501; + Name_Goto : constant Name_Id := N + 502; + Name_If : constant Name_Id := N + 503; + Name_In : constant Name_Id := N + 504; + Name_Is : constant Name_Id := N + 505; + Name_Limited : constant Name_Id := N + 506; + Name_Loop : constant Name_Id := N + 507; + Name_Mod : constant Name_Id := N + 508; + Name_New : constant Name_Id := N + 509; + Name_Not : constant Name_Id := N + 510; + Name_Null : constant Name_Id := N + 511; + Name_Of : constant Name_Id := N + 512; + Name_Or : constant Name_Id := N + 513; + Name_Others : constant Name_Id := N + 514; + Name_Out : constant Name_Id := N + 515; + Name_Package : constant Name_Id := N + 516; + Name_Pragma : constant Name_Id := N + 517; + Name_Private : constant Name_Id := N + 518; + Name_Procedure : constant Name_Id := N + 519; + Name_Raise : constant Name_Id := N + 520; + Name_Record : constant Name_Id := N + 521; + Name_Rem : constant Name_Id := N + 522; + Name_Renames : constant Name_Id := N + 523; + Name_Return : constant Name_Id := N + 524; + Name_Reverse : constant Name_Id := N + 525; + Name_Select : constant Name_Id := N + 526; + Name_Separate : constant Name_Id := N + 527; + Name_Subtype : constant Name_Id := N + 528; + Name_Task : constant Name_Id := N + 529; + Name_Terminate : constant Name_Id := N + 530; + Name_Then : constant Name_Id := N + 531; + Name_Type : constant Name_Id := N + 532; + Name_Use : constant Name_Id := N + 533; + Name_When : constant Name_Id := N + 534; + Name_While : constant Name_Id := N + 535; + Name_With : constant Name_Id := N + 536; + Name_Xor : constant Name_Id := N + 537; -- Names of intrinsic subprograms -- Note: Asm is missing from this list, since Asm is a legitimate -- convention name. So is To_Adress, which is a GNAT attribute. - First_Intrinsic_Name : constant Name_Id := N + 537; - Name_Divide : constant Name_Id := N + 537; - Name_Enclosing_Entity : constant Name_Id := N + 538; - Name_Exception_Information : constant Name_Id := N + 539; - Name_Exception_Message : constant Name_Id := N + 540; - Name_Exception_Name : constant Name_Id := N + 541; - Name_File : constant Name_Id := N + 542; - Name_Import_Address : constant Name_Id := N + 543; - Name_Import_Largest_Value : constant Name_Id := N + 544; - Name_Import_Value : constant Name_Id := N + 545; - Name_Is_Negative : constant Name_Id := N + 546; - Name_Line : constant Name_Id := N + 547; - Name_Rotate_Left : constant Name_Id := N + 548; - Name_Rotate_Right : constant Name_Id := N + 549; - Name_Shift_Left : constant Name_Id := N + 550; - Name_Shift_Right : constant Name_Id := N + 551; - Name_Shift_Right_Arithmetic : constant Name_Id := N + 552; - Name_Source_Location : constant Name_Id := N + 553; - Name_Unchecked_Conversion : constant Name_Id := N + 554; - Name_Unchecked_Deallocation : constant Name_Id := N + 555; - Name_To_Pointer : constant Name_Id := N + 556; - Last_Intrinsic_Name : constant Name_Id := N + 556; + First_Intrinsic_Name : constant Name_Id := N + 538; + Name_Divide : constant Name_Id := N + 538; + Name_Enclosing_Entity : constant Name_Id := N + 539; + Name_Exception_Information : constant Name_Id := N + 540; + Name_Exception_Message : constant Name_Id := N + 541; + Name_Exception_Name : constant Name_Id := N + 542; + Name_File : constant Name_Id := N + 543; + Name_Import_Address : constant Name_Id := N + 544; + Name_Import_Largest_Value : constant Name_Id := N + 545; + Name_Import_Value : constant Name_Id := N + 546; + Name_Is_Negative : constant Name_Id := N + 547; + Name_Line : constant Name_Id := N + 548; + Name_Rotate_Left : constant Name_Id := N + 549; + Name_Rotate_Right : constant Name_Id := N + 550; + Name_Shift_Left : constant Name_Id := N + 551; + Name_Shift_Right : constant Name_Id := N + 552; + Name_Shift_Right_Arithmetic : constant Name_Id := N + 553; + Name_Source_Location : constant Name_Id := N + 554; + Name_Unchecked_Conversion : constant Name_Id := N + 555; + Name_Unchecked_Deallocation : constant Name_Id := N + 556; + Name_To_Pointer : constant Name_Id := N + 557; + Last_Intrinsic_Name : constant Name_Id := N + 557; -- Reserved words used only in Ada 95 - First_95_Reserved_Word : constant Name_Id := N + 557; - Name_Abstract : constant Name_Id := N + 557; - Name_Aliased : constant Name_Id := N + 558; - Name_Protected : constant Name_Id := N + 559; - Name_Until : constant Name_Id := N + 560; - Name_Requeue : constant Name_Id := N + 561; - Name_Tagged : constant Name_Id := N + 562; - Last_95_Reserved_Word : constant Name_Id := N + 562; + First_95_Reserved_Word : constant Name_Id := N + 558; + Name_Abstract : constant Name_Id := N + 558; + Name_Aliased : constant Name_Id := N + 559; + Name_Protected : constant Name_Id := N + 560; + Name_Until : constant Name_Id := N + 561; + Name_Requeue : constant Name_Id := N + 562; + Name_Tagged : constant Name_Id := N + 563; + Last_95_Reserved_Word : constant Name_Id := N + 563; subtype Ada_95_Reserved_Words is Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word; -- Miscellaneous names used in semantic checking - Name_Raise_Exception : constant Name_Id := N + 563; + Name_Raise_Exception : constant Name_Id := N + 564; -- Additional reserved words in GNAT Project Files -- Note that Name_External is already previously declared - Name_Binder : constant Name_Id := N + 564; - Name_Body_Suffix : constant Name_Id := N + 565; - Name_Builder : constant Name_Id := N + 566; - Name_Compiler : constant Name_Id := N + 567; - Name_Cross_Reference : constant Name_Id := N + 568; - Name_Default_Switches : constant Name_Id := N + 569; - Name_Exec_Dir : constant Name_Id := N + 570; - Name_Executable : constant Name_Id := N + 571; - Name_Executable_Suffix : constant Name_Id := N + 572; - Name_Extends : constant Name_Id := N + 573; - Name_Finder : constant Name_Id := N + 574; - Name_Global_Configuration_Pragmas : constant Name_Id := N + 575; - Name_Gnatls : constant Name_Id := N + 576; - Name_Gnatstub : constant Name_Id := N + 577; - Name_Implementation : constant Name_Id := N + 578; - Name_Implementation_Exceptions : constant Name_Id := N + 579; - Name_Implementation_Suffix : constant Name_Id := N + 580; - Name_Languages : constant Name_Id := N + 581; - Name_Library_Dir : constant Name_Id := N + 582; - Name_Library_Auto_Init : constant Name_Id := N + 583; - Name_Library_GCC : constant Name_Id := N + 584; - Name_Library_Interface : constant Name_Id := N + 585; - Name_Library_Kind : constant Name_Id := N + 586; - Name_Library_Name : constant Name_Id := N + 587; - Name_Library_Options : constant Name_Id := N + 588; - Name_Library_Reference_Symbol_File : constant Name_Id := N + 589; - Name_Library_Src_Dir : constant Name_Id := N + 590; - Name_Library_Symbol_File : constant Name_Id := N + 591; - Name_Library_Symbol_Policy : constant Name_Id := N + 592; - Name_Library_Version : constant Name_Id := N + 593; - Name_Linker : constant Name_Id := N + 594; - Name_Local_Configuration_Pragmas : constant Name_Id := N + 595; - Name_Locally_Removed_Files : constant Name_Id := N + 596; - Name_Metrics : constant Name_Id := N + 597; - Name_Naming : constant Name_Id := N + 598; - Name_Object_Dir : constant Name_Id := N + 599; - Name_Pretty_Printer : constant Name_Id := N + 600; - Name_Project : constant Name_Id := N + 601; - Name_Separate_Suffix : constant Name_Id := N + 602; - Name_Source_Dirs : constant Name_Id := N + 603; - Name_Source_Files : constant Name_Id := N + 604; - Name_Source_List_File : constant Name_Id := N + 605; - Name_Spec : constant Name_Id := N + 606; - Name_Spec_Suffix : constant Name_Id := N + 607; - Name_Specification : constant Name_Id := N + 608; - Name_Specification_Exceptions : constant Name_Id := N + 609; - Name_Specification_Suffix : constant Name_Id := N + 610; - Name_Switches : constant Name_Id := N + 611; + Name_Binder : constant Name_Id := N + 565; + Name_Body_Suffix : constant Name_Id := N + 566; + Name_Builder : constant Name_Id := N + 567; + Name_Compiler : constant Name_Id := N + 568; + Name_Cross_Reference : constant Name_Id := N + 569; + Name_Default_Switches : constant Name_Id := N + 570; + Name_Exec_Dir : constant Name_Id := N + 571; + Name_Executable : constant Name_Id := N + 572; + Name_Executable_Suffix : constant Name_Id := N + 573; + Name_Extends : constant Name_Id := N + 574; + Name_Finder : constant Name_Id := N + 575; + Name_Global_Configuration_Pragmas : constant Name_Id := N + 576; + Name_Gnatls : constant Name_Id := N + 577; + Name_Gnatstub : constant Name_Id := N + 578; + Name_Implementation : constant Name_Id := N + 579; + Name_Implementation_Exceptions : constant Name_Id := N + 580; + Name_Implementation_Suffix : constant Name_Id := N + 581; + Name_Languages : constant Name_Id := N + 582; + Name_Library_Dir : constant Name_Id := N + 583; + Name_Library_Auto_Init : constant Name_Id := N + 584; + Name_Library_GCC : constant Name_Id := N + 585; + Name_Library_Interface : constant Name_Id := N + 586; + Name_Library_Kind : constant Name_Id := N + 587; + Name_Library_Name : constant Name_Id := N + 588; + Name_Library_Options : constant Name_Id := N + 589; + Name_Library_Reference_Symbol_File : constant Name_Id := N + 590; + Name_Library_Src_Dir : constant Name_Id := N + 591; + Name_Library_Symbol_File : constant Name_Id := N + 592; + Name_Library_Symbol_Policy : constant Name_Id := N + 593; + Name_Library_Version : constant Name_Id := N + 594; + Name_Linker : constant Name_Id := N + 595; + Name_Local_Configuration_Pragmas : constant Name_Id := N + 596; + Name_Locally_Removed_Files : constant Name_Id := N + 597; + Name_Metrics : constant Name_Id := N + 598; + Name_Naming : constant Name_Id := N + 599; + Name_Object_Dir : constant Name_Id := N + 600; + Name_Pretty_Printer : constant Name_Id := N + 601; + Name_Project : constant Name_Id := N + 602; + Name_Separate_Suffix : constant Name_Id := N + 603; + Name_Source_Dirs : constant Name_Id := N + 604; + Name_Source_Files : constant Name_Id := N + 605; + Name_Source_List_File : constant Name_Id := N + 606; + Name_Spec : constant Name_Id := N + 607; + Name_Spec_Suffix : constant Name_Id := N + 608; + Name_Specification : constant Name_Id := N + 609; + Name_Specification_Exceptions : constant Name_Id := N + 610; + Name_Specification_Suffix : constant Name_Id := N + 611; + Name_Switches : constant Name_Id := N + 612; -- Other miscellaneous names used in front end - Name_Unaligned_Valid : constant Name_Id := N + 612; + Name_Unaligned_Valid : constant Name_Id := N + 613; -- Mark last defined name for consistency check in Snames body - Last_Predefined_Name : constant Name_Id := N + 612; + Last_Predefined_Name : constant Name_Id := N + 613; subtype Any_Operator_Name is Name_Id range First_Operator_Name .. Last_Operator_Name; @@ -1178,6 +1179,7 @@ package Snames is Pragma_Compile_Time_Warning, Pragma_Component_Alignment, Pragma_Convention_Identifier, + Pragma_Detect_Blocking, Pragma_Discard_Names, Pragma_Elaboration_Checks, Pragma_Eliminate, diff --git a/gcc/ada/snames.h b/gcc/ada/snames.h index 29caf0e..d14d927 100644 --- a/gcc/ada/snames.h +++ b/gcc/ada/snames.h @@ -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. */ diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb index 30d5d43..8c2aa58 100644 --- a/gcc/ada/stylesw.adb +++ b/gcc/ada/stylesw.adb @@ -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; diff --git a/gcc/ada/stylesw.ads b/gcc/ada/stylesw.ads index 862f026..435b31b 100644 --- a/gcc/ada/stylesw.ads +++ b/gcc/ada/stylesw.ads @@ -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); diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 42b0a16..391347a 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -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 => diff --git a/gcc/ada/switch.adb b/gcc/ada/switch.adb index f01e308..c1c5c51 100644 --- a/gcc/ada/switch.adb +++ b/gcc/ada/switch.adb @@ -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 diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index 6918d99..7be260b 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -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 diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index 48c1469..d7a2514 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -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. diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index 991550a..9c62192 100644 --- a/gcc/ada/tracebak.c +++ b/gcc/ada/tracebak.c @@ -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 --* diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index b5903da..deda649 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -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"); diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 43b4fe4..bf236ae 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -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, diff --git a/gcc/ada/xtreeprs.adb b/gcc/ada/xtreeprs.adb index e3a9518..2e026d1 100644 --- a/gcc/ada/xtreeprs.adb +++ b/gcc/ada/xtreeprs.adb @@ -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 (" "); |