+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.
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
$(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= \
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 \
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;
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.
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
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 --
------------
-- 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;
procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
Removed : Boolean;
-
begin
Removed := Remove (Get_Current_Excep.all, GCC_Exception);
pragma Assert (Removed);
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 --
---------------------
-- 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
-- --
-- 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- --
----------
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;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
-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;
-- --
-- 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 --
package Ada.Strings.Maps is
pragma Preelaborate (Maps);
- package L renames Ada.Characters.Latin_1;
-
--------------------------------
-- Character Set Declarations --
--------------------------------
type Character_Mapping_Function is
access function (From : in Character) return Character;
- ------------------
- -- Private Part --
- ------------------
-
private
pragma Inline (Is_In);
pragma Inline (Value);
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
&& ! 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
-- 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);
-- 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!
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,
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;
----------------------------
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;
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.
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 --
---------------------
Index2 : Int;
Lib_File : File_Name_Type;
+ Source_Id : Other_Source_Id;
+ Source : Other_Source;
+
+ Global_Archive : Boolean := False;
+
use Prj.Com;
begin
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.
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);
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 &
Set_Etype (First_Entity (Standard_Op_Concatw), Standard_Wide_String);
Set_Etype (Last_Entity (Standard_Op_Concatw), Standard_Wide_String);
-
end Create_Operators;
---------------------
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
-- 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 --
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);
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);
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));
-- 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
-- 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)
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;
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);
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);
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);
raise Program_Error;
end if;
- -- Name in assignment is explicit dereference.
+ -- Name in assignment is explicit dereference
Target := New_Copy (Tmp);
end if;
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)
-- 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
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)),
-- 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
-- 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;
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;
-- 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!
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 --
---------------------------
(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;
-----------------------
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),
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),
-- 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'));
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;
-- 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
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;
-- 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,
return;
end if;
+ -- Handle case of qualified expression (other than optimization above)
+
if Nkind (Expression (N)) = N_Qualified_Expression then
Expand_Allocator_Expression (N);
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;
-- 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;
-- 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
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
-- 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
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;
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;
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;
-------------------------------
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;
Var := Make_Var (Expression (Actual));
Crep := not Same_Representation
- (Etype (Formal), Etype (Expression (Actual)));
+ (F_Typ, Etype (Expression (Actual)));
else
V_Typ := Etype (Actual);
-- 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
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 (
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
-- --
-- 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- --
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
-- 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
-- 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
-- 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
-- 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
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
--------------------------------------------
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;
-- 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
-- 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;
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;
---------------------------------
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.
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;
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;
begin
Index := First_Index (T);
-
while Present (Index) loop
if Nkind (Index) = N_Range then
Get_Index_Bounds (Index, Low, High);
-------------------------------------
function Static_Discriminated_Components
- (T : Entity_Id)
- return Boolean
+ (T : Entity_Id) return Boolean
is
Constraint : Elmt_Id;
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
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);
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;
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);
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))
-- 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);
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
------------------------------------------------------------------------------
-- 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
-- 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;
-- 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).
-- 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;
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
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
-- 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;
(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;
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;
(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;
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;
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);
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;
is
Junk : Process_Id;
Result : Integer;
-
begin
Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
return Result;
-- --
-- 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- --
-- 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
-- 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
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
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;
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
@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}
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
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;
@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}
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;
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
-- 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.
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);
-- 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 --
-------------------------------
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;
-----------
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 --
---------------------
new String'(Get_Name_String
(Projects.Table (Project).Library_Dir));
end if;
-
end if;
end Set_Library_For;
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;
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;
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
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;
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;
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
-- 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)
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;
-- 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;
-- 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;
-- 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);
-- 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
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
-- 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;
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;
/* 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
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} \
package body Lib is
+ Switch_Storing_Enabled : Boolean := True;
+ -- Set to False by Disable_Switch_Storing
+
-----------------------
-- Local Subprograms --
-----------------------
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 --
------------------------------
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;
-- 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.
-- 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.
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
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 --
-----------------------------------
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;
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
-- 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
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;
-- 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;
-- 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,
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
-- 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;
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
-- 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;
when X : others =>
Write_Line (Exception_Information (X));
Make_Failed ("INTERNAL ERROR. Please report.");
-
end Gnatmake;
----------
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;
-- 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;
-- 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;
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
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
-- 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
-- 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
-- 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);
(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
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;
-- 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
-- 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
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
-- 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
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) :=
-- 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
end if;
Last_Source := Last_Source + 1;
- Source_Indexes (Last_Source) := (Id, False);
+ Source_Indexes (Last_Source) := (Project, Id, False);
end Add_Source_Id;
----------------------------
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;
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;
"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
if not Need_To_Rebuild then
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;
if Source_Id = No_Other_Source then
Need_To_Rebuild := True;
+
if Verbose_Mode then
Write_Str (" -> ");
Write_Str (Get_Name_String (Object_Name));
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.
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;
-
- -- Create fake empty archive, so we can check its time stamp later
-
- declare
- Archive : Ada.Text_IO.File_Type;
- use Ada.Text_IO;
- begin
- Create (Archive, Out_File, Archive_Name);
- Close (Archive);
- end;
-
- 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);
+ end if;
+ end if;
- exit when not Success;
+ -- Create fake empty archive, so we can check its time stamp later
- exit when Last_Argument = Saved_Last_Argument;
+ declare
+ Archive : Ada.Text_IO.File_Type;
+ use Ada.Text_IO;
+ begin
+ Create (Archive, Out_File, Archive_Name);
+ Close (Archive);
+ end;
- 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;
+ Create_Archive_Dependency_File
+ (Archive_Dep_Name, Data.First_Other_Source);
- if Success then
+ end if;
+ end Build_Library;
- -- If the archive was built, run the archive indexer (ranlib),
- -- if there is one.
+ -----------
+ -- Check --
+ -----------
- if Archive_Indexer_Path /= null then
- Last_Argument := 0;
- Add_Argument (Archive_Name, True);
+ procedure Check (Option : String) is
+ First : Positive := Option'First;
+ Last : Natural;
- Display_Command (Archive_Indexer, Archive_Indexer_Path);
+ 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;
- Spawn (Archive_Indexer_Path.all, Arguments (1 .. 1), Success);
+ Write_Char ('"');
+ Write_Str (Option (First .. Last - 1));
+ Write_Char ('"');
- if not Success then
+ while Last <= Option'Last and then Option (Last) = ' ' loop
+ Last := Last + 1;
+ end loop;
- -- Running ranlib failed, delete the dependency file,
- -- if it exists.
+ First := Last;
- if Is_Regular_File (Archive_Dep_Name) then
- Delete_File (Archive_Dep_Name, Success);
- end if;
+ else
+ if Last = Option'Last then
+ if First /= Option'First then
+ Write_Str (", ");
+ end if;
- -- And report the error
+ Write_Char ('"');
+ Write_Str (Option (First .. Last));
+ Write_Char ('"');
+ end if;
- 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 --
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;
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
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
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
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
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
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);
-- 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;
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);
Other_Sources.Table (Source_Id) := Source;
end if;
+ -- Compilation failed
+
else
Local_Errors := True;
Report_Error
begin
Ada_Mains.Init;
-
To_Mixed (Project_Name);
-
Compile_Only := True;
Get_Imported_Directories (Main_Project, Data);
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;
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
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
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
Add_Argument (Output_File_Name, True);
end if;
- -- Transmit to gnatmake some switches
+ -- Transmit some switches to gnatmake
-- -c
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);
-- 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;
-- 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
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;
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);
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 --
---------------------
-- 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
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);
end if;
end Recursive_Get_Dirs;
+ -- Start of processing for Get_Imported_Directories
+
begin
-- First, mark all project as not processed
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,
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;
-- 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;
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 --
----------------------
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 --
---------------------------------------
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 --
-------------------------------------
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
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.
-- 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
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;
-- 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;
loop
declare
- Main : constant String := Mains.Next_Main;
+ Main : constant String := Mains.Next_Main;
Main_Id : Name_Id;
+
begin
exit when Main'Length = 0;
for Main in 1 .. Other_Mains.Last loop
declare
Source : constant Other_Source := Other_Mains.Table (Main);
+
begin
Last_Argument := 0;
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;
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;
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;
Write_Str (S3);
Write_Eol;
- else
- -- Otherwise, just fail
+ -- Otherwise just fail
+ else
Osint.Fail (S1, S2, S3);
end if;
end Report_Error;
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
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
-- -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;
if OK then
Current_Processor := Compiler;
-
else
Osint.Fail ("illegal option """, Arg, """");
end if;
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'
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;
-----------------
function Strip_CR_LF (Text : String) return String is
-
- To : String (1 .. Text'Length);
+ To : String (1 .. Text'Length);
Index_To : Natural := 0;
begin
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;
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 =>
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" &
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 --
-------------
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" &
end if;
end Build_Dynamic_Library;
- -------------------------
- -- Default_DLL_Address --
- -------------------------
-
- function Default_DLL_Address return String is
- begin
- return "";
- end Default_DLL_Address;
-
-------------
-- DLL_Ext --
-------------
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" &
end if;
end Build_Dynamic_Library;
- -------------------------
- -- Default_DLL_Address --
- -------------------------
-
- function Default_DLL_Address return String is
- begin
- return "";
- end Default_DLL_Address;
-
-------------
-- DLL_Ext --
-------------
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" &
end if;
end Build_Dynamic_Library;
- -------------------------
- -- Default_DLL_Address --
- -------------------------
-
- function Default_DLL_Address return String is
- begin
- return "";
- end Default_DLL_Address;
-
-------------
-- DLL_Ext --
-------------
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 (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 --
-------------
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" &
end if;
end Build_Dynamic_Library;
- -------------------------
- -- Default_DLL_Address --
- -------------------------
-
- function Default_DLL_Address return String is
- begin
- return "";
- end Default_DLL_Address;
-
-------------
-- DLL_Ext --
-------------
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" &
end if;
end Build_Dynamic_Library;
- -------------------------
- -- Default_DLL_Address --
- -------------------------
-
- function Default_DLL_Address return String is
- begin
- return "";
- end Default_DLL_Address;
-
-------------
-- DLL_Ext --
-------------
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" &
end if;
end Build_Dynamic_Library;
- -------------------------
- -- Default_DLL_Address --
- -------------------------
-
- function Default_DLL_Address return String is
- begin
- return "";
- end Default_DLL_Address;
-
-------------
-- DLL_Ext --
-------------
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" &
end if;
end Build_Dynamic_Library;
- -------------------------
- -- Default_DLL_Address --
- -------------------------
-
- function Default_DLL_Address return String is
- begin
- return "";
- end Default_DLL_Address;
-
-------------
-- DLL_Ext --
-------------
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);
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 --
-------------
-- --
-- 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- --
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);
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 --
-------------
-- 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".
-- 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
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
--
--
-- 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.
--
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
-- 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
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
Pragma_Component_Alignment |
Pragma_Controlled |
Pragma_Convention |
+ Pragma_Detect_Blocking |
Pragma_Discard_Names |
Pragma_Eliminate |
Pragma_Elaborate |
-- --
------------------------------------------------------------------------------
-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;
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;
else
return False;
end if;
-
end Bad_Spelling_Of;
----------------------
procedure Discard_Junk_List (L : List_Id) is
pragma Warnings (Off, L);
-
begin
null;
end Discard_Junk_List;
procedure Discard_Junk_Node (N : Node_Id) is
pragma Warnings (Off, N);
-
begin
null;
end Discard_Junk_Node;
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;
-- 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));
-- 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;
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;
-- 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;
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
-- 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
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);
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.
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
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
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
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
-- 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 --
-- 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
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
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
-- No sources of languages other than Ada
- Data.Sources_Present := False;
+ Data.Other_Sources_Present := False;
else
declare
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
-- than Ada.
if Lang /= Lang_Ada then
- Data.Sources_Present := True;
+ Data.Other_Sources_Present := True;
end if;
exit Lang_Loop;
-- 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
(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;
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
(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;
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 :=
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);
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;
(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;
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
-- 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;
-- 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;
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
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;
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,
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
-- 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.
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;
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
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;
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;
*/
-/* 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
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
{
if (action.kind == cleanup)
{
- gnat_exception->n_cleanups_to_trigger ++;
+ Adjust_N_Cleanups_For (gnat_exception, 1);
return _URC_CONTINUE_UNWIND;
}
else
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);
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;
--------------------
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
-- pragma Dispatching_Policy (FIFO_Within_Priorities);
-- pragma Locking_Policy (Ceiling_Locking);
- -- pragma Detect_Blocking_Mode ???
+ -- pragma Detect_Blocking
Ravenscar =>
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),
-- 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;
--------------------
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;
-- 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
-- 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
-- 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
-- --
-- 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- --
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
-- 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
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
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
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
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
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.
-- 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);
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;
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
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);
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
-- 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;
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
-- 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;
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;
-- --
-- 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- --
-- 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.
-- 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
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;
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
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;
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,
-- 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
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;
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
-- 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)
end if;
end if;
- -- ??? Detect_Blocking
+ -- pragma Detect_Blocking
+
+ Detect_Blocking := True;
-- Set the corresponding restrictions
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 --
-------------------
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,
-- 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
-- --
-- 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- --
-- 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
-- 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
-- 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.
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
"compile_time_warning#" &
"component_alignment#" &
"convention_identifier#" &
+ "detect_blocking#" &
"discard_names#" &
"elaboration_checks#" &
"eliminate#" &
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
-- 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
-- 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
-- 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
-- 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
-- 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.
-- 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
-- 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;
Pragma_Compile_Time_Warning,
Pragma_Component_Alignment,
Pragma_Convention_Identifier,
+ Pragma_Detect_Blocking,
Pragma_Discard_Names,
Pragma_Elaboration_Checks,
Pragma_Eliminate,
#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. */
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;
------------------------------
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
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
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);
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;
-------------------------------------
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;
-- --
-- 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- --
-- 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.
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 --
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);
return;
+ when 'z' =>
+ Store_Switch := False;
+ Disable_Switch_Storing;
+ Ptr := Ptr + 1;
+
-- All other -gnate? switches are unassigned
when others =>
-- --
-- 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- --
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;
---------------
(Switch_Chars : String;
Max : Integer;
Ptr : in out Integer;
- Result : out Pos) is
-
+ Result : out Pos)
+ is
Temp : Nat;
begin
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
-- 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.
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
/*------------------------------ PPC AIX -------------------------------*/
#if defined (_AIX)
+
+#define USE_GENERIC_UNWINDER
+
struct layout
{
struct layout *next;
/*---------------------------- PPC VxWorks------------------------------*/
#elif defined (_ARCH_PPC) && defined (__vxworks)
+
+#define USE_GENERIC_UNWINDER
+
struct layout
{
struct layout *next;
#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. */
/*------------------------------- x86 ----------------------------------*/
#elif defined (i386)
+
+#define USE_GENERIC_UNWINDER
+
struct layout
{
struct layout *next;
|| ((*((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; })
}
#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 --*
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");
-- 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
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,
-- 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 " &
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,
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 " &
"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" & '"';
-- 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 " &
"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 " &
"-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 " &
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 " &
"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,
-- 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
-- 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
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,
-- --
-- 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- --
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 (" ");
OSDN Git Service
