diff options
89 files changed, 4910 insertions, 3187 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e1464ed319c..38108d94cf4 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 7ecd218461b..a758e523c7c 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 97544297887..84d12a62ba9 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 0d0eb094759..41fb21d7f3c 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 c7c526eb32f..cddf9a8217c 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 689a22a1d0b..3a08392256f 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 31a966cb797..41cedea3b34 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 92573fd46d5..bf6454ea8b3 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 565cf534add..b9c4004df6b 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 53f82d0d416..4a3895044a3 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 61f2018270c..3782c75bcca 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 df32596a942..b45279f9cce 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 7327be8b246..ca5d69d7d40 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 1eddfd30b29..1eab6ef7c9e 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 d59e0b942ac..e0d5f7cb585 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 951d272f54a..1842996362e 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 63026d9f2ad..e541758e05a 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 6b4ced731c9..dd8b095822a 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 b86d353ea6a..364b4d7664c 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 e38bcce3baf..e90c491b554 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 fd3e92e9e07..a688564ad11 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 bb4b3f93e24..6e2d1267637 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 0d458f49b0d..1ac0e56050a 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 48963fbf40b..a3d63d90ae8 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 761e480f835..c7ad39481f5 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 3ff38b0fa22..aa899d93179 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 17daf356721..c3753d19cd7 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 2b5ff0801f3..ff9358d2d79 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 0352d7c05cb..3a0e5e4a7f1 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 41ef0a20929..ef35b931f13 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 1e491f2a7d3..30356057151 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 9d79b6c3c0e..9fe4aa13239 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 1de5f4e134e..7b6aa524a70 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 722f5630c35..e64db771b5b 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 f0f09ef0944..9ec0278680f 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 7035854e0cd..0f3fc50d83d 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 5947f19825d..d818ff25423 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 97dee952dc6..8cce3e8d8ce 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 c95d64893a4..033ca6a90ff 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 4eb2934cb51..f295b3810b9 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 c18819918dd..2f09a14d38b 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 00ab3928b79..7901f637c3e 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 a47ff42c136..79aeab59066 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 ac5e4b937fe..d40928500c8 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 2474da3ea84..13417e8d2d4 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 b3b71722fb6..285f2bd2f55 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 5ce66cce12e..e279a51fb17 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 9fa24c5646d..6eaa882b924 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 dc137737257..c18dec8caf1 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 5d142ae9a5c..971325ff544 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 0bd4336e53b..0e9f7c4778f 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 112170b200c..c07c39b7882 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 508877cafb6..19d9130dd9a 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 b8e3fc7bf02..a736641a65c 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 c87b7e3f722..6ae47557e22 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 8c89aae9af5..aaf45ac7fab 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 9d034a12dc5..7cc17fddf81 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 55523435f4f..747e7f8248a 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 0edac399d6b..d742bbf28fc 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 2d7c61a057d..77f39370d55 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 720ad257a83..b36ee59bed4 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 00000000000..d77ebdbcca1 --- /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 f0fbc493572..409adc66c0f 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 7d7299f4970..049a63d42a5 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 f7aa92ba548..4e04afc3277 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 31ddc659dba..b8f30017ce4 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 69e324b0a7f..2030b3020a3 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 3abdffb8073..cc573ef154a 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 ea0991faa29..a85d8c5ddca 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 78aceb63e20..ea64e37a592 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 bdd3d53d646..3c6eacfa84b 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 c48361092fe..aee306dd1d6 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 404ba58294d..0945a4dbc7d 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 0d8c1e1861e..e4689a67e35 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 04853f28f1d..84f22c550aa 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 fb085cd7008..90f388dc745 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 272801b35b1..2e2aeb58a44 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 153ea275fc6..bcd57939ea5 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 29caf0e28b1..d14d9279ed3 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 30d5d43471d..8c2aa58d08e 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 862f0262ce5..435b31b038a 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 42b0a16c940..391347a0c22 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 f01e3081080..c1c5c51a0f2 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 6918d990c3b..7be260b9738 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 48c1469b25d..d7a25148e39 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 991550ad540..9c621929d1a 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 b5903da0190..deda649effb 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 43b4fe46859..bf236aebca7 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 e3a9518c889..2e026d10163 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 (" "); |
