gprbuild-gpl-2014-src/ 0000755 0000767 0000145 00000000000 12323721732 014134 5 ustar gnatmail gnat gprbuild-gpl-2014-src/known-problems-130 0000644 0000767 0000145 00000010726 11267625216 017351 0 ustar gnatmail gnat ========================================
Known problems in GPRBUILD version 1.3.0
========================================
Copyright (c) 2009, AdaCore
The following is a listing of known problems in release 1.3.0. Except where
specifically noted, all these problems have been corrected in the development
tree of the 1.4 technology. This means they are corrected in any 1.3.0w
wavefront issued subsequent to the date specified (in ISO format YYYY-MM-DD) in
the status line. This can be used to determine if a given wavefront has the fix
identified in the entry.
KP-130-IA09-020 Wrong run path option for shared libs on Darwin
Problem: On Darwin, where there should be one run path option per
directory, a single run path option for all the directory is
issued when linking a shared library.
Status: This was fixed in 1.4.0 on 2009-10-09
Workaround: Use static libraries
KP-130-IA01-027 Incorrect linking of shared library on Windows
Problem: When gprbuild is invoked with --unchecked-shared-lib-imports
and a shared library imports a static ibrary, the linking of
the shared library may fail in Windows with undefined references.
Status: This was fixed in 1.4.0 on 2009-10-02
Workaround: Add the necessary Library_Options
KP-130-I904-011 Incorrect compilation in extending projects
Problem: gprbuild incorrectly compiles up to date inherited sources
in extending projects and does not recompile non up-to-date
sources in projects extending externally built projects.
Status: This was fixed in 1.4.0 on 2009-09-05
Workaround: Make the project being extended not externally built.
KP-130-I828-007 Crash when using attribute Included_Switches
Problem: When there are several languages in a project files and for
one of these languages attribute Included_Switches is declared,
gprbuild may crash.
Status: This was fixed in 1.4.0 on 2009-08-29
Workaround: Use one project file for each language
KP-130-I828-004 Failure to bind with a cross with no prefix
Problem: When a cross-compiler with no prefix is used, gprbind fails as
it does not recognize "gnatbind_prefix=" as a special option.
Status: This was fixed in 1.4.0 on 2009-09-01
Workaround: Remove the lines in package Binder of the configuration project
file that specify the option "gnatbind_prefix=".
KP-130-I722-017 Systematic binding and linking when using extending projects
Problem: If you are using extending projects, gprbuild will systematically
bind and link your application, even when everything is up to
date.
Status: This was fixed in 1.4.0 on 2009-07-21
Workaround: The compilation still performs correctly, and is just a bit
slower
KP-130-I713-011 gprclean does not remove binder files
Problem: When the main unit's name is less than 3 characters long,
gprclean does not remove the binder generated files (b__*.ads,
b__*.adb and *.bexch files)
Status: This was fixed in 1.4.0 on 2009-07-13
Workaround: Remove the files manually.
KP-130-I525-017 gprbuild incompatible with option -r of gnatbind
Problem: When a binder option such as -r that adds output to the
invocation of gnatbind is used, linking fails.
Status: This was fixed in 1.4.0 on 2009-08-12
Workaround: Remove binder option -r
KP-130-I507-019 Spec not compiled when body has been excluded
Problem: When the body of a spec has been locally removed, the spec that
does not need a completion is not compiled.
Status: This was fixed in 1.4.0 on 2009-05-19
Workaround: Use a spec with a dummy completion and a dummy body
KP-130-I505-015 Extending library project not built
Problem: When gprbuild is invoked for a library project that extends
another one, the library may not be built.
Status: This was fixed in 1.4.0 on 2009-05-06
Workaround: Use only non extending library projects
KP-130-I421-020 First compiler on the path not automatically used
Problem: If the directory where gprbuild resides is not first on the path,
compilers that are in front of this directory in the path will
not be chosen in autoconfiguration.
Status: This was fixed in 1.4.0 on 2009-09-08
Workaround: Create a configuration project file using gprconfig before
invoking gprbuild.
gprbuild-gpl-2014-src/obj-debug/ 0000755 0000767 0000145 00000000000 12317234544 015775 5 ustar gnatmail gnat gprbuild-gpl-2014-src/share/ 0000755 0000767 0000145 00000000000 12317234545 015242 5 ustar gnatmail gnat gprbuild-gpl-2014-src/share/_default.gpr 0000644 0000767 0000145 00000000051 12323721731 017526 0 ustar gnatmail gnat standard project Default is
end Default;
gprbuild-gpl-2014-src/share/gprconfig/ 0000755 0000767 0000145 00000000000 12317234545 017220 5 ustar gnatmail gnat gprbuild-gpl-2014-src/share/gprconfig/asm.xml 0000644 0000767 0000145 00000003406 11452363313 020520 0 ustar gnatmail gnat
package Naming is
for Body_Suffix ("Asm_Cpp") use ".S";
end Naming;
package Compiler is
for Driver ("Asm_Cpp") use "${PATH(asm_cpp)}${PREFIX(asm_cpp)}gcc";
for Leading_Required_Switches ("Asm_Cpp") use
Compiler'Leading_Required_Switches ("Asm_Cpp") &
("-c", "-x", "assembler-with-cpp");
for Include_Path ("Asm_Cpp") use "CPATH";
end Compiler;
package Naming is
for Body_Suffix ("Asm") use ".s";
end Naming;
package Compiler is
for Driver ("Asm") use "${PATH(asm)}${PREFIX(asm)}gcc";
for Leading_Required_Switches ("Asm") use
Compiler'Leading_Required_Switches ("Asm") &
("-c", "-x", "assembler");
for Include_Path ("Asm") use "CPATH";
end Compiler;
package Naming is
for Body_Suffix ("Asm2") use ".asm";
end Naming;
package Compiler is
for Driver ("Asm2") use "${PATH(asm2)}${PREFIX(asm2)}gcc";
for Leading_Required_Switches ("Asm2") use
Compiler'Leading_Required_Switches ("Asm2") &
("-c", "-x", "assembler");
for Include_Path ("Asm2") use "CPATH";
end Compiler;
gprbuild-gpl-2014-src/share/gprconfig/linker.xml 0000644 0000767 0000145 00000111377 12277050514 021235 0 ustar gnatmail gnat
for Archive_Builder use ("lmp-elf-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("lmp-elf-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("powerpc-elf-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("powerpc-elf-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("ar", "crs");
for Archive_Builder_Append_Option use ("q");
for Archive_Suffix use ".a";
for Archive_Builder use ("powerpc-xcoff-lynxos178-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("powerpc-xcoff-lynxos178-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("powerpc-eabispe-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("powerpc-eabispe-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("i686-elinos-linux-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("i686-elinos-linux-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("i686-pc-mingw32-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("i686-pc-mingw32-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("x86_64-pc-mingw32-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("x86_64-pc-mingw32-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("powerpc-elinos-linux-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("powerpc-elinos-linux-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("arm-linux-androideabi-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("arm-linux-androideabi-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("arm-linux-gnueabi-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("arm-linux-gnueabi-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("erc32-elf-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("erc32-elf-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("leon-elf-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("leon-elf-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("leon3-elf-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("leon3-elf-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("arm-eabi-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("arm-eabi-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("avr-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("avr-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("i586-sysgo-pikeos-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("i586-sysgo-pikeos-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Suffix use ".a";
package Linker is
for Max_Command_Line_Length use "15000";
for Response_File_Format use "object_list";
for Response_File_Switches use ("-Wl,-f,");
for Map_File_Option use "-Wl,-b,map:";
end Linker;
for Archive_Builder use ("e500v2-wrs-vxworks-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("e500v2-wrs-vxworks-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("e500v2-wrs-vxworksae-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("e500v2-wrs-vxworksae-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("e500v2-wrs-vxworksmils-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("e500v2-wrs-vxworksmils-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("i586-wrs-vxworks-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("i586-wrs-vxworks-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("i586-wrs-vxworksae-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("i586-wrs-vxworksae-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("arm-wrs-vxworks-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("arm-wrs-vxworks-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("powerpc-wrs-vxworks-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("powerpc-wrs-vxworks-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("leon-wrs-vxworks-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("leon-wrs-vxworks-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("powerpc-wrs-vxworksae-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("powerpc-wrs-vxworksae-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("powerpc-wrs-vxworksmils-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("powerpc-wrs-vxworksmils-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Suffix use ".a";
for Archive_Builder use ("ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("powerpc-wrs-linux-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("powerpc-wrs-linux-ranlib");
for Archive_Suffix use ".a";
for Archive_Builder use ("e500v2-wrs-linux-ar", "cr");
for Archive_Builder_Append_Option use ("q");
for Archive_Indexer use ("e500v2-wrs-linux-ranlib");
for Archive_Suffix use ".a";
package Linker is
for Driver use Compiler'Driver ("Ada");
end Linker;
for Library_Support use "static_only";
for Library_Builder use "${GPRCONFIG_PREFIX}libexec/gprbuild/gprlib";
for Library_Support use "none";
package Linker is
for Driver use "aa_link";
end Linker;
for Library_Support use "none";
package Linker is
for Driver use "dotnet-ld";
end Linker;
for Library_Builder use "${GPRCONFIG_PREFIX}libexec/gprbuild/gprlib";
for Library_Support use "full";
for Shared_Library_Prefix use "lib";
for Symbolic_Link_Supported use "true";
for Library_Major_Minor_Id_Supported use "true";
for Run_Path_Option use ("-Wl,-rpath,");
for Separate_Run_Path_Options use "true";
for Run_Path_Origin use "@executable_path";
for Library_Install_Name_Option use "-Wl,-install_name,@rpath";
for Shared_Library_Suffix use ".dylib";
for Library_Auto_Init_Supported use "true";
for Archive_Indexer use project'Archive_Indexer & ("-c");
for Shared_Library_Minimum_Switches use
("-dynamiclib", "-shared-libgcc");
for Library_Encapsulated_Options use ("-shared", "-static-libgcc");
package Linker is
for Map_File_Option use "-Wl,-map,";
end Linker;
for Library_Rpath_Options ("C++") use ("-print-file-name=libstdc++.dylib");
for Library_Builder use "${GPRCONFIG_PREFIX}libexec/gprbuild/gprlib";
for Library_Support use "full";
for Shared_Library_Prefix use "lib";
for Symbolic_Link_Supported use "true";
for Library_Major_Minor_Id_Supported use "true";
for Shared_Library_Minimum_Switches use ("-shared", "-fPIC");
for Library_Version_Switches use ("-Wl,-soname,");
for Shared_Library_Suffix use ".sl";
for Library_Auto_Init_Supported use "true";
for Run_Path_Option use ("-Wl,+b,");
for Library_Partial_Linker use ("gcc", "-nostdlib", "-Wl,-r", "-o");
package Linker is
for Max_Command_Line_Length use "5000";
for Response_File_Format use "object_list";
for Response_File_Switches use ("-Wl,-c,");
end Linker;
for Shared_Library_Suffix use ".so";
for Library_Version_Switches use ("-Wl,+h,");
for Library_Builder use "${GPRCONFIG_PREFIX}libexec/gprbuild/gprlib";
for Library_Support use "full";
for Shared_Library_Prefix use "lib";
for Symbolic_Link_Supported use "true";
for Library_Major_Minor_Id_Supported use "true";
for Shared_Library_Minimum_Switches use ("-shared");
for Library_Version_Switches use ("-Wl,-soname,");
for Shared_Library_Suffix use ".so";
for Library_Auto_Init_Supported use "true";
for Run_Path_Option use ("-Wl,-z,origin,-rpath,");
for Run_Path_Origin use "$$ORIGIN";
for Library_Encapsulated_Options use ("-shared", "-static-libgcc");
package Linker is
for Map_File_Option use "-Wl,-Map,";
end Linker;
for Library_Partial_Linker use ("${PATH(ada)}${PREFIX(ada)}gcc", "-nostdlib", "-Wl,-r", "-o");
for Library_Partial_Linker use ("${PATH(ada)}${PREFIX(c)}gcc", "-nostdlib", "-Wl,-r", "-o");
for Library_Rpath_Options ("C++") use ("-print-file-name=libstdc++.so");
for Run_Path_Option use ("-Wl,-rpath,");
for Run_Path_Option use ("-Wl,-rpath,");
package Linker is
for Max_Command_Line_Length use "5000";
for Response_File_Format use "object_list";
for Response_File_Switches use ("-Wl,-objectlist,");
end Linker;
for Library_Builder use "${GPRCONFIG_PREFIX}libexec/gprbuild/gprlib";
for Library_Support use "full";
for Shared_Library_Prefix use "lib";
for Symbolic_Link_Supported use "true";
for Library_Major_Minor_Id_Supported use "true";
for Shared_Library_Minimum_Switches use ("-shared");
for Library_Version_Switches use ("-Wl,-h,");
for Shared_Library_Suffix use ".so";
for Library_Auto_Init_Supported use "true";
for Library_Encapsulated_Options use
("-shared", "-static-libgcc", "-mimpure-text");
for Run_Path_Option use ("-Wl,-z,origin,-R,");
for Run_Path_Origin use "$$ORIGIN";
for Library_Partial_Linker use ("gcc", "-nostdlib", "-Wl,-r", "-o");
for Library_Rpath_Options ("C++") use ("-print-file-name=libstdc++.so");
for Library_Builder use "${GPRCONFIG_PREFIX}libexec/gprbuild/gprlib";
for Library_Support use "full";
for Shared_Library_Prefix use "lib";
for Symbolic_Link_Supported use "false";
for Library_Major_Minor_Id_Supported use "false";
for Shared_Library_Minimum_Switches use ("-shared", "-shared-libgcc");
for Library_Version_Switches use ("-Wl,-soname,");
for Shared_Library_Suffix use ".dll";
for Library_Encapsulated_Options use ("-shared", "-static-libgcc");
for Library_Auto_Init_Supported use "true";
for Library_Partial_Linker use ("gcc", "-nostdlib", "-Wl,-r", "-o");
package Linker is
for Map_File_Option use "-Wl,-Map,";
end Linker;
for Library_Builder use "${GPRCONFIG_PREFIX}libexec/gprbuild/gprlib";
for Library_Support use "full";
for Shared_Library_Prefix use "lib";
for Symbolic_Link_Supported use "true";
for Library_Major_Minor_Id_Supported use "true";
for Shared_Library_Minimum_Switches use
("-shared", "-Wl,-expect_unresolved,*");
for Library_Version_Switches use ("-Wl,-soname,");
for Shared_Library_Suffix use ".so";
for Library_Auto_Init_Supported use "true";
for Run_Path_Option use ("-Wl,-rpath,");
package Linker is
for Max_Command_Line_Length use "10000";
for Response_File_Format use "object_list";
for Response_File_Switches use ("-Wl,-input,");
end Linker;
for Library_Builder use "${GPRCONFIG_PREFIX}libexec/gprbuild/gprlib";
for Library_Support use "full";
for Shared_Library_Prefix use "lib";
for Shared_Library_Suffix use ".exe";
for Symbolic_Link_Supported use "false";
for Library_Major_Minor_Id_Supported use "false";
for Shared_Library_Minimum_Switches use ("-shared", "-shared-libgcc");
for Library_Auto_Init_Supported use "true";
package Linker is
for Required_Switches use ("-mno-cygwin");
end Linker;
package Linker is
for Driver use Compiler'Driver ("C++");
end Linker;
package Linker is
for Driver use Compiler'Driver ("C++");
end Linker;
package Linker is
for Required_Switches use Linker'Required_Switches & ("-shared-libgcc");
end Linker;
package Linker is
for Driver use Compiler'Driver ("Fortran");
end Linker;
package Linker is
for Driver use Compiler'Driver ("Ada");
end Linker;
package Linker is
for Driver use Compiler'Driver ("C");
end Linker;
package Linker is
for Driver use Compiler'Driver ("Ada");
end Linker;
package Linker is
for Driver use Compiler'Driver ("Ada");
end Linker;
package Linker is
for Driver use Compiler'Driver ("C");
end Linker;
package Linker is
for Required_Switches use
Linker'Required_Switches
& ("-L" & Wind_Base
& "/target/lib/usr/lib/ppc/PPC32/common",
"-L" & Wind_Base
& "/target/usr/lib/ppc/PPC32/common");
end Linker;
package Linker is
for Required_Switches use
Linker'Required_Switches
& ("-L" & Wind_Base
& "/target/lib_smp/usr/lib/ppc/PPC32/common");
end Linker;
package Linker is
for Required_Switches use
Linker'Required_Switches
& ("-L" & Wind_Base
& "/target/lib_smp/usr/lib/arm/ARMARCH7/common");
end Linker;
package Linker is
for Required_Switches use
Linker'Required_Switches
& ("-L" & Wind_Base
& "/target/lib/usr/lib/ppc/PPC32/e500v2common",
"-L" & Wind_Base
& "/target/usr/lib/ppc/PPC32/e500v2common");
end Linker;
package Linker is
for Required_Switches use
Linker'Required_Switches
& ("-L" & Wind_Base
& "/target/lib_smp/usr/lib/ppc/PPC32/e500v2common");
end Linker;
package Linker is
for Required_Switches use
Linker'Required_Switches
& ("-L" & Wind_Base
& "/target/usr/lib_cert_rtp/ppc/PPC32/common");
end Linker;
package Linker is
for Required_Switches use
Linker'Required_Switches
& ("-L" & Wind_Base
& "/target/usr/lib_cert_rtp/ppc/PPC32/e500v2common");
end Linker;
package Linker is
for Driver use Compiler'Driver ("C");
end Linker;
package Linker is
for Response_File_Format use "GCC_GNU";
for Max_Command_Line_Length use "8192";
end Linker;
package Linker is
for Response_File_Format use "GNU";
for Max_Command_Line_Length use "8192";
end Linker;
package Linker is
for Response_File_Format use "GNU";
for Max_Command_Line_Length use "8192";
end Linker;
package Linker is
for Response_File_Format use "GCC_Object_List";
end Linker;
for Default_Language use "Ada";
for Default_Language use "C";
for Default_Language use "Fortran";
for Default_Language use "C++";
gprbuild-gpl-2014-src/share/gprconfig/fortran.xml 0000644 0000767 0000145 00000004504 11452321006 021404 0 ustar gnatmail gnat
package Naming is
for Body_Suffix ("Fortran") use ".f";
end Naming;
package Compiler is
for Driver ("Fortran") use "${PATH(fortran)}g77";
for Leading_Required_Switches ("Fortran") use
Compiler'Leading_Required_Switches ("Fortran") &
("-c", "-fno-underscoring");
for Include_Path ("Fortran") use "CPATH";
end Compiler;
package Compiler is
for Leading_Required_Switches ("Fortran") use
Compiler'Leading_Required_Switches ("Fortran") & ("-mno-cygwin");
end Compiler;
package Naming is
for Body_Suffix ("Fortran") use ".f";
end Naming;
package Compiler is
for Driver ("Fortran") use "${PATH(fortran)}gfortran${PREFIX(fortran)}";
for Leading_Required_Switches ("Fortran") use
Compiler'Leading_Required_Switches ("Fortran") &
("-c", "-fno-underscoring");
for Include_Path ("Fortran") use "CPATH";
end Compiler;
package Compiler is
for PIC_Option ("Fortran") use ("-fPIC");
end Compiler;
gprbuild-gpl-2014-src/share/gprconfig/nocompiler.xml 0000644 0000767 0000145 00000000567 10774202155 022116 0 ustar gnatmail gnat
package Compiler is
for Driver ("Project File") use "";
end Compiler;
package Naming is
for Spec_Suffix ("Project File") use ".gpr";
end Naming;
gprbuild-gpl-2014-src/share/gprconfig/cpp.xml 0000644 0000767 0000145 00000013273 12247666154 020541 0 ustar gnatmail gnat
package Naming is
for Spec_Suffix ("C++") use ".hh";
for Body_Suffix ("C++") use ".cpp";
end Naming;
for Inherit_Source_Path ("C++") use ("C");
package Compiler is
for Driver ("C++") use "${PATH(c++)}g++${PREFIX(c++)}";
end Compiler;
package Clean is
for Source_Artifact_Extensions ("C++") use (".gli");
for Object_Artifact_Extensions ("C++") use (".s", "ci", ".gcno");
end Clean;
package Compiler is
for Driver ("C++") use "${PATH(c++)}c++${PREFIX(c++)}";
end Compiler;
package Compiler is
for Leading_Required_Switches ("C++") use
("-c", "-x", "c++") &
Compiler'Leading_Required_Switches ("C++");
for Dependency_Switches ("C++") use ("-MMD", "-MF", "");
for Include_Path ("C++") use "CPATH";
end Compiler;
package Compiler is
for Leading_Required_Switches ("C++") use
Compiler'Leading_Required_Switches ("C++") & ("-fdump-xref");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C++") use
Compiler'Leading_Required_Switches ("C++") &
("-c", "-x", "c++");
for Dependency_Switches ("C++") use ("-Wp,-MMD,");
for Include_Path ("C++") use "CPATH";
end Compiler;
package Compiler is
for PIC_Option ("C++") use ("-fPIC");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C++") use
Compiler'Leading_Required_Switches ("C++") & ("-mno-cygwin");
end Compiler;
gprbuild-gpl-2014-src/share/gprconfig/gnat.xml 0000644 0000767 0000145 00000024171 12215621730 020671 0 ustar gnatmail gnat
package Naming is
for Spec_Suffix ("Ada") use ".ads";
for Body_Suffix ("Ada") use ".adb";
for Casing use "lowercase";
for Dot_Replacement use "-";
end Naming;
package Compiler is
for Driver ("Ada") use "gnaamp";
for Language_Kind ("Ada") use "unit_based";
for Dependency_Kind ("Ada") use "ALI_File";
for Required_Switches ("Ada") use
Compiler'Required_Switches ("Ada")
& ("-gnatA");
for Object_File_Suffix ("Ada") use ".obj";
for Mapping_File_Switches ("Ada") use ("-gnatem=");
for Mapping_Spec_Suffix ("Ada") use "%s";
for Mapping_Body_Suffix ("Ada") use "%b";
for Config_File_Switches ("Ada") use ("-gnatec=");
for Include_Path_File ("Ada") use "ADA_PRJ_INCLUDE_FILE";
for Config_Body_File_Name ("Ada") use
"pragma Source_File_Name_Project (%u, Body_File_Name => ""%f"");";
for Config_Spec_File_Name ("Ada") use
"pragma Source_File_Name_Project (%u, Spec_File_Name => ""%f"");";
for Config_Body_File_Name_Pattern ("Ada") use
"pragma Source_File_Name_Project " &
" (Body_File_Name => ""*%b""," &
" Casing => %c," &
" Dot_Replacement => ""%d"");";
for Config_Spec_File_Name_Pattern ("Ada") use
"pragma Source_File_Name_Project " &
" (Spec_File_Name => ""*%s""," &
" Casing => %c," &
" Dot_Replacement => ""%d"");";
for Config_File_Unique ("Ada") use "False";
end Compiler;
package Binder is
for Objects_Path_File ("Ada") use "ADA_PRJ_OBJECTS_FILE";
for Required_Switches ("Ada") use
Binder'Required_Switches ("Ada") &
("ada_binder=gnaampbind");
for Driver ("Ada") use
"${GPRCONFIG_PREFIX}/libexec/gprbuild/gprbind";
end Binder;
for Toolchain_Version ("Ada") use "GNAT ${VERSION(ada)}";
for Runtime_Library_Dir ("Ada") use "${RUNTIME_DIR(ada)}/adalib/";
for Runtime_Source_Dir ("Ada") use "${RUNTIME_DIR(ada)}/adainclude/";
&filter_gnat;
package Naming is
for Spec_Suffix ("Ada") use ".ads";
for Body_Suffix ("Ada") use ".adb";
for Casing use "lowercase";
for Dot_Replacement use "-";
end Naming;
package Compiler is
for Driver ("Ada") use "${PATH(ada)}${PREFIX(ada)}gcc";
for Language_Kind ("Ada") use "unit_based";
for Dependency_Kind ("Ada") use "ALI_File";
for Leading_Required_Switches ("Ada") use
("-c", "-x", "ada", "-gnatA")
& Compiler'Leading_Required_Switches ("Ada");
for Mapping_File_Switches ("Ada") use ("-gnatem=");
for Mapping_Spec_Suffix ("Ada") use "%s";
for Mapping_Body_Suffix ("Ada") use "%b";
for Config_File_Switches ("Ada") use ("-gnatec=");
for Include_Path_File ("Ada") use "ADA_PRJ_INCLUDE_FILE";
end Compiler;
package Binder is
for Objects_Path_File ("Ada") use "ADA_PRJ_OBJECTS_FILE";
for Driver ("Ada") use
"${GPRCONFIG_PREFIX}libexec/gprbuild/gprbind";
end Binder;
package Clean is
for Source_Artifact_Extensions ("Ada") use (".dg", ".rep");
for Object_Artifact_Extensions ("Ada") use (".s", "ci", ".gcno");
end Clean;
for Toolchain_Version ("Ada") use "GNAT ${VERSION(ada)}";
for Runtime_Library_Dir ("Ada") use "${RUNTIME_DIR(ada)}/adalib/";
for Runtime_Source_Dir ("Ada") use "${RUNTIME_DIR(ada)}/adainclude/";
package Compiler is
for Object_File_Suffix ("Ada") use ".il";
for Driver ("Ada") use "${PATH(ada)}${PREFIX(ada)}gnatcompile";
end Compiler;
&filter_gnat;
package Compiler is
for Multi_Unit_Switches ("Ada") use ("-gnateI");
for Multi_Unit_Object_Separator ("Ada") use "~";
for Config_Body_File_Name ("Ada") use
"pragma Source_File_Name_Project (%u, Body_File_Name => ""%f"");";
for Config_Spec_File_Name ("Ada") use
"pragma Source_File_Name_Project (%u, Spec_File_Name => ""%f"");";
for Config_Body_File_Name_Index ("Ada") use
"pragma Source_File_Name_Project (%u, Body_File_Name => ""%f"", Index => %i);";
for Config_Spec_File_Name_Index ("Ada") use
"pragma Source_File_Name_Project (%u, Spec_File_Name => ""%f"", Index => %i);";
for Config_Body_File_Name_Pattern ("Ada") use
"pragma Source_File_Name_Project " &
" (Body_File_Name => ""*%b""," &
" Casing => %c," &
" Dot_Replacement => ""%d"");";
for Config_Spec_File_Name_Pattern ("Ada") use
"pragma Source_File_Name_Project " &
" (Spec_File_Name => ""*%s""," &
" Casing => %c," &
" Dot_Replacement => ""%d"");";
for Config_File_Unique ("Ada") use "False";
end Compiler;
&filter_gnat;
package Compiler is
for Config_Body_File_Name ("Ada") use
"pragma Source_File_Name (%u, Body_File_Name => ""%f"");";
for Config_Spec_File_Name ("Ada") use
"pragma Source_File_Name (%u, Spec_File_Name => ""%f"");";
for Config_Body_File_Name_Pattern ("Ada") use
"pragma Source_File_Name " &
" (Body_File_Name => ""*%b""," &
" Casing => %c," &
" Dot_Replacement => ""%d"");";
for Config_Spec_File_Name_Pattern ("Ada") use
"pragma Source_File_Name " &
" (Spec_File_Name => ""*%s""," &
" Casing => %c," &
" Dot_Replacement => ""%d"");";
for Config_File_Unique ("Ada") use "True";
end Compiler;
&filter_gnat;
package Compiler is
for Config_Body_File_Name ("Ada") use
"pragma Source_File_Name_Project (%u, Body_File_Name => ""%f"");";
for Config_Spec_File_Name ("Ada") use
"pragma Source_File_Name_Project (%u, Spec_File_Name => ""%f"");";
for Config_Body_File_Name_Pattern ("Ada") use
"pragma Source_File_Name_Project " &
" (Body_File_Name => ""*%b""," &
" Casing => %c," &
" Dot_Replacement => ""%d"");";
for Config_Spec_File_Name_Pattern ("Ada") use
"pragma Source_File_Name_Project " &
" (Spec_File_Name => ""*%s""," &
" Casing => %c," &
" Dot_Replacement => ""%d"");";
for Config_File_Unique ("Ada") use "False";
end Compiler;
&filter_gnat;
package Compiler is
for PIC_Option ("Ada") use ("-fPIC");
end Compiler;
&filter_gnat;
for Library_Encapsulated_Supported use "true";
package Compiler is
for Leading_Required_Switches ("Ada") use
Compiler'Leading_Required_Switches ("Ada") & ("--RTS=${RUNTIME(ada)}");
end Compiler;
package Binder is
for Required_Switches ("Ada") use
Binder'Required_Switches ("Ada") & ("--RTS=${RUNTIME(ada)}");
end Binder;
package Compiler is
for Leading_Required_Switches ("Ada") use
Compiler'Leading_Required_Switches ("Ada") & ("--RTS=${RUNTIME(ada)}/..");
end Compiler;
package Binder is
for Required_Switches ("Ada") use
Binder'Required_Switches ("Ada") & ("--RTS=${RUNTIME(ada)}/..");
end Binder;
package Compiler is
for Leading_Required_Switches ("Ada") use
Compiler'Leading_Required_Switches ("Ada") & ("-msoft-float");
end Compiler;
gprbuild-gpl-2014-src/share/gprconfig/gprconfig.xsd 0000644 0000767 0000145 00000014474 12267650363 021734 0 ustar gnatmail gnat
gprbuild-gpl-2014-src/share/gprconfig/compilers.xml 0000644 0000767 0000145 00000064521 12313013502 021727 0 ustar gnatmail gnat
PRJFILE
Project File
GCC
(.*(-wrs-|-sysgo|-elf-|-eabi-|-eabispe-|avr-|-elinos-linux|-pc-mingw32|-xcoff-|arm-linux-androideabi-|arm-linux-gnueabi-).*)?gcc
${PREFIX}gcc -v
C
${PREFIX}gcc -dumpmachine
GCC_Pro
(.*(-wrs-|-sysgo|-elf-|-eabi-|-eabispe-|avr-|-elinos-linux|-pc-mingw32|-xcoff-|arm-linux-androideabi-|arm-linux-gnueabi-).*)?gcc
${PREFIX}gcc -v
C
${PREFIX}gcc -dumpmachine
GCC-WRS6
cc(arm|pentium|sh|mips|ppc)
vxworks-6.*
C
kernel,kernel-smp,kernel-sjlj,rtp,rtp-smp
cc${PREFIX} -dumpmachine
GCC-WRS6LEON
cc(sparc)
vxworks-6.*
C
kernel
leon-wrs-vxworks
GCC-WRS6E500V2
cc(ppc)
vxworks-6.*
C
kernel,kernel-smp,kernel-sjlj,rtp,rtp-smp
e500v2-wrs-vxworks
GCC-WRS7
cc(arm|pentium|sh|mips|ppc)
vxworks-7.*
C
kernel,kernel-smp,kernel-sjlj,rtp,rtp-smp
cc${PREFIX} -dumpmachine
GCC-WRS7LEON
cc(sparc)
vxworks-6.*
C
kernel
leon-wrs-vxworks
GCC-WRS7E500V2
cc(ppc)
vxworks-7.*
C
kernel,kernel-smp,kernel-sjlj,rtp,rtp-smp
e500v2-wrs-vxworks
GCC-WRS6CERT
cc(arm|pentium|sh|mips|ppc|sparc)
vxworks-cert-6.*
C
kernel,ravenscar-cert,zfp,rtp,ravenscar-cert-rtp
cc${PREFIX} -dumpmachine
GCC-WRS6CERTE500V2
cc(ppc)
vxworks-cert-6.*
C
kernel,ravenscar-cert,zfp,rtp,ravenscar-cert-rtp
e500v2-wrs-vxworks
GCC-WRS5
cc(arm|pentium|sh|mips|ppc|sparc)
cc${PREFIX} -v
(tornado 2|VxWorks 5)
C
cc${PREFIX} -dumpmachine
GCC-WRS653
cc(ppc|pentium)
vxworks653.*
C
full,cert,ravenscar-cert,zfp
cc${PREFIX} -dumpmachine
GCC-WRS653-E500V2
cc(ppc)
vxworks653.*
C
full,cert,ravenscar-cert,zfp
e500v2-wrs-vxworksae
GCC-WRSMILS
cc(ppc)
cc${PREFIX} -v
vxworksae
C
full,cert,ravenscar-cert,zfp
powerpc-wrs-vxworksmils
GCC-WRSMILS-E500V2
cc(ppc)
cc${PREFIX} -v
vxworksae
C
full,cert,ravenscar-cert,zfp
e500v2-wrs-vxworksmils
GCC-WRSMILSHAE
c\+\+(ppc)
vxworks-mils-hae-1.*
C
zfp
powerpc-wrs-vxworksmils
GCC-WRSMILSHAE-E500V2
c\+\+(ppc)
vxworks-mils-hae-1.*
C
zfp
e500v2-wrs-vxworksmils
GCC-SYSGO
(x86_i586-)gcc
C
i586-sysgo-pikeos
GCC-28
gcc
gcc -v
2\.8\.
C
gcc -dumpmachine
GNAAMP
gnaampmake
gnaampls -v
Ada
aamp
G++
g\+\+
g++ -v
C++
g++ -dumpmachine
G++_Pro
g\+\+
g++ -v
C++
g++ -dumpmachine
G++-WRS5
c\+\+(arm|pentium|sh|mips|ppc|sparc)
c++${PREFIX} -v
tornado 2|VxWorks 5
C++
c++${PREFIX} -dumpmachine
G++-WRS6
c\+\+(arm|pentium|sh|mips|ppc|sparc)
vxworks-6.*
C++
kernel,kernel-smp,kernel-sjlj,rtp,rtp-smp
c++${PREFIX} -dumpmachine
G++-WRS6LEON
c\+\+(sparc)
vxworks-6.*
C++
kernel
leon-wrs-vxworks
G++-WRS6E500V2
c\+\+(ppc)
vxworks-6.*
C++
kernel,kernel-smp,kernel-sjlj,rtp,rtp-smp
e500v2-wrs-vxworks
G++-WRS7
c\+\+(arm|pentium|sh|mips|ppc|sparc)
vxworks-7.*
C++
kernel,kernel-smp,kernel-sjlj,rtp,rtp-smp
c++${PREFIX} -dumpmachine
G++-WRS7LEON
c\+\+(sparc)
vxworks-7.*
C++
kernel
leon-wrs-vxworks
G++-WRS7E500V2
c\+\+(ppc)
vxworks-7.*
C++
kernel,kernel-smp,kernel-sjlj,rtp,rtp-smp
e500v2-wrs-vxworks
G++-WRS6CERT
c\+\+(arm|pentium|sh|mips|ppc|sparc)
vxworks-cert-6.*
C++
kernel,ravenscar-cert,zfp,rtp,ravenscar-cert-rtp
c++${PREFIX} -dumpmachine
G++-WRS6CERTE500V2
c\+\+(ppc)
vxworks-cert-6.*
C++
kernel,ravenscar-cert,zfp,rtp,ravenscar-cert-rtp
e500v2-wrs-vxworks
G++-WRS653
c\+\+(ppc|pentium)
vxworks653.*
C++
full,cert,ravenscar-cert,zfp
c++${PREFIX} -dumpmachine
G++-WRS653-E500V2
c\+\+(ppc)
vxworks653.*
C++
full,cert,ravenscar-cert,zfp
e500v2-wrs-vxworksae
G++-WRSMILS
c\+\+(ppc)
c++${PREFIX} -v
vxworksae
C++
full,cert,ravenscar-cert,zfp
powerpc-wrs-vxworksmils
G++-WRSMILS-E500V2
c\+\+(ppc)
c++${PREFIX} -v
vxworksae
C++
full,cert,ravenscar-cert,zfp
e500v2-wrs-vxworksmils
G++-WRSLINUX
(powerpc-wrs-linux-gnu)-cpp
${PREFIX}-cpp -v
C++
full
${PREFIX}-cpp -dumpmachine
G++-WRSLINUXE500V2
(powerpc-wrs-linux-gnu)-cpp
${PREFIX}-cpp -v
C++
full
e500v2-wrs-linux
GCC-WRSLINUX
(powerpc-wrs-linux-gnu)-gcc
${PREFIX}-cpp -v
C
full
${PREFIX} -dumpmachine
GCC-WRSLINUXE500V2
(powerpc-wrs-linux-gnu)-gcc
${PREFIX}-cpp -v
C
full
e500v2-wrs-linux
G++-WRSMILSHAE
c\+\+(ppc)
vxworks-mils-hae-1.*
C++
zfp
powerpc-wrs-vxworksmils
G++-WRSMILSHAE-E500V2
c\+\+(ppc)
vxworks-mils-hae-1.*
C++
zfp
e500v2-wrs-vxworksmils
GCC-ASM
(.*(-wrs-|-elf-|-eabi-|-eabispe-|avr-|elinos-linux|-pc-mingw32).*)?gcc
${PREFIX}gcc -v
Asm,Asm_Cpp,Asm2
${PREFIX}gcc -dumpmachine
GNAT
(.*(-wrs-|-sysgo|-elf-|-eabi-|-eabispe-|avr-|elinos-linux|-pc-mingw32|-xcoff-|-pikeos-|arm-linux-androideabi-|arm-linux-gnueabi-).*)?gnatmake
${PREFIX}gnatls -v
Ada
${PREFIX}gcc -v
\.\./lib/gcc(-lib)?/$TARGET/$gcc_version/adalib/
\.\./lib/gcc(-lib)?/$TARGET/$gcc_version/ada_object_path
\.\./lib/gcc(-lib)?/$TARGET/$gcc_version/rts-(.*)/adalib/
${PREFIX}gcc -dumpmachine
GNAT_CODEPEER
(.*codepeer-)gnatmake
${PREFIX}gnatls -v
Ada
${PREFIX}gcc -v
\.\./lib/gcc/.*/$gcc_version/adalib/
codepeer
GNAT_DOTNET
(.*dotnet-)gnatmake
${PREFIX}gnatls -v
Ada
\.\./lib/dotgnat/adalib/
\.\./lib/dotgnat/rts-(.*)/adalib/
dotnet
G77
g77
g77 --version
Fortran
g77 -dumpmachine
GFORTRAN
gfortran
gfortran -v
Fortran
gfortran -dumpmachine
GCC-CYGMING
gcc
gcc --version
C,C++,Fortran
gcc -mno-cygwin -dumpmachine
GCC-MINGW32
gcc(-sjlj|)
gcc${PREFIX} --version
C,C++,Fortran
gcc${PREFIX} -dumpmachine
DIABC-PPC
dcc
dcc -V
C
powerpc-elf
LYNXWORKS-C
gcc
gcc -v
C
gcc -dumpmachine
.*xcoff-lynxos.*
LYNXWORKS-C++
c\+\+
c++ -v
C++
c++ -dumpmachine
.*xcoff-lynxos.*
LLVM
clang
clang -v
C
clang -dumpmachine
gprbuild-gpl-2014-src/share/gprconfig/c.xml 0000644 0000767 0000145 00000017060 12313013502 020150 0 ustar gnatmail gnat
package Naming is
for Spec_Suffix ("C") use ".h";
for Body_Suffix ("C") use ".c";
end Naming;
package Compiler is
for Driver ("C") use "${PATH(c)}${PREFIX(c)}gcc";
end Compiler;
package Clean is
for Source_Artifact_Extensions ("C") use (".gli");
for Object_Artifact_Extensions ("C") use (".s", "ci", ".gcno");
end Clean;
package Compiler is
for Driver ("C") use "${PATH(c)}gcc${PREFIX(c)}";
end Compiler;
package Clean is
for Source_Artifact_Extensions ("C") use (".gli");
for Object_Artifact_Extensions ("C") use (".s", "ci", ".gcno");
end Clean;
package Compiler is
for Driver ("C") use "${PATH(c)}cc${PREFIX(c)}";
end Compiler;
package Compiler is
for Driver ("C") use "${PATH(c)}dcc";
end Compiler;
package Compiler is
for Driver ("C") use "${PATH(c)}clang";
end Compiler;
package Compiler is
for Leading_Required_Switches ("C") use
("-c", "-x", "c") & Compiler'Leading_Required_Switches ("C");
for Include_Path ("C") use "CPATH";
end Compiler;
package Compiler is
for Dependency_Switches ("C") use ("-Wp,-MMD,");
end Compiler;
package Compiler is
for Dependency_Switches ("C") use ("-MMD", "-MF", "");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C") & ("-tPPC750EH:cross", "-c");
for Dependency_Switches ("C") use
("-Xmake-dependency=6", "-Xmake-dependency-savefile=");
for Include_Path ("C") use "CPATH";
end Compiler;
package Compiler is
for PIC_Option ("C") use ("-fPIC");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C") & ("-fdump-xref");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C") & ("-mno-cygwin");
end Compiler;
gprbuild-gpl-2014-src/share/gprconfig/gnat_runtime.mapping 0000644 0000767 0000145 00000122571 10520412162 023264 0 ustar gnatmail gnat a-astaco.adb
body
Ada.Asynchronous_Task_Control
a-calari.adb
body
Ada.Calendar.Arithmetic
a-caldel.adb
body
Ada.Calendar.Delays
a-calend.adb
body
Ada.Calendar
a-calfor.adb
body
Ada.Calendar.Formatting
a-catizo.adb
body
Ada.Calendar.Time_Zones
a-cbdlli.adb
body
Ada.Containers.Bounded_Doubly_Linked_Lists
a-cdlili.adb
body
Ada.Containers.Doubly_Linked_Lists
a-cgaaso.adb
body
Ada.Containers.Generic_Anonymous_Array_Sort
a-cgarso.adb
body
Ada.Containers.Generic_Array_Sort
a-cgcaso.adb
body
Ada.Containers.Generic_Constrained_Array_Sort
a-chacon.adb
body
Ada.Characters.Conversions
a-chahan.adb
body
Ada.Characters.Handling
a-chtgke.adb
body
Ada.Containers.Hash_Tables.Generic_Keys
a-chtgop.adb
body
Ada.Containers.Hash_Tables.Generic_Operations
a-cidlli.adb
body
Ada.Containers.Indefinite_Doubly_Linked_Lists
a-cihama.adb
body
Ada.Containers.Indefinite_Hashed_Maps
a-cihase.adb
body
Ada.Containers.Indefinite_Hashed_Sets
a-ciorma.adb
body
Ada.Containers.Indefinite_Ordered_Maps
a-ciormu.adb
body
Ada.Containers.Indefinite_Ordered_Multisets
a-ciorse.adb
body
Ada.Containers.Indefinite_Ordered_Sets
a-cohama.adb
body
Ada.Containers.Hashed_Maps
a-cohase.adb
body
Ada.Containers.Hashed_Sets
a-coinve.adb
body
Ada.Containers.Indefinite_Vectors
a-colien.adb
body
Ada.Command_Line.Environment
a-colire.adb
body
Ada.Command_Line.Remove
a-comlin.adb
body
Ada.Command_Line
a-convec.adb
body
Ada.Containers.Vectors
a-coorma.adb
body
Ada.Containers.Ordered_Maps
a-coormu.adb
body
Ada.Containers.Ordered_Multisets
a-coorse.adb
body
Ada.Containers.Ordered_Sets
a-coprnu.adb
body
Ada.Containers.Prime_Numbers
a-crbtgk.adb
body
Ada.Containers.Red_Black_Trees.Generic_Keys
a-crbtgo.adb
body
Ada.Containers.Red_Black_Trees.Generic_Operations
a-crdlli.adb
body
Ada.Containers.Restricted_Doubly_Linked_Lists
a-decima.adb
body
Ada.Decimal
a-diocst.adb
body
Ada.Direct_Io.C_Streams
a-direct.adb
body
Ada.Directories
a-direio.adb
body
Ada.Direct_Io
a-diroro.adb
body
Ada.Dispatching.Round_Robin
a-dirval.adb
body
Ada.Directories.Validity
a-dynpri.adb
body
Ada.Dynamic_Priorities
a-einuoc.adb
body
Ada.Exceptions.Is_Null_Occurrence
a-elchha.adb
body
Ada.Exceptions.Last_Chance_Handler
a-envvar.adb
body
Ada.Environment_Variables
a-excpol.adb
body
Ada.Exceptions.Poll
a-exctra.adb
body
Ada.Exceptions.Traceback
a-exexda.adb
body
Ada.Exceptions.Exception_Data
a-exexpr.adb
body
Ada.Exceptions.Exception_Propagation
a-exextr.adb
body
Ada.Exceptions.Exception_Traces
a-filico.adb
body
Ada.Finalization.List_Controller
a-finali.adb
body
Ada.Finalization
a-interr.adb
body
Ada.Interrupts
a-intsig.adb
body
Ada.Interrupts.Signal
a-ngcefu.adb
body
Ada.Numerics.Generic_Complex_Elementary_Functions
a-ngcoar.adb
body
Ada.Numerics.Generic_Complex_Arrays
a-ngcoty.adb
body
Ada.Numerics.Generic_Complex_Types
a-ngelfu.adb
body
Ada.Numerics.Generic_Elementary_Functions
a-ngrear.adb
body
Ada.Numerics.Generic_Real_Arrays
a-nudira.adb
body
Ada.Numerics.Discrete_Random
a-nuflra.adb
body
Ada.Numerics.Float_Random
a-numaux.adb
body
Ada.Numerics.Aux
a-rbtgso.adb
body
Ada.Containers.Red_Black_Trees.Generic_Set_Operations
a-reatim.adb
body
Ada.Real_Time
a-retide.adb
body
Ada.Real_Time.Delays
a-rttiev.adb
body
Ada.Real_Time.Timing_Events
a-secain.adb
body
Ada.Strings.Equal_Case_Insensitive
a-sequio.adb
body
Ada.Sequential_Io
a-shcain.adb
body
Ada.Strings.Hash_Case_Insensitive
a-siocst.adb
body
Ada.Sequential_Io.C_Streams
a-slcain.adb
body
Ada.Strings.Less_Case_Insensitive
a-ssicst.adb
body
Ada.Streams.Stream_Io.C_Streams
a-stboha.adb
body
Ada.Strings.Bounded.Hash
a-storio.adb
body
Ada.Storage_Io
a-strbou.adb
body
Ada.Strings.Bounded
a-strfix.adb
body
Ada.Strings.Fixed
a-strhas.adb
body
Ada.Strings.Hash
a-strmap.adb
body
Ada.Strings.Maps
a-strsea.adb
body
Ada.Strings.Search
a-strsup.adb
body
Ada.Strings.Superbounded
a-strunb.adb
body
Ada.Strings.Unbounded
a-ststio.adb
body
Ada.Streams.Stream_Io
a-stunau.adb
body
Ada.Strings.Unbounded.Aux
a-stunha.adb
body
Ada.Strings.Unbounded.Hash
a-stwibo.adb
body
Ada.Strings.Wide_Bounded
a-stwifi.adb
body
Ada.Strings.Wide_Fixed
a-stwiha.adb
body
Ada.Strings.Wide_Hash
a-stwima.adb
body
Ada.Strings.Wide_Maps
a-stwise.adb
body
Ada.Strings.Wide_Search
a-stwisu.adb
body
Ada.Strings.Wide_Superbounded
a-stwiun.adb
body
Ada.Strings.Wide_Unbounded
a-stzbou.adb
body
Ada.Strings.Wide_Wide_Bounded
a-stzfix.adb
body
Ada.Strings.Wide_Wide_Fixed
a-stzhas.adb
body
Ada.Strings.Wide_Wide_Hash
a-stzmap.adb
body
Ada.Strings.Wide_Wide_Maps
a-stzsea.adb
body
Ada.Strings.Wide_Wide_Search
a-stzsup.adb
body
Ada.Strings.Wide_Wide_Superbounded
a-stzunb.adb
body
Ada.Strings.Wide_Wide_Unbounded
a-suteio.adb
body
Ada.Strings.Unbounded.Text_Io
a-swbwha.adb
body
Ada.Strings.Wide_Bounded.Wide_Hash
a-swunau.adb
body
Ada.Strings.Wide_Unbounded.Aux
a-swuwha.adb
body
Ada.Strings.Wide_Unbounded.Wide_Hash
a-swuwti.adb
body
Ada.Strings.Wide_Unbounded.Wide_Text_Io
a-swwibo.adb
body
Ada.Strings.Wide_Wide_Bounded
a-swwifi.adb
body
Ada.Strings.Wide_Wide_Fixed
a-swwima.adb
body
Ada.Strings.Wide_Wide_Maps
a-swwise.adb
body
Ada.Strings.Wide_Wide_Search
a-swwisu.adb
body
Ada.Strings.Wide_Wide_Superbounded
a-sytaco.adb
body
Ada.Synchronous_Task_Control
a-szbzha.adb
body
Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash
a-szunau.adb
body
Ada.Strings.Wide_Wide_Unbounded.Aux
a-szuzha.adb
body
Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash
a-szuzti.adb
body
Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_Io
a-tags.adb
body
Ada.Tags
a-tasatt.adb
body
Ada.Task_Attributes
a-taside.adb
body
Ada.Task_Identification
a-taster.adb
body
Ada.Task_Termination
a-teioed.adb
body
Ada.Text_Io.Editing
a-textio.adb
body
Ada.Text_Io
a-tiboio.adb
body
Ada.Text_Io.Bounded_Io
a-ticoau.adb
body
Ada.Text_Io.Complex_Aux
a-ticoio.adb
body
Ada.Text_Io.Complex_Io
a-tideau.adb
body
Ada.Text_Io.Decimal_Aux
a-tideio.adb
body
Ada.Text_Io.Decimal_Io
a-tienau.adb
body
Ada.Text_Io.Enumeration_Aux
a-tienio.adb
body
Ada.Text_Io.Enumeration_Io
a-tifiio.adb
body
Ada.Text_Io.Fixed_Io
a-tiflau.adb
body
Ada.Text_Io.Float_Aux
a-tiflio.adb
body
Ada.Text_Io.Float_Io
a-tigeau.adb
body
Ada.Text_Io.Generic_Aux
a-tiinau.adb
body
Ada.Text_Io.Integer_Aux
a-tiinio.adb
body
Ada.Text_Io.Integer_Io
a-timoau.adb
body
Ada.Text_Io.Modular_Aux
a-timoio.adb
body
Ada.Text_Io.Modular_Io
a-tiocst.adb
body
Ada.Text_Io.C_Streams
a-titest.adb
body
Ada.Text_Io.Text_Streams
a-wichun.adb
body
Ada.Wide_Characters.Unicode
a-witeio.adb
body
Ada.Wide_Text_Io
a-wtcoau.adb
body
Ada.Wide_Text_Io.Complex_Aux
a-wtcoio.adb
body
Ada.Wide_Text_Io.Complex_Io
a-wtcstr.adb
body
Ada.Wide_Text_Io.C_Streams
a-wtdeau.adb
body
Ada.Wide_Text_Io.Decimal_Aux
a-wtdeio.adb
body
Ada.Wide_Text_Io.Decimal_Io
a-wtedit.adb
body
Ada.Wide_Text_Io.Editing
a-wtenau.adb
body
Ada.Wide_Text_Io.Enumeration_Aux
a-wtenio.adb
body
Ada.Wide_Text_Io.Enumeration_Io
a-wtfiio.adb
body
Ada.Wide_Text_Io.Fixed_Io
a-wtflau.adb
body
Ada.Wide_Text_Io.Float_Aux
a-wtflio.adb
body
Ada.Wide_Text_Io.Float_Io
a-wtgeau.adb
body
Ada.Wide_Text_Io.Generic_Aux
a-wtinau.adb
body
Ada.Wide_Text_Io.Integer_Aux
a-wtinio.adb
body
Ada.Wide_Text_Io.Integer_Io
a-wtmoau.adb
body
Ada.Wide_Text_Io.Modular_Aux
a-wtmoio.adb
body
Ada.Wide_Text_Io.Modular_Io
a-wttest.adb
body
Ada.Wide_Text_Io.Text_Streams
a-wwboio.adb
body
Ada.Wide_Text_Io.Wide_Bounded_Io
a-zchuni.adb
body
Ada.Wide_Wide_Characters.Unicode
a-ztcoau.adb
body
Ada.Wide_Wide_Text_Io.Complex_Aux
a-ztcoio.adb
body
Ada.Wide_Wide_Text_Io.Complex_Io
a-ztcstr.adb
body
Ada.Wide_Wide_Text_Io.C_Streams
a-ztdeau.adb
body
Ada.Wide_Wide_Text_Io.Decimal_Aux
a-ztdeio.adb
body
Ada.Wide_Wide_Text_Io.Decimal_Io
a-ztedit.adb
body
Ada.Wide_Wide_Text_Io.Editing
a-ztenau.adb
body
Ada.Wide_Wide_Text_Io.Enumeration_Aux
a-ztenio.adb
body
Ada.Wide_Wide_Text_Io.Enumeration_Io
a-ztexio.adb
body
Ada.Wide_Wide_Text_Io
a-ztfiio.adb
body
Ada.Wide_Wide_Text_Io.Fixed_Io
a-ztflau.adb
body
Ada.Wide_Wide_Text_Io.Float_Aux
a-ztflio.adb
body
Ada.Wide_Wide_Text_Io.Float_Io
a-ztgeau.adb
body
Ada.Wide_Wide_Text_Io.Generic_Aux
a-ztinau.adb
body
Ada.Wide_Wide_Text_Io.Integer_Aux
a-ztinio.adb
body
Ada.Wide_Wide_Text_Io.Integer_Io
a-ztmoau.adb
body
Ada.Wide_Wide_Text_Io.Modular_Aux
a-ztmoio.adb
body
Ada.Wide_Wide_Text_Io.Modular_Io
a-zttest.adb
body
Ada.Wide_Wide_Text_Io.Text_Streams
a-zzboio.adb
body
Ada.Wide_Wide_Text_Io.Wide_Wide_Bounded_Io
g-alleve.adb
body
GNAT.ALTIVEC.LOW_LEVEL_VECTORS
g-altcon.adb
body
GNAT.ALTIVEC.CONVERSIONS
g-alveop.adb
body
GNAT.ALTIVEC.VECTOR_OPERATIONS
g-arrspl.adb
body
GNAT.ARRAY_SPLIT
g-boubuf.adb
body
GNAT.BOUNDED_BUFFERS
g-bubsor.adb
body
GNAT.BUBBLE_SORT
g-busora.adb
body
GNAT.BUBBLE_SORT_A
g-busorg.adb
body
GNAT.BUBBLE_SORT_G
g-bytswa.adb
body
GNAT.BYTE_SWAPPING
g-calend.adb
body
GNAT.CALENDAR
g-casuti.adb
body
GNAT.CASE_UTIL
g-catiio.adb
body
GNAT.CALENDAR.TIME_IO
g-cgi.adb
body
GNAT.CGI
g-cgicoo.adb
body
GNAT.CGI.COOKIE
g-cgideb.adb
body
GNAT.CGI.DEBUG
g-comlin.adb
body
GNAT.COMMAND_LINE
g-comver.adb
body
GNAT.COMPILER_VERSION
g-crc32.adb
body
GNAT.CRC32
g-debpoo.adb
body
GNAT.DEBUG_POOLS
g-debuti.adb
body
GNAT.DEBUG_UTILITIES
g-diopit.adb
body
GNAT.DIRECTORY_OPERATIONS.ITERATION
g-dirope.adb
body
GNAT.DIRECTORY_OPERATIONS
g-dynhta.adb
body
GNAT.DYNAMIC_HTABLES
g-dyntab.adb
body
GNAT.DYNAMIC_TABLES
g-eacodu.adb
body
Gnat.Exception_Actions.Core_Dump
g-excact.adb
body
GNAT.EXCEPTION_ACTIONS
g-exctra.adb
body
GNAT.EXCEPTION_TRACES
g-expect.adb
body
GNAT.EXPECT
g-heasor.adb
body
GNAT.HEAP_SORT
g-hesora.adb
body
GNAT.HEAP_SORT_A
g-hesorg.adb
body
GNAT.HEAP_SORT_G
g-htable.adb
body
GNAT.HTABLE
g-io.adb
body
GNAT.IO
g-io_aux.adb
body
GNAT.IO_AUX
g-locfil.adb
body
GNAT.LOCK_FILES
g-md5.adb
body
GNAT.MD5
g-memdum.adb
body
GNAT.MEMORY_DUMP
g-moreex.adb
body
GNAT.MOST_RECENT_EXCEPTION
g-os_lib.adb
body
GNAT.OS_LIB
g-pehage.adb
body
GNAT.PERFECT_HASH_GENERATORS
g-regexp.adb
body
GNAT.REGEXP
g-regist.adb
body
GNAT.REGISTRY
g-regpat.adb
body
GNAT.REGPAT
g-semaph.adb
body
GNAT.SEMAPHORES
g-sha1.adb
body
GNAT.SHA1
g-signal.adb
body
GNAT.SIGNALS
g-socket.adb
body
GNAT.SOCKETS
g-socthi.adb
body
GNAT.SOCKETS.THIN
g-speche.adb
body
GNAT.SPELLING_CHECKER
g-spipat.adb
body
GNAT.SPITBOL.PATTERNS
g-spitbo.adb
body
GNAT.SPITBOL
g-string.adb
body
GNAT.STRINGS
g-table.adb
body
GNAT.TABLE
g-tasloc.adb
body
GNAT.TASK_LOCK
g-thread.adb
body
GNAT.THREADS
g-traceb.adb
body
GNAT.TRACEBACK
g-trasym.adb
body
GNAT.TRACEBACK.SYMBOLIC
i-c.adb
body
Interfaces.C
i-cobol.adb
body
Interfaces.Cobol
i-cpoint.adb
body
Interfaces.C.Pointers
i-cpp.adb
body
Interfaces.Cpp
i-cstrea.adb
body
Interfaces.C_Streams
i-cstrin.adb
body
Interfaces.C.Strings
i-fortra.adb
body
Interfaces.Fortran
i-pacdec.adb
body
Interfaces.Packed_Decimal
i-vxwoio.adb
body
Interfaces.Vxworks.Io
s-addima.adb
body
System.Address_Image
s-addope.adb
body
System.Address_Operations
s-arit64.adb
body
System.Arith_64
s-assert.adb
body
System.Assertions
s-asthan.adb
body
System.Ast_Handling
s-atacco.adb
body
System.Address_To_Access_Conversions
s-bbinte.adb
body
System.Bb.Interrupts
s-bbprot.adb
body
System.Bb.Protection
s-bbseou.adb
body
System.Bb.Serial_Output
s-bbthqu.adb
body
System.Bb.Threads.Queues
s-bbthre.adb
body
System.Bb.Threads
s-bbtime.adb
body
System.Bb.Time
s-bitops.adb
body
System.Bit_Ops
s-carsi8.adb
body
System.Compare_Array_Signed_8
s-carun8.adb
body
System.Compare_Array_Unsigned_8
s-casi16.adb
body
System.Compare_Array_Signed_16
s-casi32.adb
body
System.Compare_Array_Signed_32
s-casi64.adb
body
System.Compare_Array_Signed_64
s-casuti.adb
body
System.Case_Util
s-caun16.adb
body
System.Compare_Array_Unsigned_16
s-caun32.adb
body
System.Compare_Array_Unsigned_32
s-caun64.adb
body
System.Compare_Array_Unsigned_64
s-crc32.adb
body
System.Crc32
s-direio.adb
body
System.Direct_Io
s-errrep.adb
body
System.Error_Reporting
s-exctab.adb
body
System.Exception_Table
s-exnint.adb
body
System.Exn_Int
s-exnllf.adb
body
System.Exn_Llf
s-exnlli.adb
body
System.Exn_Lli
s-expint.adb
body
System.Exp_Int
s-explli.adb
body
System.Exp_Lli
s-expllu.adb
body
System.Exp_Llu
s-expmod.adb
body
System.Exp_Mod
s-expuns.adb
body
System.Exp_Uns
s-fatgen.adb
body
System.Fat_Gen
s-fileio.adb
body
System.File_Io
s-finimp.adb
body
System.Finalization_Implementation
s-finroo.adb
body
System.Finalization_Root
s-fore.adb
body
System.Fore
s-gearop.adb
body
System.Generic_Array_Operations
s-gecobl.adb
body
System.Generic_Complex_Blas
s-gecola.adb
body
System.Generic_Complex_Lapack
s-gerebl.adb
body
System.Generic_Real_Blas
s-gerela.adb
body
System.Generic_Real_Lapack
s-geveop.adb
body
System.Generic_Vector_Operations
s-gloloc.adb
body
System.Global_Locks
s-htable.adb
body
System.Htable
s-imgbiu.adb
body
System.Img_Biu
s-imgboo.adb
body
System.Img_Bool
s-imgcha.adb
body
System.Img_Char
s-imgdec.adb
body
System.Img_Dec
s-imgenu.adb
body
System.Img_Enum
s-imgint.adb
body
System.Img_Int
s-imgllb.adb
body
System.Img_Llb
s-imglld.adb
body
System.Img_Lld
s-imglli.adb
body
System.Img_Lli
s-imgllu.adb
body
System.Img_Llu
s-imgllw.adb
body
System.Img_Llw
s-imgrea.adb
body
System.Img_Real
s-imguns.adb
body
System.Img_Uns
s-imgwch.adb
body
System.Img_Wchar
s-imgwiu.adb
body
System.Img_Wiu
s-inmaop.adb
body
System.Interrupt_Management.Operations
s-interr.adb
body
System.Interrupts
s-intman.adb
body
System.Interrupt_Management
s-io.adb
body
System.Io
s-mantis.adb
body
System.Mantissa
s-mastop.adb
body
System.Machine_State_Operations
s-memory.adb
body
System.Memory
s-osprim.adb
body
System.Os_Primitives
s-pack03.adb
body
System.Pack_03
s-pack05.adb
body
System.Pack_05
s-pack06.adb
body
System.Pack_06
s-pack07.adb
body
System.Pack_07
s-pack09.adb
body
System.Pack_09
s-pack10.adb
body
System.Pack_10
s-pack11.adb
body
System.Pack_11
s-pack12.adb
body
System.Pack_12
s-pack13.adb
body
System.Pack_13
s-pack14.adb
body
System.Pack_14
s-pack15.adb
body
System.Pack_15
s-pack17.adb
body
System.Pack_17
s-pack18.adb
body
System.Pack_18
s-pack19.adb
body
System.Pack_19
s-pack20.adb
body
System.Pack_20
s-pack21.adb
body
System.Pack_21
s-pack22.adb
body
System.Pack_22
s-pack23.adb
body
System.Pack_23
s-pack24.adb
body
System.Pack_24
s-pack25.adb
body
System.Pack_25
s-pack26.adb
body
System.Pack_26
s-pack27.adb
body
System.Pack_27
s-pack28.adb
body
System.Pack_28
s-pack29.adb
body
System.Pack_29
s-pack30.adb
body
System.Pack_30
s-pack31.adb
body
System.Pack_31
s-pack33.adb
body
System.Pack_33
s-pack34.adb
body
System.Pack_34
s-pack35.adb
body
System.Pack_35
s-pack36.adb
body
System.Pack_36
s-pack37.adb
body
System.Pack_37
s-pack38.adb
body
System.Pack_38
s-pack39.adb
body
System.Pack_39
s-pack40.adb
body
System.Pack_40
s-pack41.adb
body
System.Pack_41
s-pack42.adb
body
System.Pack_42
s-pack43.adb
body
System.Pack_43
s-pack44.adb
body
System.Pack_44
s-pack45.adb
body
System.Pack_45
s-pack46.adb
body
System.Pack_46
s-pack47.adb
body
System.Pack_47
s-pack48.adb
body
System.Pack_48
s-pack49.adb
body
System.Pack_49
s-pack50.adb
body
System.Pack_50
s-pack51.adb
body
System.Pack_51
s-pack52.adb
body
System.Pack_52
s-pack53.adb
body
System.Pack_53
s-pack54.adb
body
System.Pack_54
s-pack55.adb
body
System.Pack_55
s-pack56.adb
body
System.Pack_56
s-pack57.adb
body
System.Pack_57
s-pack58.adb
body
System.Pack_58
s-pack59.adb
body
System.Pack_59
s-pack60.adb
body
System.Pack_60
s-pack61.adb
body
System.Pack_61
s-pack62.adb
body
System.Pack_62
s-pack63.adb
body
System.Pack_63
s-parame.adb
body
System.Parameters
s-parint.adb
body
System.Partition_Interface
s-pooglo.adb
body
System.Pool_Global
s-pooloc.adb
body
System.Pool_Local
s-poosiz.adb
body
System.Pool_Size
s-proinf.adb
body
System.Program_Info
s-restri.adb
body
System.Restrictions
s-rpc.adb
body
System.Rpc
s-scaval.adb
body
System.Scalar_Values
s-secsta.adb
body
System.Secondary_Stack
s-sequio.adb
body
System.Sequential_Io
s-shasto.adb
body
System.Shared_Storage
s-sopco3.adb
body
System.String_Ops_Concat_3
s-sopco4.adb
body
System.String_Ops_Concat_4
s-sopco5.adb
body
System.String_Ops_Concat_5
s-stache.adb
body
System.Stack_Checking
s-stausa.adb
body
System.Stack_Usage
s-stoele.adb
body
System.Storage_Elements
s-stopoo.adb
body
System.Storage_Pools
s-stratt.adb
body
System.Stream_Attributes
s-strcom.adb
body
System.String_Compare
s-strops.adb
body
System.String_Ops
s-strxdr.adb
body
System.Stream_Attributes
s-tadeca.adb
body
System.Tasking.Async_Delays.Enqueue_Calendar
s-tadert.adb
body
System.Tasking.Async_Delays.Enqueue_Rt
s-taenca.adb
body
System.Tasking.Entry_Calls
s-tasdeb.adb
body
System.Tasking.Debug
s-tasinf.adb
body
System.Task_Info
s-tasque.adb
body
System.Tasking.Queuing
s-tasren.adb
body
System.Tasking.Rendezvous
s-tataat.adb
body
System.Tasking.Task_Attributes
s-tpinop.adb
body
System.Task_Primitives.Interrupt_Operations
s-tpoben.adb
body
System.Tasking.Protected_Objects.Entries
s-tpobop.adb
body
System.Tasking.Protected_Objects.Operations
s-tpopsp.adb
body
System.Task_Primitives.Operations.Specific
s-tporft.adb
body
System.Task_Primitives.Operations.Register_Foreign_Thread
s-traceb.adb
body
System.Traceback
s-traces.adb
body
System.Traces
s-traent.adb
body
System.Traceback_Entries
s-tratas.adb
body
System.Traces.Tasking
s-vaflop.adb
body
System.Vax_Float_Operations
s-valboo.adb
body
System.Val_Bool
s-valcha.adb
body
System.Val_Char
s-valdec.adb
body
System.Val_Dec
s-valenu.adb
body
System.Val_Enum
s-valint.adb
body
System.Val_Int
s-vallld.adb
body
System.Val_Lld
s-vallli.adb
body
System.Val_Lli
s-valllu.adb
body
System.Val_Llu
s-valrea.adb
body
System.Val_Real
s-valuns.adb
body
System.Val_Uns
s-valuti.adb
body
System.Val_Util
s-valwch.adb
body
System.Val_Wchar
s-veboop.adb
body
System.Vectors.Boolean_Operations
s-vercon.adb
body
System.Version_Control
s-vmexta.adb
body
System.Vms_Exception_Table
s-vxwexc.adb
body
System.Vxworks_Exceptions
s-wchcnv.adb
body
System.Wch_Cnv
s-wchcon.adb
body
System.Wch_Con
s-wchjis.adb
body
System.Wch_Jis
s-wchstw.adb
body
System.Wch_Stw
s-wchwts.adb
body
System.Wch_Wts
s-widboo.adb
body
System.Wid_Bool
s-widcha.adb
body
System.Wid_Char
s-widenu.adb
body
System.Wid_Enum
s-widlli.adb
body
System.Wid_Lli
s-widllu.adb
body
System.Wid_Llu
s-widwch.adb
body
System.Wid_Wchar
s-wwdcha.adb
body
System.Wwd_Char
s-wwdenu.adb
body
System.Wwd_Enum
s-wwdwch.adb
body
System.Wwd_Wchar
a-astaco.ads
spec
Ada.Asynchronous_Task_Control
a-calari.ads
spec
Ada.Calendar.Arithmetic
a-caldel.ads
spec
Ada.Calendar.Delays
a-calend.ads
spec
Ada.Calendar
a-calfor.ads
spec
Ada.Calendar.Formatting
a-catizo.ads
spec
Ada.Calendar.Time_Zones
a-cbdlli.ads
spec
Ada.Containers.Bounded_Doubly_Linked_Lists
a-cdlili.ads
spec
Ada.Containers.Doubly_Linked_Lists
a-cgaaso.ads
spec
Ada.Containers.Generic_Anonymous_Array_Sort
a-cgarso.ads
spec
Ada.Containers.Generic_Array_Sort
a-cgcaso.ads
spec
Ada.Containers.Generic_Constrained_Array_Sort
a-chacon.ads
spec
Ada.Characters.Conversions
a-chahan.ads
spec
Ada.Characters.Handling
a-charac.ads
spec
Ada.Characters
a-chlat1.ads
spec
Ada.Characters.Latin_1
a-chlat9.ads
spec
Ada.Characters.Latin_9
a-chtgke.ads
spec
Ada.Containers.Hash_Tables.Generic_Keys
a-chtgop.ads
spec
Ada.Containers.Hash_Tables.Generic_Operations
a-chzla1.ads
spec
Ada.Characters.Wide_Wide_Latin_1
a-chzla9.ads
spec
Ada.Characters.Wide_Wide_Latin_9
a-cidlli.ads
spec
Ada.Containers.Indefinite_Doubly_Linked_Lists
a-cihama.ads
spec
Ada.Containers.Indefinite_Hashed_Maps
a-cihase.ads
spec
Ada.Containers.Indefinite_Hashed_Sets
a-ciorma.ads
spec
Ada.Containers.Indefinite_Ordered_Maps
a-ciormu.ads
spec
Ada.Containers.Indefinite_Ordered_Multisets
a-ciorse.ads
spec
Ada.Containers.Indefinite_Ordered_Sets
a-cohama.ads
spec
Ada.Containers.Hashed_Maps
a-cohase.ads
spec
Ada.Containers.Hashed_Sets
a-cohata.ads
spec
Ada.Containers.Hash_Tables
a-coinve.ads
spec
Ada.Containers.Indefinite_Vectors
a-colien.ads
spec
Ada.Command_Line.Environment
a-colire.ads
spec
Ada.Command_Line.Remove
a-comlin.ads
spec
Ada.Command_Line
a-contai.ads
spec
Ada.Containers
a-convec.ads
spec
Ada.Containers.Vectors
a-coorma.ads
spec
Ada.Containers.Ordered_Maps
a-coormu.ads
spec
Ada.Containers.Ordered_Multisets
a-coorse.ads
spec
Ada.Containers.Ordered_Sets
a-coprnu.ads
spec
Ada.Containers.Prime_Numbers
a-coteio.ads
spec
Ada.Complex_Text_Io
a-crbltr.ads
spec
Ada.Containers.Red_Black_Trees
a-crbtgk.ads
spec
Ada.Containers.Red_Black_Trees.Generic_Keys
a-crbtgo.ads
spec
Ada.Containers.Red_Black_Trees.Generic_Operations
a-crdlli.ads
spec
Ada.Containers.Restricted_Doubly_Linked_Lists
a-cwila1.ads
spec
Ada.Characters.Wide_Latin_1
a-cwila9.ads
spec
Ada.Characters.Wide_Latin_9
a-decima.ads
spec
Ada.Decimal
a-diocst.ads
spec
Ada.Direct_Io.C_Streams
a-direct.ads
spec
Ada.Directories
a-direio.ads
spec
Ada.Direct_Io
a-diroro.ads
spec
Ada.Dispatching.Round_Robin
a-dirval.ads
spec
Ada.Directories.Validity
a-disedf.ads
spec
Ada.Dispatching.Edf
a-dispat.ads
spec
Ada.Dispatching
a-dynpri.ads
spec
Ada.Dynamic_Priorities
a-einuoc.ads
spec
Ada.Exceptions.Is_Null_Occurrence
a-elchha.ads
spec
Ada.Exceptions.Last_Chance_Handler
a-envvar.ads
spec
Ada.Environment_Variables
a-etgrbu.ads
spec
Ada.Execution_Time.Group_Budgets
a-exctra.ads
spec
Ada.Exceptions.Traceback
a-exetim.ads
spec
Ada.Execution_Time
a-extiti.ads
spec
Ada.Execution_Time.Timers
a-filico.ads
spec
Ada.Finalization.List_Controller
a-finali.ads
spec
Ada.Finalization
a-flteio.ads
spec
Ada.Float_Text_Io
a-fwteio.ads
spec
Ada.Float_Wide_Text_Io
a-fzteio.ads
spec
Ada.Float_Wide_Wide_Text_Io
a-inteio.ads
spec
Ada.Integer_Text_Io
a-interr.ads
spec
Ada.Interrupts
a-intnam.ads
spec
Ada.Interrupts.Names
a-intsig.ads
spec
Ada.Interrupts.Signal
a-ioexce.ads
spec
Ada.Io_Exceptions
a-iwteio.ads
spec
Ada.Integer_Wide_Text_Io
a-izteio.ads
spec
Ada.Integer_Wide_Wide_Text_Io
a-lcteio.ads
spec
Ada.Long_Complex_Text_Io
a-lfteio.ads
spec
Ada.Long_Float_Text_Io
a-lfwtio.ads
spec
Ada.Long_Float_Wide_Text_Io
a-lfztio.ads
spec
Ada.Long_Float_Wide_Wide_Text_Io
a-liteio.ads
spec
Ada.Long_Integer_Text_Io
a-liwtio.ads
spec
Ada.Long_Integer_Wide_Text_Io
a-liztio.ads
spec
Ada.Long_Integer_Wide_Wide_Text_Io
a-llctio.ads
spec
Ada.Long_Long_Complex_Text_Io
a-llftio.ads
spec
Ada.Long_Long_Float_Text_Io
a-llfwti.ads
spec
Ada.Long_Long_Float_Wide_Text_Io
a-llfzti.ads
spec
Ada.Long_Long_Float_Wide_Wide_Text_Io
a-llitio.ads
spec
Ada.Long_Long_Integer_Text_Io
a-lliwti.ads
spec
Ada.Long_Long_Integer_Wide_Text_Io
a-llizti.ads
spec
Ada.Long_Long_Integer_Wide_Wide_Text_Io
a-ncelfu.ads
spec
Ada.Numerics.Complex_Elementary_Functions
a-ngcefu.ads
spec
Ada.Numerics.Generic_Complex_Elementary_Functions
a-ngcoar.ads
spec
Ada.Numerics.Generic_Complex_Arrays
a-ngcoty.ads
spec
Ada.Numerics.Generic_Complex_Types
a-ngelfu.ads
spec
Ada.Numerics.Generic_Elementary_Functions
a-ngrear.ads
spec
Ada.Numerics.Generic_Real_Arrays
a-nlcefu.ads
spec
Ada.Numerics.Long_Complex_Elementary_Functions
a-nlcoar.ads
spec
Ada.Numerics.Long_Complex_Arrays
a-nlcoty.ads
spec
Ada.Numerics.Long_Complex_Types
a-nlelfu.ads
spec
Ada.Numerics.Long_Elementary_Functions
a-nllcar.ads
spec
Ada.Numerics.Long_Long_Complex_Arrays
a-nllcef.ads
spec
Ada.Numerics.Long_Long_Complex_Elementary_Functions
a-nllcty.ads
spec
Ada.Numerics.Long_Long_Complex_Types
a-nllefu.ads
spec
Ada.Numerics.Long_Long_Elementary_Functions
a-nllrar.ads
spec
Ada.Numerics.Long_Long_Real_Arrays
a-nlrear.ads
spec
Ada.Numerics.Long_Real_Arrays
a-nscefu.ads
spec
Ada.Numerics.Short_Complex_Elementary_Functions
a-nscoty.ads
spec
Ada.Numerics.Short_Complex_Types
a-nselfu.ads
spec
Ada.Numerics.Short_Elementary_Functions
a-nucoar.ads
spec
Ada.Numerics.Complex_Arrays
a-nucoty.ads
spec
Ada.Numerics.Complex_Types
a-nudira.ads
spec
Ada.Numerics.Discrete_Random
a-nuelfu.ads
spec
Ada.Numerics.Elementary_Functions
a-nuflra.ads
spec
Ada.Numerics.Float_Random
a-numaux.ads
spec
Ada.Numerics.Aux
a-numeri.ads
spec
Ada.Numerics
a-nurear.ads
spec
Ada.Numerics.Real_Arrays
a-rbtgso.ads
spec
Ada.Containers.Red_Black_Trees.Generic_Set_Operations
a-reatim.ads
spec
Ada.Real_Time
a-retide.ads
spec
Ada.Real_Time.Delays
a-rttiev.ads
spec
Ada.Real_Time.Timing_Events
a-scteio.ads
spec
Ada.Short_Complex_Text_Io
a-secain.ads
spec
Ada.Strings.Equal_Case_Insensitive
a-sequio.ads
spec
Ada.Sequential_Io
a-sfteio.ads
spec
Ada.Short_Float_Text_Io
a-sfwtio.ads
spec
Ada.Short_Float_Wide_Text_Io
a-sfztio.ads
spec
Ada.Short_Float_Wide_Wide_Text_Io
a-shcain.ads
spec
Ada.Strings.Hash_Case_Insensitive
a-siocst.ads
spec
Ada.Sequential_Io.C_Streams
a-siteio.ads
spec
Ada.Short_Integer_Text_Io
a-siwtio.ads
spec
Ada.Short_Integer_Wide_Text_Io
a-siztio.ads
spec
Ada.Short_Integer_Wide_Wide_Text_Io
a-slcain.ads
spec
Ada.Strings.Less_Case_Insensitive
a-ssicst.ads
spec
Ada.Streams.Stream_Io.C_Streams
a-ssitio.ads
spec
Ada.Short_Short_Integer_Text_Io
a-ssiwti.ads
spec
Ada.Short_Short_Integer_Wide_Text_Io
a-ssizti.ads
spec
Ada.Short_Short_Integer_Wide_Wide_Text_Io
a-stboha.ads
spec
Ada.Strings.Bounded.Hash
a-stfiha.ads
spec
Ada.Strings.Fixed.Hash
a-stmaco.ads
spec
Ada.Strings.Maps.Constants
a-storio.ads
spec
Ada.Storage_Io
a-strbou.ads
spec
Ada.Strings.Bounded
a-stream.ads
spec
Ada.Streams
a-strfix.ads
spec
Ada.Strings.Fixed
a-strhas.ads
spec
Ada.Strings.Hash
a-string.ads
spec
Ada.Strings
a-strmap.ads
spec
Ada.Strings.Maps
a-strsea.ads
spec
Ada.Strings.Search
a-strsup.ads
spec
Ada.Strings.Superbounded
a-strunb.ads
spec
Ada.Strings.Unbounded
a-ststio.ads
spec
Ada.Streams.Stream_Io
ada.ads
spec
Ada
a-stunau.ads
spec
Ada.Strings.Unbounded.Aux
a-stunha.ads
spec
Ada.Strings.Unbounded.Hash
a-stwibo.ads
spec
Ada.Strings.Wide_Bounded
a-stwifi.ads
spec
Ada.Strings.Wide_Fixed
a-stwiha.ads
spec
Ada.Strings.Wide_Hash
a-stwima.ads
spec
Ada.Strings.Wide_Maps
a-stwise.ads
spec
Ada.Strings.Wide_Search
a-stwisu.ads
spec
Ada.Strings.Wide_Superbounded
a-stwiun.ads
spec
Ada.Strings.Wide_Unbounded
a-stzbou.ads
spec
Ada.Strings.Wide_Wide_Bounded
a-stzfix.ads
spec
Ada.Strings.Wide_Wide_Fixed
a-stzhas.ads
spec
Ada.Strings.Wide_Wide_Hash
a-stzmap.ads
spec
Ada.Strings.Wide_Wide_Maps
a-stzsea.ads
spec
Ada.Strings.Wide_Wide_Search
a-stzsup.ads
spec
Ada.Strings.Wide_Wide_Superbounded
a-stzunb.ads
spec
Ada.Strings.Wide_Wide_Unbounded
a-suteio.ads
spec
Ada.Strings.Unbounded.Text_Io
a-swbwha.ads
spec
Ada.Strings.Wide_Bounded.Wide_Hash
a-swfwha.ads
spec
Ada.Strings.Wide_Fixed.Wide_Hash
a-swmwco.ads
spec
Ada.Strings.Wide_Maps.Wide_Constants
a-swunau.ads
spec
Ada.Strings.Wide_Unbounded.Aux
a-swuwha.ads
spec
Ada.Strings.Wide_Unbounded.Wide_Hash
a-swuwti.ads
spec
Ada.Strings.Wide_Unbounded.Wide_Text_Io
a-sytaco.ads
spec
Ada.Synchronous_Task_Control
a-szbzha.ads
spec
Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash
a-szfzha.ads
spec
Ada.Strings.Wide_Wide_Fixed.Wide_Wide_Hash
a-szmzco.ads
spec
Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants
a-szunau.ads
spec
Ada.Strings.Wide_Wide_Unbounded.Aux
a-szuzha.ads
spec
Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash
a-szuzti.ads
spec
Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_Io
a-tags.ads
spec
Ada.Tags
a-tasatt.ads
spec
Ada.Task_Attributes
a-taside.ads
spec
Ada.Task_Identification
a-taster.ads
spec
Ada.Task_Termination
a-teioed.ads
spec
Ada.Text_Io.Editing
a-textio.ads
spec
Ada.Text_Io
a-tiboio.ads
spec
Ada.Text_Io.Bounded_Io
a-ticoau.ads
spec
Ada.Text_Io.Complex_Aux
a-ticoio.ads
spec
Ada.Text_Io.Complex_Io
a-tideau.ads
spec
Ada.Text_Io.Decimal_Aux
a-tideio.ads
spec
Ada.Text_Io.Decimal_Io
a-tienau.ads
spec
Ada.Text_Io.Enumeration_Aux
a-tienio.ads
spec
Ada.Text_Io.Enumeration_Io
a-tifiau.ads
spec
Ada.Text_Io.Fixed_Aux
a-tifiio.ads
spec
Ada.Text_Io.Fixed_Io
a-tiflau.ads
spec
Ada.Text_Io.Float_Aux
a-tiflio.ads
spec
Ada.Text_Io.Float_Io
a-tigeau.ads
spec
Ada.Text_Io.Generic_Aux
a-tiinau.ads
spec
Ada.Text_Io.Integer_Aux
a-tiinio.ads
spec
Ada.Text_Io.Integer_Io
a-timoau.ads
spec
Ada.Text_Io.Modular_Aux
a-timoio.ads
spec
Ada.Text_Io.Modular_Io
a-tiocst.ads
spec
Ada.Text_Io.C_Streams
a-titest.ads
spec
Ada.Text_Io.Text_Streams
a-tiunio.ads
spec
Ada.Text_Io.Unbounded_Io
a-unccon.ads
spec
Ada.Unchecked_Conversion
a-uncdea.ads
spec
Ada.Unchecked_Deallocation
a-wichun.ads
spec
Ada.Wide_Characters.Unicode
a-widcha.ads
spec
Ada.Wide_Characters
a-witeio.ads
spec
Ada.Wide_Text_Io
a-wtcoau.ads
spec
Ada.Wide_Text_Io.Complex_Aux
a-wtcoio.ads
spec
Ada.Wide_Text_Io.Complex_Io
a-wtcstr.ads
spec
Ada.Wide_Text_Io.C_Streams
a-wtdeau.ads
spec
Ada.Wide_Text_Io.Decimal_Aux
a-wtdeio.ads
spec
Ada.Wide_Text_Io.Decimal_Io
a-wtedit.ads
spec
Ada.Wide_Text_Io.Editing
a-wtenau.ads
spec
Ada.Wide_Text_Io.Enumeration_Aux
a-wtenio.ads
spec
Ada.Wide_Text_Io.Enumeration_Io
a-wtfiio.ads
spec
Ada.Wide_Text_Io.Fixed_Io
a-wtflau.ads
spec
Ada.Wide_Text_Io.Float_Aux
a-wtflio.ads
spec
Ada.Wide_Text_Io.Float_Io
a-wtgeau.ads
spec
Ada.Wide_Text_Io.Generic_Aux
a-wtinau.ads
spec
Ada.Wide_Text_Io.Integer_Aux
a-wtinio.ads
spec
Ada.Wide_Text_Io.Integer_Io
a-wtmoau.ads
spec
Ada.Wide_Text_Io.Modular_Aux
a-wtmoio.ads
spec
Ada.Wide_Text_Io.Modular_Io
a-wttest.ads
spec
Ada.Wide_Text_Io.Text_Streams
a-wwboio.ads
spec
Ada.Wide_Text_Io.Wide_Bounded_Io
a-wwunio.ads
spec
Ada.Wide_Text_Io.Wide_Unbounded_Io
a-zchara.ads
spec
Ada.Wide_Wide_Characters
a-zchuni.ads
spec
Ada.Wide_Wide_Characters.Unicode
a-ztcoau.ads
spec
Ada.Wide_Wide_Text_Io.Complex_Aux
a-ztcoio.ads
spec
Ada.Wide_Wide_Text_Io.Complex_Io
a-ztcstr.ads
spec
Ada.Wide_Wide_Text_Io.C_Streams
a-ztdeau.ads
spec
Ada.Wide_Wide_Text_Io.Decimal_Aux
a-ztdeio.ads
spec
Ada.Wide_Wide_Text_Io.Decimal_Io
a-ztedit.ads
spec
Ada.Wide_Wide_Text_Io.Editing
a-ztenau.ads
spec
Ada.Wide_Wide_Text_Io.Enumeration_Aux
a-ztenio.ads
spec
Ada.Wide_Wide_Text_Io.Enumeration_Io
a-ztexio.ads
spec
Ada.Wide_Wide_Text_Io
a-ztfiio.ads
spec
Ada.Wide_Wide_Text_Io.Fixed_Io
a-ztflau.ads
spec
Ada.Wide_Wide_Text_Io.Float_Aux
a-ztflio.ads
spec
Ada.Wide_Wide_Text_Io.Float_Io
a-ztgeau.ads
spec
Ada.Wide_Wide_Text_Io.Generic_Aux
a-ztinau.ads
spec
Ada.Wide_Wide_Text_Io.Integer_Aux
a-ztinio.ads
spec
Ada.Wide_Wide_Text_Io.Integer_Io
a-ztmoau.ads
spec
Ada.Wide_Wide_Text_Io.Modular_Aux
a-ztmoio.ads
spec
Ada.Wide_Wide_Text_Io.Modular_Io
a-zttest.ads
spec
Ada.Wide_Wide_Text_Io.Text_Streams
a-zzboio.ads
spec
Ada.Wide_Wide_Text_Io.Wide_Wide_Bounded_Io
a-zzunio.ads
spec
Ada.Wide_Wide_Text_Io.Wide_Wide_Unbounded_Io
calendar.ads
spec
Calendar
g-allein.ads
spec
GNAT.ALTIVEC.LOW_LEVEL_INTERFACE
g-alleve.ads
spec
GNAT.ALTIVEC.LOW_LEVEL_VECTORS
g-altcon.ads
spec
GNAT.ALTIVEC.CONVERSIONS
g-altdes.ads
spec
GNAT.ALTIVEC.DESIGN
g-altive.ads
spec
GNAT.ALTIVEC
g-alveop.ads
spec
GNAT.ALTIVEC.VECTOR_OPERATIONS
g-alvety.ads
spec
GNAT.ALTIVEC.VECTOR_TYPES
g-alvevi.ads
spec
GNAT.ALTIVEC.VECTOR_VIEWS
g-arrspl.ads
spec
Gnat.Array_Split
g-awk.ads
spec
GNAT.AWK
g-boubuf.ads
spec
GNAT.BOUNDED_BUFFERS
g-boumai.ads
spec
GNAT.BOUNDED_MAILBOXES
g-bubsor.ads
spec
GNAT.BUBBLE_SORT
g-busora.ads
spec
GNAT.BUBBLE_SORT_A
g-busorg.ads
spec
Gnat.Bubble_Sort_G
g-bytswa.ads
spec
GNAT.BYTE_SWAPPING
g-calend.ads
spec
GNAT.CALENDAR
g-casuti.ads
spec
GNAT.CASE_UTIL
g-catiio.ads
spec
GNAT.CALENDAR.TIME_IO
g-cgi.ads
spec
GNAT.CGI
g-cgicoo.ads
spec
GNAT.CGI.COOKIE
g-cgideb.ads
spec
GNAT.CGI.DEBUG
g-comlin.ads
spec
GNAT.COMMAND_LINE
g-comver.ads
spec
GNAT.COMPILER_VERSION
g-crc32.ads
spec
GNAT.CRC32
g-ctrl_c.ads
spec
GNAT.CTRL_C
g-curexc.ads
spec
GNAT.CURRENT_EXCEPTION
g-debpoo.ads
spec
GNAT.DEBUG_POOLS
g-debuti.ads
spec
GNAT.DEBUG_UTILITIES
g-diopit.ads
spec
GNAT.DIRECTORY_OPERATIONS.ITERATION
g-dirope.ads
spec
GNAT.DIRECTORY_OPERATIONS
g-dynhta.ads
spec
GNAT.DYNAMIC_HTABLES
g-dyntab.ads
spec
GNAT.DYNAMIC_TABLES
g-excact.ads
spec
GNAT.EXCEPTION_ACTIONS
g-except.ads
spec
GNAT.EXCEPTIONS
g-exctra.ads
spec
GNAT.EXCEPTION_TRACES
g-expect.ads
spec
GNAT.EXPECT
g-flocon.ads
spec
GNAT.FLOAT_CONTROL
g-heasor.ads
spec
GNAT.HEAP_SORT
g-hesora.ads
spec
GNAT.HEAP_SORT_A
g-hesorg.ads
spec
Gnat.Heap_Sort_G
g-htable.ads
spec
GNAT.HTABLE
g-io.ads
spec
GNAT.IO
g-io_aux.ads
spec
GNAT.IO_AUX
g-locfil.ads
spec
GNAT.LOCK_FILES
g-md5.ads
spec
GNAT.MD5
g-memdum.ads
spec
GNAT.MEMORY_DUMP
g-moreex.ads
spec
GNAT.MOST_RECENT_EXCEPTION
g-os_lib.ads
spec
GNAT.OS_LIB
g-pehage.ads
spec
GNAT.PERFECT_HASH_GENERATORS
g-regexp.ads
spec
GNAT.REGEXP
g-regist.ads
spec
GNAT.REGISTRY
g-regpat.ads
spec
GNAT.REGPAT
g-semaph.ads
spec
GNAT.SEMAPHORES
g-sestin.ads
spec
GNAT.SECONDARY_STACK_INFO
g-sha1.ads
spec
GNAT.SHA1
g-signal.ads
spec
GNAT.SIGNALS
g-soccon.ads
spec
GNAT.SOCKETS.CONSTANTS
g-socket.ads
spec
GNAT.SOCKETS
g-socthi.ads
spec
GNAT.SOCKETS.THIN
g-soliop.ads
spec
GNAT.SOCKETS.LINKER_OPTIONS
g-souinf.ads
spec
GNAT.SOURCE_INFO
g-speche.ads
spec
GNAT.SPELLING_CHECKER
g-spipat.ads
spec
GNAT.SPITBOL.PATTERNS
g-spitbo.ads
spec
GNAT.SPITBOL
g-sptabo.ads
spec
GNAT.SPITBOL.TABLE_BOOLEAN
g-sptain.ads
spec
GNAT.SPITBOL.TABLE_INTEGER
g-sptavs.ads
spec
GNAT.SPITBOL.TABLE_VSTRING
g-string.ads
spec
GNAT.STRINGS
g-strspl.ads
spec
GNAT.STRING_SPLIT
g-table.ads
spec
GNAT.TABLE
g-tasloc.ads
spec
GNAT.TASK_LOCK
g-thread.ads
spec
GNAT.THREADS
g-traceb.ads
spec
GNAT.TRACEBACK
g-trasym.ads
spec
GNAT.TRACEBACK.SYMBOLIC
g-utf_32.ads
spec
GNAT.UTF_32
g-wistsp.ads
spec
GNAT.WIDE_STRING_SPLIT
g-zstspl.ads
spec
GNAT.WIDE_WIDE_STRING_SPLIT
gnat.ads
spec
GNAT
i-c.ads
spec
Interfaces.C
i-cexten.ads
spec
Interfaces.C.Extensions
i-cobol.ads
spec
Interfaces.Cobol
i-cpoint.ads
spec
Interfaces.C.Pointers
i-cpp.ads
spec
Interfaces.Cpp
i-cstrea.ads
spec
Interfaces.C_Streams
i-cstrin.ads
spec
Interfaces.C.Strings
i-forbla.ads
spec
Interfaces.Fortran.Blas
i-forlap.ads
spec
Interfaces.Fortran.Lapack
i-fortra.ads
spec
Interfaces.Fortran
i-jalaob.ads
spec
Interfaces.Java.Lang.Object
i-jalasy.ads
spec
Interfaces.Java.Lang.System
i-jalath.ads
spec
Interfaces.Java.Lang.Thread
i-java.ads
spec
Interfaces.Java
i-javlan.ads
spec
Interfaces.Java.Lang
i-pacdec.ads
spec
Interfaces.Packed_Decimal
i-vxwoio.ads
spec
Interfaces.Vxworks.Io
i-vxwork.ads
spec
Interfaces.Vxworks
interfac.ads
spec
Interfaces
machcode.ads
spec
Machine_Code
s-addima.ads
spec
System.Address_Image
s-addope.ads
spec
System.Address_Operations
s-arit64.ads
spec
System.Arith_64
s-assert.ads
spec
System.Assertions
s-asthan.ads
spec
System.Ast_Handling
s-atacco.ads
spec
System.Address_To_Access_Conversions
s-auxdec.ads
spec
System.Aux_Dec
s-auxvad.ads
spec
System.Aux_Vads_Sgi
s-bb.ads
spec
System.Bb
s-bbinte.ads
spec
System.Bb.Interrupts
s-bbprot.ads
spec
System.Bb.Protection
s-bbseou.ads
spec
System.Bb.Serial_Output
s-bbthqu.ads
spec
System.Bb.Threads.Queues
s-bbthre.ads
spec
System.Bb.Threads
s-bbtime.ads
spec
System.Bb.Time
s-bitops.ads
spec
System.Bit_Ops
s-boarop.ads
spec
System.Boolean_Array_Operations
s-carsi8.ads
spec
System.Compare_Array_Signed_8
s-carun8.ads
spec
System.Compare_Array_Unsigned_8
s-casi16.ads
spec
System.Compare_Array_Signed_16
s-casi32.ads
spec
System.Compare_Array_Signed_32
s-casi64.ads
spec
System.Compare_Array_Signed_64
s-casuti.ads
spec
System.Case_Util
s-caun16.ads
spec
System.Compare_Array_Unsigned_16
s-caun32.ads
spec
System.Compare_Array_Unsigned_32
s-caun64.ads
spec
System.Compare_Array_Unsigned_64
s-chepoo.ads
spec
System.Checked_Pools
s-crc32.ads
spec
System.Crc32
s-crtl.ads
spec
System.Crtl
s-direio.ads
spec
System.Direct_Io
s-dsaser.ads
spec
System.Dsa_Services
s-errrep.ads
spec
System.Error_Reporting
s-exctab.ads
spec
System.Exception_Table
s-exnint.ads
spec
System.Exn_Int
s-exnllf.ads
spec
System.Exn_Llf
s-exnlli.ads
spec
System.Exn_Lli
s-expint.ads
spec
System.Exp_Int
s-explli.ads
spec
System.Exp_Lli
s-expllu.ads
spec
System.Exp_Llu
s-expmod.ads
spec
System.Exp_Mod
s-expuns.ads
spec
System.Exp_Uns
s-fatflt.ads
spec
System.Fat_Flt
s-fatgen.ads
spec
System.Fat_Gen
s-fatlfl.ads
spec
System.Fat_Lflt
s-fatllf.ads
spec
System.Fat_Llf
s-fatsfl.ads
spec
System.Fat_Sflt
s-ficobl.ads
spec
System.File_Control_Block
s-fileio.ads
spec
System.File_Io
s-filofl.ads
spec
System.Fat_Ieee_Long_Float
s-finimp.ads
spec
System.Finalization_Implementation
s-finroo.ads
spec
System.Finalization_Root
s-fishfl.ads
spec
System.Fat_Ieee_Short_Float
s-fore.ads
spec
System.Fore
s-fvadfl.ads
spec
System.Fat_Vax_D_Float
s-fvaffl.ads
spec
System.Fat_Vax_F_Float
s-fvagfl.ads
spec
System.Fat_Vax_G_Float
s-gearop.ads
spec
System.Generic_Array_Operations
s-gecobl.ads
spec
System.Generic_Complex_Blas
s-gecola.ads
spec
System.Generic_Complex_Lapack
s-gerebl.ads
spec
System.Generic_Real_Blas
s-gerela.ads
spec
System.Generic_Real_Lapack
s-geveop.ads
spec
System.Generic_Vector_Operations
s-gloloc.ads
spec
System.Global_Locks
s-hibaen.ads
spec
System.Hie_Back_End
s-htable.ads
spec
System.Htable
s-imgbiu.ads
spec
System.Img_Biu
s-imgboo.ads
spec
System.Img_Bool
s-imgcha.ads
spec
System.Img_Char
s-imgdec.ads
spec
System.Img_Dec
s-imgenu.ads
spec
System.Img_Enum
s-imgint.ads
spec
System.Img_Int
s-imgllb.ads
spec
System.Img_Llb
s-imglld.ads
spec
System.Img_Lld
s-imglli.ads
spec
System.Img_Lli
s-imgllu.ads
spec
System.Img_Llu
s-imgllw.ads
spec
System.Img_Llw
s-imgrea.ads
spec
System.Img_Real
s-imguns.ads
spec
System.Img_Uns
s-imgwch.ads
spec
System.Img_Wchar
s-imgwiu.ads
spec
System.Img_Wiu
s-inmaop.ads
spec
System.Interrupt_Management.Operations
s-interr.ads
spec
System.Interrupts
s-intman.ads
spec
System.Interrupt_Management
s-io.ads
spec
System.Io
s-maccod.ads
spec
System.Machine_Code
s-mantis.ads
spec
System.Mantissa
s-memcop.ads
spec
System.Memory_Copy
s-memory.ads
spec
System.Memory
s-osinte.ads
spec
System.Os_Interface
s-osprim.ads
spec
System.Os_Primitives
s-pack03.ads
spec
System.Pack_03
s-pack05.ads
spec
System.Pack_05
s-pack06.ads
spec
System.Pack_06
s-pack07.ads
spec
System.Pack_07
s-pack09.ads
spec
System.Pack_09
s-pack10.ads
spec
System.Pack_10
s-pack11.ads
spec
System.Pack_11
s-pack12.ads
spec
System.Pack_12
s-pack13.ads
spec
System.Pack_13
s-pack14.ads
spec
System.Pack_14
s-pack15.ads
spec
System.Pack_15
s-pack17.ads
spec
System.Pack_17
s-pack18.ads
spec
System.Pack_18
s-pack19.ads
spec
System.Pack_19
s-pack20.ads
spec
System.Pack_20
s-pack21.ads
spec
System.Pack_21
s-pack22.ads
spec
System.Pack_22
s-pack23.ads
spec
System.Pack_23
s-pack24.ads
spec
System.Pack_24
s-pack25.ads
spec
System.Pack_25
s-pack26.ads
spec
System.Pack_26
s-pack27.ads
spec
System.Pack_27
s-pack28.ads
spec
System.Pack_28
s-pack29.ads
spec
System.Pack_29
s-pack30.ads
spec
System.Pack_30
s-pack31.ads
spec
System.Pack_31
s-pack33.ads
spec
System.Pack_33
s-pack34.ads
spec
System.Pack_34
s-pack35.ads
spec
System.Pack_35
s-pack36.ads
spec
System.Pack_36
s-pack37.ads
spec
System.Pack_37
s-pack38.ads
spec
System.Pack_38
s-pack39.ads
spec
System.Pack_39
s-pack40.ads
spec
System.Pack_40
s-pack41.ads
spec
System.Pack_41
s-pack42.ads
spec
System.Pack_42
s-pack43.ads
spec
System.Pack_43
s-pack44.ads
spec
System.Pack_44
s-pack45.ads
spec
System.Pack_45
s-pack46.ads
spec
System.Pack_46
s-pack47.ads
spec
System.Pack_47
s-pack48.ads
spec
System.Pack_48
s-pack49.ads
spec
System.Pack_49
s-pack50.ads
spec
System.Pack_50
s-pack51.ads
spec
System.Pack_51
s-pack52.ads
spec
System.Pack_52
s-pack53.ads
spec
System.Pack_53
s-pack54.ads
spec
System.Pack_54
s-pack55.ads
spec
System.Pack_55
s-pack56.ads
spec
System.Pack_56
s-pack57.ads
spec
System.Pack_57
s-pack58.ads
spec
System.Pack_58
s-pack59.ads
spec
System.Pack_59
s-pack60.ads
spec
System.Pack_60
s-pack61.ads
spec
System.Pack_61
s-pack62.ads
spec
System.Pack_62
s-pack63.ads
spec
System.Pack_63
s-parame.ads
spec
System.Parameters
s-parint.ads
spec
System.Partition_Interface
s-pooglo.ads
spec
System.Pool_Global
s-pooloc.ads
spec
System.Pool_Local
s-poosiz.ads
spec
System.Pool_Size
s-powtab.ads
spec
System.Powten_Table
s-proinf.ads
spec
System.Program_Info
s-purexc.ads
spec
System.Pure_Exceptions
s-restri.ads
spec
System.Restrictions
s-rident.ads
spec
System.Rident
s-rpc.ads
spec
System.Rpc
s-scaval.ads
spec
System.Scalar_Values
s-secsta.ads
spec
System.Secondary_Stack
s-sequio.ads
spec
System.Sequential_Io
s-shasto.ads
spec
System.Shared_Storage
s-soflin.ads
spec
System.Soft_Links
s-solita.ads
spec
System.Soft_Links.Tasking
s-sopco3.ads
spec
System.String_Ops_Concat_3
s-sopco4.ads
spec
System.String_Ops_Concat_4
s-sopco5.ads
spec
System.String_Ops_Concat_5
s-stache.ads
spec
System.Stack_Checking
s-stausa.ads
spec
System.Stack_Usage
s-stoele.ads
spec
System.Storage_Elements
s-stopoo.ads
spec
System.Storage_Pools
s-stratt.ads
spec
System.Stream_Attributes
s-strcom.ads
spec
System.String_Compare
s-strops.ads
spec
System.String_Ops
s-taasde.ads
spec
System.Tasking.Async_Delays
s-tadeca.ads
spec
System.Tasking.Async_Delays.Enqueue_Calendar
s-tadert.ads
spec
System.Tasking.Async_Delays.Enqueue_Rt
s-taenca.ads
spec
System.Tasking.Entry_Calls
s-taprob.ads
spec
System.Tasking.Protected_Objects
s-taprop.ads
spec
System.Task_Primitives.Operations
s-tarest.ads
spec
System.Tasking.Restricted.Stages
s-tasdeb.ads
spec
System.Tasking.Debug
s-tasinf.ads
spec
System.Task_Info
s-tasini.ads
spec
System.Tasking.Initialization
s-taskin.ads
spec
System.Tasking
s-tasque.ads
spec
System.Tasking.Queuing
s-tasren.ads
spec
System.Tasking.Rendezvous
s-tasres.ads
spec
System.Tasking.Restricted
s-tassta.ads
spec
System.Tasking.Stages
s-tasuti.ads
spec
System.Tasking.Utilities
s-tataat.ads
spec
System.Tasking.Task_Attributes
s-thread.ads
spec
System.Threads
s-tpinop.ads
spec
System.Task_Primitives.Interrupt_Operations
s-tpoben.ads
spec
System.Tasking.Protected_Objects.Entries
s-tpobop.ads
spec
System.Tasking.Protected_Objects.Operations
s-tposen.ads
spec
System.Tasking.Protected_Objects.Single_Entry
s-traces.ads
spec
System.Traces
s-traent.ads
spec
System.Traceback_Entries
s-tratas.ads
spec
System.Traces.Tasking
s-unstyp.ads
spec
System.Unsigned_Types
s-vaflop.ads
spec
System.Vax_Float_Operations
s-valboo.ads
spec
System.Val_Bool
s-valcha.ads
spec
System.Val_Char
s-valdec.ads
spec
System.Val_Dec
s-valenu.ads
spec
System.Val_Enum
s-valint.ads
spec
System.Val_Int
s-vallld.ads
spec
System.Val_Lld
s-vallli.ads
spec
System.Val_Lli
s-valllu.ads
spec
System.Val_Llu
s-valrea.ads
spec
System.Val_Real
s-valuns.ads
spec
System.Val_Uns
s-valuti.ads
spec
System.Val_Util
s-valwch.ads
spec
System.Val_Wchar
s-veboop.ads
spec
System.Vectors.Boolean_Operations
s-vector.ads
spec
System.Vectors
s-vercon.ads
spec
System.Version_Control
s-vmexta.ads
spec
System.Vms_Exception_Table
s-vxwexc.ads
spec
System.Vxworks_Exceptions
s-wchcnv.ads
spec
System.Wch_Cnv
s-wchcon.ads
spec
System.Wch_Con
s-wchjis.ads
spec
System.Wch_Jis
s-wchstw.ads
spec
System.Wch_Stw
s-wchwts.ads
spec
System.Wch_Wts
s-widboo.ads
spec
System.Wid_Bool
s-widcha.ads
spec
System.Wid_Char
s-widenu.ads
spec
System.Wid_Enum
s-widlli.ads
spec
System.Wid_Lli
s-widllu.ads
spec
System.Wid_Llu
s-widwch.ads
spec
System.Wid_Wchar
s-wwdcha.ads
spec
System.Wwd_Char
s-wwdenu.ads
spec
System.Wwd_Enum
s-wwdwch.ads
spec
System.Wwd_Wchar
system.ads
spec
System
unchconv.ads
spec
Unchecked_Conversion
unchdeal.ads
spec
Unchecked_Deallocation
gprbuild-gpl-2014-src/share/gprconfig/cross.xml 0000644 0000767 0000145 00000063475 12203444510 021077 0 ustar gnatmail gnat
package Builder is
for Executable_Suffix use ".axe";
end Builder;
package Builder is
for Executable_Suffix use ".exe";
end Builder;
package Builder is
for Executable_Suffix use "";
end Builder;
Wind_Base := external ("WIND_BASE");
Wind_Usr := external ("WIND_USR", Wind_Base & "/target/usr/");
Pikeos_Target_Files := external ("PIKEOS_TARGET_FILES");
WRS_RTP_Base := external ("WRS_RTP_BASE", "0x40000000");
package Builder is
for Executable_Suffix use ".out";
end Builder;
package Builder is
for Executable_Suffix use ".vxe";
end Builder;
package Linker is
for Required_Switches use
Linker'Required_Switches & ("-mrtp");
end Linker;
package Compiler is
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C")
& ("-mlongcall");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C++") use
Compiler'Leading_Required_Switches ("C++")
& ("-mlongcall");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C")
& ("-mlong-calls");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C++") use
Compiler'Leading_Required_Switches ("C++")
& ("-mlong-calls");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C")
& ("-fno-builtin");
end Compiler;
-- Traditionally the entry point of a native application is _p4_entry. For
-- an APEX application, it is _begin.
-- In order to use the same link options for both personalities, _begin is
-- used for native as well.
package Linker is
for Required_Switches use
Linker'Required_Switches
& ("-u_begin", "-e_begin", "-nostdlib", "-Tapp-ld-script",
"-lvm", "-lp4", "-lstand", "-lgcc",
"-L" & Pikeos_Target_Files & "/scripts",
"-L" & Pikeos_Target_Files & "/lib");
end Linker;
package Linker is
for Required_Switches use
Linker'Required_Switches
& ("-Wl,--defsym,__wrs_rtp_base=" & WRS_RTP_Base,
"-mrtp");
end Linker;
package Linker is
for Required_Switches use
Linker'Required_Switches
& ("-Wl,--defsym,__wrs_rtp_base=" & WRS_RTP_Base,
"-mrtp");
end Linker;
package Compiler is
for Leading_Required_Switches ("Ada") use
Compiler'Leading_Required_Switches ("Ada") & ("-mrtp");
end Compiler;
package Linker is
for Required_Switches use
Linker'Required_Switches & ("-mrtp");
end Linker;
package Compiler is
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C") & ("-mrtp")
& ("-I" & Wind_Base & "/target/usr/h",
"-I" & Wind_Base & "/target/usr/h/wrn/coreip");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C")
& ("-DVTHREADS",
"-I" & Wind_Base & "/target/vThreads/h",
"-I" & Wind_Base & "/target/val/h");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C")
& ("-I" & Wind_Base & "/target/include");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C")
& ("-I" & Wind_Base & "/target/h",
"-I" & Wind_Base & "/target/h/wrn/coreip");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C")
& ("-I" & Wind_Base & "/target/h",
"-msoft-float");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C")
& ("-I" & Wind_Base & "/target/h");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C++") use
Compiler'Leading_Required_Switches ("C++") & ("-mrtp")
& ("-I" & Wind_Base & "/target/usr/h",
"-I" & Wind_Base & "/target/usr/h/wrn/coreip");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C++") use
Compiler'Leading_Required_Switches ("C++")
& ("-I" & Wind_Base & "/target/h",
"-I" & Wind_Base & "/target/h/wrn/coreip");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C")
& ("-te500v2", "-fno-implicit-fp");
for Leading_Required_Switches ("C++") use
Compiler'Leading_Required_Switches ("C++")
& ("-te500v2", "-fno-implicit-fp");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C++") use
Compiler'Leading_Required_Switches ("C++")
& ("-DVTHREADS",
"-I" & Wind_Base & "/target/vThreads/h",
"-I" & Wind_Base & "/target/val/h");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C++") use
Compiler'Leading_Required_Switches ("C++")
& ("-I" & Wind_Base & "/target/include");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C")
& ("-fno-builtin");
end Compiler;
package Compiler is
for Leading_Required_Switches ("C++") use
Compiler'Leading_Required_Switches ("C++")
& ("-fno-builtin");
end Compiler;
package Builder is
for Executable_Suffix use ".out";
end Builder;
package Binder is
for Required_Switches ("Ada") use
Binder'Required_Switches ("Ada") &
("gnatbind_prefix=${PREFIX(ada)}");
end Binder;
gprbuild-gpl-2014-src/share/gprconfig/targetset.xml 0000644 0000767 0000145 00000016070 12277050514 021745 0 ustar gnatmail gnat
x86-elinos-linux
i686-elinos-linux
ppc-elinos-linux
powerpc-elinos-linux
e500v2-wrs-linux
e500v2-wrs-linux
ppc-wrs-linux
powerpc-wrs-linux
x86-linux
i.86-.*linux.*
x86_64-linux
x86_64-.*linux.*
ia64-hp_linux
ia64-sgi_linux
ia64-.*linux.*
sparc-solaris
sparc-.*solaris.*
sparc64-solaris
sparc64-.*solaris.*
x86-solaris
i.86-(pc-)?solaris.*
x86-windows
mingw32
i.86-.*mingw32.*
pentium-.*mingw32.*
x86_64-windows
x86_64-.*mingw32.*
ppc-darwin
powerpc.*darwin.*
x86-darwin
i.86-.*-darwin.*
x86_64-darwin
x86_64-.*-darwin.*
pa-hpux
hppa.*-hpux.*
ia64-hpux
ia64-.*hpux.*
alpha-tru64
alpha.*osf.*
alpha-openvms
alpha64-dec-openvms.*
mips-irix
mips-.*irix.*
ppc-aix
powerpc.*-aix.*
x86-lynx
i.86-.*-lynxos
i.*-cygwin.*
pent.*-cygwin.*
x86-freebsd
i.86-.*freebsd.*
x86_64-freebsd
x86_64-.*freebsd.*
amd64-.*freebsd.*
aamp
.*aamp.*
ppc-lynx5.*
powerpc-elf-lynxos5.*
ppc-lynx-solaris
ppc-lynx-.*
powerpc-elf-lynxos.*
ppc-xcoff-lynxos
ppc-xcoff-lynxos178.*
powerpc-xcoff-lynxos178.*
x86-lynx5.*
i386-elf-lynxos5.*
x86-wrs-vxworks
x86-vx6-windows
x86-vx6-linux
i.86-wrs-vxworks
powerpc-wrs-vxworks
ppc-vxw-solaris
ppc-vxw-windows
ppc-vx178b-solaris
ppc-vx178b-windows
ppc-vx6-solaris
ppc-vx6-windows
ppc-vx6-linux
e500v2-wrs-vxworks
e500v2-vx6-solaris
e500v2-vx6-windows
e500v2-vx6-linux
leon-wrs-vxworks
leon-vx6-linux
ppc-vx653-solaris
ppc-vx653-windows
powerpc-wrs-vxworksae
e500v2-vx653-windows
e500v2-wrs-vxworksae
ppc-vxmils-windows
powerpc-wrs-vxworksmils
e500v2-vxmils-windows
e500v2-wrs-vxworksmils
x86-vx653-windows
i.86-wrs-vxworksae
ppc-elf-solaris
ppc-elf-windows
powerpc-elf
p55-elf-windows
powerpc-eabispe
erc32-elf-solaris
erc32-elf-linux
erc32-elf.*
leon-elf-solaris
leon-elf-linux
leon-elf.*
leon3-elf-linux
leon3-elf.*
arm-elf-linux
arm-eabi
avr-elf-windows
avr
gprbuild-gpl-2014-src/share/gprconfig/windres.xml 0000644 0000767 0000145 00000002105 12033260115 021376 0 ustar gnatmail gnat
WINDRES
(i686-pc-mingw32-|x86_64-pc-mingw32-)?windres
${PREFIX}windres --version
WinRes
${PREFIX}gcc -dumpmachine
package Compiler is
for Driver ("WinRes") use "${PREFIX(WinRes)}windres";
for Leading_Required_Switches ("WinRes") use ("-i");
for Object_File_Suffix ("WinRes") use ".coff";
for Object_File_Switches ("WinRes") use ("-o", "");
end Compiler;
package Naming is
for Body_Suffix ("WinRes") use ".rc";
end Naming;
gprbuild-gpl-2014-src/share/gprconfig/clean.xml 0000644 0000767 0000145 00000000514 12160011421 021002 0 ustar gnatmail gnat
package Clean is
-- Remove the files generated by gnatinspect (in the context of GPS)
for Artifacts_In_Object_Dir use Clean'Artifacts_In_Object_Dir
& ("gnatinspect.*");
end Clean;
gprbuild-gpl-2014-src/share/share.gpr 0000644 0000767 0000145 00000000143 12323721731 017047 0 ustar gnatmail gnat project Share is
for Languages use ("XML");
for Source_Dirs use ("gprconfig");
end Share;
gprbuild-gpl-2014-src/config.sub 0000755 0000767 0000145 00000067100 10517620563 016126 0 ustar gnatmail gnat #! /bin/sh
# Configuration validation subroutine script.
# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
# Free Software Foundation, Inc.
timestamp='2001-09-07'
# This file is (in principle) common to ALL GNU software.
# The presence of a machine in this file suggests that SOME GNU software
# can handle that machine. It does not imply ALL GNU software can.
#
# This file is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT 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
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
# As a special exception to the GNU General Public License, if you
# distribute this file as part of a program that contains a
# configuration script generated by Autoconf, you may include it under
# the same distribution terms that you use for the rest of that program.
# Please send patches to .
#
# Configuration subroutine to validate and canonicalize a configuration type.
# Supply the specified configuration type as an argument.
# If it is invalid, we print an error message on stderr and exit with code 1.
# Otherwise, we print the canonical config type on stdout and succeed.
# This file is supposed to be the same for all GNU packages
# and recognize all the CPU types, system types and aliases
# that are meaningful with *any* GNU software.
# Each package is responsible for reporting which valid configurations
# it does not support. The user should be able to distinguish
# a failure to support a valid configuration from a meaningless
# configuration.
# The goal of this file is to map all the various variations of a given
# machine specification into a single specification in the form:
# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
# or in some cases, the newer four-part form:
# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM
# It is wrong to echo any other type of specification.
me=`echo "$0" | sed -e 's,.*/,,'`
usage="\
Usage: $0 [OPTION] CPU-MFR-OPSYS
$0 [OPTION] ALIAS
Canonicalize a configuration name.
Operation modes:
-h, --help print this help, then exit
-t, --time-stamp print date of last modification, then exit
-v, --version print version number, then exit
Report bugs and patches to ."
version="\
GNU config.sub ($timestamp)
Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
help="
Try \`$me --help' for more information."
# Parse command line
while test $# -gt 0 ; do
case $1 in
--time-stamp | --time* | -t )
echo "$timestamp" ; exit 0 ;;
--version | -v )
echo "$version" ; exit 0 ;;
--help | --h* | -h )
echo "$usage"; exit 0 ;;
-- ) # Stop option processing
shift; break ;;
- ) # Use stdin as input.
break ;;
-* )
echo "$me: invalid option $1$help"
exit 1 ;;
*local*)
# First pass through any local machine types.
echo $1
exit 0;;
* )
break ;;
esac
done
case $# in
0) echo "$me: missing argument$help" >&2
exit 1;;
1) ;;
*) echo "$me: too many arguments$help" >&2
exit 1;;
esac
# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any).
# Here we must recognize all the valid KERNEL-OS combinations.
maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'`
case $maybe_os in
nto-qnx* | linux-gnu* | storm-chaos* | os2-emx* | windows32-*)
os=-$maybe_os
basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`
;;
*)
basic_machine=`echo $1 | sed 's/-[^-]*$//'`
if [ $basic_machine != $1 ]
then os=`echo $1 | sed 's/.*-/-/'`
else os=; fi
;;
esac
### Let's recognize common machines as not being operating systems so
### that things like config.sub decstation-3100 work. We also
### recognize some manufacturers as not being operating systems, so we
### can provide default operating systems below.
case $os in
-sun*os*)
# Prevent following clause from handling this invalid input.
;;
-dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \
-att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \
-unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \
-convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\
-c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \
-harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \
-apple | -axis)
os=
basic_machine=$1
;;
-sim | -cisco | -oki | -wec | -winbond)
os=
basic_machine=$1
;;
-scout)
;;
-wrs)
os=-vxworks
basic_machine=$1
;;
-chorusos*)
os=-chorusos
basic_machine=$1
;;
-chorusrdb)
os=-chorusrdb
basic_machine=$1
;;
-hiux*)
os=-hiuxwe2
;;
-sco5)
os=-sco3.2v5
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-sco4)
os=-sco3.2v4
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-sco3.2.[4-9]*)
os=`echo $os | sed -e 's/sco3.2./sco3.2v/'`
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-sco3.2v[4-9]*)
# Don't forget version if it is 3.2v4 or newer.
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-sco*)
os=-sco3.2v2
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-udk*)
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-isc)
os=-isc2.2
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-clix*)
basic_machine=clipper-intergraph
;;
-isc*)
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-lynx*)
os=-lynxos
;;
-ptx*)
basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'`
;;
-windowsnt*)
os=`echo $os | sed -e 's/windowsnt/winnt/'`
;;
-psos*)
os=-psos
;;
-mint | -mint[0-9]*)
basic_machine=m68k-atari
os=-mint
;;
esac
# Decode aliases for certain CPU-COMPANY combinations.
case $basic_machine in
# Recognize the basic CPU types without company name.
# Some are omitted here because they have special meanings below.
1750a | 580 \
| a29k \
| alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \
| arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \
| c4x | clipper \
| d10v | d30v | dsp16xx \
| fr30 \
| h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \
| i370 | i860 | i960 | ia64 \
| m32r | m68000 | m68k | m88k | mcore \
| mips16 | mips64 | mips64el | mips64orion | mips64orionel \
| mips64vr4100 | mips64vr4100el | mips64vr4300 \
| mips64vr4300el | mips64vr5000 | mips64vr5000el \
| mipsbe | mipseb | mipsel | mipsle | mipstx39 | mipstx39el \
| mipsisa32 \
| mn10200 | mn10300 \
| ns16k | ns32k \
| openrisc \
| pdp10 | pdp11 | pj | pjl \
| powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \
| pyramid \
| s390 | s390x \
| sh | sh[34] | sh[34]eb | shbe | shle \
| sparc | sparc64 | sparclet | sparclite | sparcv9 | sparcv9b \
| stormy16 | strongarm \
| tahoe | thumb | tic80 | tron \
| v850 \
| we32k \
| x86 | xscale \
| z8k)
basic_machine=$basic_machine-unknown
;;
m6811 | m68hc11 | m6812 | m68hc12)
# Motorola 68HC11/12.
basic_machine=$basic_machine-unknown
os=-none
;;
m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k)
;;
# We use `pc' rather than `unknown'
# because (1) that's what they normally are, and
# (2) the word "unknown" tends to confuse beginning users.
i*86 | x86_64)
basic_machine=$basic_machine-pc
;;
# Object if more than one company name word.
*-*-*)
echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
exit 1
;;
# Recognize the basic CPU types with company name.
580-* \
| a29k-* \
| alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \
| alphapca5[67]-* | arc-* \
| arm-* | armbe-* | armle-* | armv*-* \
| bs2000-* \
| c[123]* | c30-* | [cjt]90-* | c54x-* \
| clipper-* | cray2-* | cydra-* \
| d10v-* | d30v-* \
| elxsi-* \
| f30[01]-* | f700-* | fr30-* | fx80-* \
| h8300-* | h8500-* \
| hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \
| i*86-* | i860-* | i960-* | ia64-* \
| m32r-* \
| m68000-* | m680[01234]0-* | m68360-* | m683?2-* | m68k-* \
| m88110-* | m88k-* | mcore-* \
| mips-* | mips16-* | mips64-* | mips64el-* | mips64orion-* \
| mips64orionel-* | mips64vr4100-* | mips64vr4100el-* \
| mips64vr4300-* | mips64vr4300el-* | mipsbe-* | mipseb-* \
| mipsle-* | mipsel-* | mipstx39-* | mipstx39el-* \
| none-* | np1-* | ns16k-* | ns32k-* \
| orion-* \
| pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \
| powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \
| pyramid-* \
| romp-* | rs6000-* \
| s390-* | s390x-* \
| sh-* | sh[34]-* | sh[34]eb-* | shbe-* | shle-* \
| sparc-* | sparc64-* | sparc86x-* | sparclite-* \
| sparcv9-* | sparcv9b-* | stormy16-* | strongarm-* | sv1-* \
| t3e-* | tahoe-* | thumb-* | tic30-* | tic54x-* | tic80-* | tron-* \
| v850-* | vax-* \
| we32k-* \
| x86-* | x86_64-* | xmp-* | xps100-* | xscale-* \
| ymp-* \
| z8k-*)
;;
# Recognize the various machine names and aliases which stand
# for a CPU type and a company and sometimes even an OS.
386bsd)
basic_machine=i386-unknown
os=-bsd
;;
3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc)
basic_machine=m68000-att
;;
3b*)
basic_machine=we32k-att
;;
a29khif)
basic_machine=a29k-amd
os=-udi
;;
adobe68k)
basic_machine=m68010-adobe
os=-scout
;;
alliant | fx80)
basic_machine=fx80-alliant
;;
altos | altos3068)
basic_machine=m68k-altos
;;
am29k)
basic_machine=a29k-none
os=-bsd
;;
amdahl)
basic_machine=580-amdahl
os=-sysv
;;
amiga | amiga-*)
basic_machine=m68k-unknown
;;
amigaos | amigados)
basic_machine=m68k-unknown
os=-amigaos
;;
amigaunix | amix)
basic_machine=m68k-unknown
os=-sysv4
;;
apollo68)
basic_machine=m68k-apollo
os=-sysv
;;
apollo68bsd)
basic_machine=m68k-apollo
os=-bsd
;;
aux)
basic_machine=m68k-apple
os=-aux
;;
balance)
basic_machine=ns32k-sequent
os=-dynix
;;
convex-c1)
basic_machine=c1-convex
os=-bsd
;;
convex-c2)
basic_machine=c2-convex
os=-bsd
;;
convex-c32)
basic_machine=c32-convex
os=-bsd
;;
convex-c34)
basic_machine=c34-convex
os=-bsd
;;
convex-c38)
basic_machine=c38-convex
os=-bsd
;;
cray | ymp)
basic_machine=ymp-cray
os=-unicos
;;
cray2)
basic_machine=cray2-cray
os=-unicos
;;
[cjt]90)
basic_machine=${basic_machine}-cray
os=-unicos
;;
crds | unos)
basic_machine=m68k-crds
;;
cris | cris-* | etrax*)
basic_machine=cris-axis
;;
da30 | da30-*)
basic_machine=m68k-da30
;;
decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn)
basic_machine=mips-dec
;;
delta | 3300 | motorola-3300 | motorola-delta \
| 3300-motorola | delta-motorola)
basic_machine=m68k-motorola
;;
delta88)
basic_machine=m88k-motorola
os=-sysv3
;;
dpx20 | dpx20-*)
basic_machine=rs6000-bull
os=-bosx
;;
dpx2* | dpx2*-bull)
basic_machine=m68k-bull
os=-sysv3
;;
ebmon29k)
basic_machine=a29k-amd
os=-ebmon
;;
elxsi)
basic_machine=elxsi-elxsi
os=-bsd
;;
encore | umax | mmax)
basic_machine=ns32k-encore
;;
es1800 | OSE68k | ose68k | ose | OSE)
basic_machine=m68k-ericsson
os=-ose
;;
fx2800)
basic_machine=i860-alliant
;;
genix)
basic_machine=ns32k-ns
;;
gmicro)
basic_machine=tron-gmicro
os=-sysv
;;
go32)
basic_machine=i386-pc
os=-go32
;;
h3050r* | hiux*)
basic_machine=hppa1.1-hitachi
os=-hiuxwe2
;;
h8300hms)
basic_machine=h8300-hitachi
os=-hms
;;
h8300xray)
basic_machine=h8300-hitachi
os=-xray
;;
h8500hms)
basic_machine=h8500-hitachi
os=-hms
;;
harris)
basic_machine=m88k-harris
os=-sysv3
;;
hp300-*)
basic_machine=m68k-hp
;;
hp300bsd)
basic_machine=m68k-hp
os=-bsd
;;
hp300hpux)
basic_machine=m68k-hp
os=-hpux
;;
hp3k9[0-9][0-9] | hp9[0-9][0-9])
basic_machine=hppa1.0-hp
;;
hp9k2[0-9][0-9] | hp9k31[0-9])
basic_machine=m68000-hp
;;
hp9k3[2-9][0-9])
basic_machine=m68k-hp
;;
hp9k6[0-9][0-9] | hp6[0-9][0-9])
basic_machine=hppa1.0-hp
;;
hp9k7[0-79][0-9] | hp7[0-79][0-9])
basic_machine=hppa1.1-hp
;;
hp9k78[0-9] | hp78[0-9])
# FIXME: really hppa2.0-hp
basic_machine=hppa1.1-hp
;;
hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893)
# FIXME: really hppa2.0-hp
basic_machine=hppa1.1-hp
;;
hp9k8[0-9][13679] | hp8[0-9][13679])
basic_machine=hppa1.1-hp
;;
hp9k8[0-9][0-9] | hp8[0-9][0-9])
basic_machine=hppa1.0-hp
;;
hppa-next)
os=-nextstep3
;;
hppaosf)
basic_machine=hppa1.1-hp
os=-osf
;;
hppro)
basic_machine=hppa1.1-hp
os=-proelf
;;
i370-ibm* | ibm*)
basic_machine=i370-ibm
;;
# I'm not sure what "Sysv32" means. Should this be sysv3.2?
i*86v32)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv32
;;
i*86v4*)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv4
;;
i*86v)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv
;;
i*86sol2)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-solaris2
;;
i386mach)
basic_machine=i386-mach
os=-mach
;;
i386-vsta | vsta)
basic_machine=i386-unknown
os=-vsta
;;
iris | iris4d)
basic_machine=mips-sgi
case $os in
-irix*)
;;
*)
os=-irix4
;;
esac
;;
isi68 | isi)
basic_machine=m68k-isi
os=-sysv
;;
m88k-omron*)
basic_machine=m88k-omron
;;
magnum | m3230)
basic_machine=mips-mips
os=-sysv
;;
merlin)
basic_machine=ns32k-utek
os=-sysv
;;
mingw32)
basic_machine=i386-pc
os=-mingw32
;;
miniframe)
basic_machine=m68000-convergent
;;
*mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*)
basic_machine=m68k-atari
os=-mint
;;
mipsel*-linux*)
basic_machine=mipsel-unknown
os=-linux-gnu
;;
mips*-linux*)
basic_machine=mips-unknown
os=-linux-gnu
;;
mips3*-*)
basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`
;;
mips3*)
basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown
;;
mmix*)
basic_machine=mmix-knuth
os=-mmixware
;;
monitor)
basic_machine=m68k-rom68k
os=-coff
;;
msdos)
basic_machine=i386-pc
os=-msdos
;;
mvs)
basic_machine=i370-ibm
os=-mvs
;;
ncr3000)
basic_machine=i486-ncr
os=-sysv4
;;
netbsd386)
basic_machine=i386-unknown
os=-netbsd
;;
netwinder)
basic_machine=armv4l-rebel
os=-linux
;;
news | news700 | news800 | news900)
basic_machine=m68k-sony
os=-newsos
;;
news1000)
basic_machine=m68030-sony
os=-newsos
;;
news-3600 | risc-news)
basic_machine=mips-sony
os=-newsos
;;
necv70)
basic_machine=v70-nec
os=-sysv
;;
next | m*-next )
basic_machine=m68k-next
case $os in
-nextstep* )
;;
-ns2*)
os=-nextstep2
;;
*)
os=-nextstep3
;;
esac
;;
nh3000)
basic_machine=m68k-harris
os=-cxux
;;
nh[45]000)
basic_machine=m88k-harris
os=-cxux
;;
nindy960)
basic_machine=i960-intel
os=-nindy
;;
mon960)
basic_machine=i960-intel
os=-mon960
;;
nonstopux)
basic_machine=mips-compaq
os=-nonstopux
;;
np1)
basic_machine=np1-gould
;;
nsr-tandem)
basic_machine=nsr-tandem
;;
op50n-* | op60c-*)
basic_machine=hppa1.1-oki
os=-proelf
;;
OSE68000 | ose68000)
basic_machine=m68000-ericsson
os=-ose
;;
os68k)
basic_machine=m68k-none
os=-os68k
;;
pa-hitachi)
basic_machine=hppa1.1-hitachi
os=-hiuxwe2
;;
paragon)
basic_machine=i860-intel
os=-osf
;;
pbd)
basic_machine=sparc-tti
;;
pbb)
basic_machine=m68k-tti
;;
pc532 | pc532-*)
basic_machine=ns32k-pc532
;;
pentium | p5 | k5 | k6 | nexgen)
basic_machine=i586-pc
;;
pentiumpro | p6 | 6x86 | athlon)
basic_machine=i686-pc
;;
pentiumii | pentium2)
basic_machine=i686-pc
;;
pentium-* | p5-* | k5-* | k6-* | nexgen-*)
basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
pentiumpro-* | p6-* | 6x86-* | athlon-*)
basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
pentiumii-* | pentium2-*)
basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
pn)
basic_machine=pn-gould
;;
power) basic_machine=power-ibm
;;
ppc) basic_machine=powerpc-unknown
;;
ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
ppcle | powerpclittle | ppc-le | powerpc-little)
basic_machine=powerpcle-unknown
;;
ppcle-* | powerpclittle-*)
basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
ppc64) basic_machine=powerpc64-unknown
;;
ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
ppc64le | powerpc64little | ppc64-le | powerpc64-little)
basic_machine=powerpc64le-unknown
;;
ppc64le-* | powerpc64little-*)
basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
ps2)
basic_machine=i386-ibm
;;
pw32)
basic_machine=i586-unknown
os=-pw32
;;
rom68k)
basic_machine=m68k-rom68k
os=-coff
;;
rm[46]00)
basic_machine=mips-siemens
;;
rtpc | rtpc-*)
basic_machine=romp-ibm
;;
sa29200)
basic_machine=a29k-amd
os=-udi
;;
sequent)
basic_machine=i386-sequent
;;
sh)
basic_machine=sh-hitachi
os=-hms
;;
sparclite-wrs)
basic_machine=sparclite-wrs
os=-vxworks
;;
sps7)
basic_machine=m68k-bull
os=-sysv2
;;
spur)
basic_machine=spur-unknown
;;
st2000)
basic_machine=m68k-tandem
;;
stratus)
basic_machine=i860-stratus
os=-sysv4
;;
sun2)
basic_machine=m68000-sun
;;
sun2os3)
basic_machine=m68000-sun
os=-sunos3
;;
sun2os4)
basic_machine=m68000-sun
os=-sunos4
;;
sun3os3)
basic_machine=m68k-sun
os=-sunos3
;;
sun3os4)
basic_machine=m68k-sun
os=-sunos4
;;
sun4os3)
basic_machine=sparc-sun
os=-sunos3
;;
sun4os4)
basic_machine=sparc-sun
os=-sunos4
;;
sun4sol2)
basic_machine=sparc-sun
os=-solaris2
;;
sun3 | sun3-*)
basic_machine=m68k-sun
;;
sun4)
basic_machine=sparc-sun
;;
sun386 | sun386i | roadrunner)
basic_machine=i386-sun
;;
sv1)
basic_machine=sv1-cray
os=-unicos
;;
symmetry)
basic_machine=i386-sequent
os=-dynix
;;
t3e)
basic_machine=t3e-cray
os=-unicos
;;
tic54x | c54x*)
basic_machine=tic54x-unknown
os=-coff
;;
tx39)
basic_machine=mipstx39-unknown
;;
tx39el)
basic_machine=mipstx39el-unknown
;;
tower | tower-32)
basic_machine=m68k-ncr
;;
udi29k)
basic_machine=a29k-amd
os=-udi
;;
ultra3)
basic_machine=a29k-nyu
os=-sym1
;;
v810 | necv810)
basic_machine=v810-nec
os=-none
;;
vaxv)
basic_machine=vax-dec
os=-sysv
;;
vms)
basic_machine=vax-dec
os=-vms
;;
vpp*|vx|vx-*)
basic_machine=f301-fujitsu
;;
vxworks960)
basic_machine=i960-wrs
os=-vxworks
;;
vxworks68)
basic_machine=m68k-wrs
os=-vxworks
;;
vxworks29k)
basic_machine=a29k-wrs
os=-vxworks
;;
w65*)
basic_machine=w65-wdc
os=-none
;;
w89k-*)
basic_machine=hppa1.1-winbond
os=-proelf
;;
windows32)
basic_machine=i386-pc
os=-windows32-msvcrt
;;
xmp)
basic_machine=xmp-cray
os=-unicos
;;
xps | xps100)
basic_machine=xps100-honeywell
;;
z8k-*-coff)
basic_machine=z8k-unknown
os=-sim
;;
none)
basic_machine=none-none
os=-none
;;
# Here we handle the default manufacturer of certain CPU types. It is in
# some cases the only manufacturer, in others, it is the most popular.
w89k)
basic_machine=hppa1.1-winbond
;;
op50n)
basic_machine=hppa1.1-oki
;;
op60c)
basic_machine=hppa1.1-oki
;;
mips)
if [ x$os = x-linux-gnu ]; then
basic_machine=mips-unknown
else
basic_machine=mips-mips
fi
;;
romp)
basic_machine=romp-ibm
;;
rs6000)
basic_machine=rs6000-ibm
;;
vax)
basic_machine=vax-dec
;;
pdp10)
# there are many clones, so DEC is not a safe bet
basic_machine=pdp10-unknown
;;
pdp11)
basic_machine=pdp11-dec
;;
we32k)
basic_machine=we32k-att
;;
sh3 | sh4 | sh3eb | sh4eb)
basic_machine=sh-unknown
;;
sparc | sparcv9 | sparcv9b)
basic_machine=sparc-sun
;;
cydra)
basic_machine=cydra-cydrome
;;
orion)
basic_machine=orion-highlevel
;;
orion105)
basic_machine=clipper-highlevel
;;
mac | mpw | mac-mpw)
basic_machine=m68k-apple
;;
pmac | pmac-mpw)
basic_machine=powerpc-apple
;;
c4x*)
basic_machine=c4x-none
os=-coff
;;
*-unknown)
# Make sure to match an already-canonicalized machine name.
;;
*)
echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
exit 1
;;
esac
# Here we canonicalize certain aliases for manufacturers.
case $basic_machine in
*-digital*)
basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'`
;;
*-commodore*)
basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'`
;;
*)
;;
esac
# Decode manufacturer-specific aliases for certain operating systems.
if [ x"$os" != x"" ]
then
case $os in
# First match some system type aliases
# that might get confused with valid system types.
# -solaris* is a basic system type, with this one exception.
-solaris1 | -solaris1.*)
os=`echo $os | sed -e 's|solaris1|sunos4|'`
;;
-solaris)
os=-solaris2
;;
-svr4*)
os=-sysv4
;;
-unixware*)
os=-sysv4.2uw
;;
-gnu/linux*)
os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'`
;;
# First accept the basic system types.
# The portable systems comes first.
# Each alternative MUST END IN A *, to match a version number.
# -sysv* is not here because it comes later, after sysvr4.
-gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \
| -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\
| -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \
| -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \
| -aos* \
| -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \
| -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \
| -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \
| -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \
| -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \
| -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \
| -chorusos* | -chorusrdb* \
| -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \
| -mingw32* | -linux-gnu* | -uxpv* | -beos* | -mpeix* | -udk* \
| -interix* | -uwin* | -rhapsody* | -darwin* | -opened* \
| -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \
| -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \
| -os2* | -vos*)
# Remember, each alternative MUST END IN *, to match a version number.
;;
-qnx*)
case $basic_machine in
x86-* | i*86-*)
;;
*)
os=-nto$os
;;
esac
;;
-nto*)
os=-nto-qnx
;;
-sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \
| -windows* | -osx | -abug | -netware* | -os9* | -beos* \
| -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*)
;;
-mac*)
os=`echo $os | sed -e 's|mac|macos|'`
;;
-linux*)
os=`echo $os | sed -e 's|linux|linux-gnu|'`
;;
-sunos5*)
os=`echo $os | sed -e 's|sunos5|solaris2|'`
;;
-sunos6*)
os=`echo $os | sed -e 's|sunos6|solaris3|'`
;;
-opened*)
os=-openedition
;;
-wince*)
os=-wince
;;
-osfrose*)
os=-osfrose
;;
-osf*)
os=-osf
;;
-utek*)
os=-bsd
;;
-dynix*)
os=-bsd
;;
-acis*)
os=-aos
;;
-386bsd)
os=-bsd
;;
-ctix* | -uts*)
os=-sysv
;;
-ns2 )
os=-nextstep2
;;
-nsk*)
os=-nsk
;;
# Preserve the version number of sinix5.
-sinix5.*)
os=`echo $os | sed -e 's|sinix|sysv|'`
;;
-sinix*)
os=-sysv4
;;
-triton*)
os=-sysv3
;;
-oss*)
os=-sysv3
;;
-svr4)
os=-sysv4
;;
-svr3)
os=-sysv3
;;
-sysvr4)
os=-sysv4
;;
# This must come after -sysvr4.
-sysv*)
;;
-ose*)
os=-ose
;;
-es1800*)
os=-ose
;;
-xenix)
os=-xenix
;;
-*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
os=-mint
;;
-none)
;;
*)
# Get rid of the `-' at the beginning of $os.
os=`echo $os | sed 's/[^-]*-//'`
echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2
exit 1
;;
esac
else
# Here we handle the default operating systems that come with various machines.
# The value should be what the vendor currently ships out the door with their
# machine or put another way, the most popular os provided with the machine.
# Note that if you're going to try to match "-MANUFACTURER" here (say,
# "-sun"), then you have to tell the case statement up towards the top
# that MANUFACTURER isn't an operating system. Otherwise, code above
# will signal an error saying that MANUFACTURER isn't an operating
# system, and we'll never get to this point.
case $basic_machine in
*-acorn)
os=-riscix1.2
;;
arm*-rebel)
os=-linux
;;
arm*-semi)
os=-aout
;;
pdp10-*)
os=-tops20
;;
pdp11-*)
os=-none
;;
*-dec | vax-*)
os=-ultrix4.2
;;
m68*-apollo)
os=-domain
;;
i386-sun)
os=-sunos4.0.2
;;
m68000-sun)
os=-sunos3
# This also exists in the configure program, but was not the
# default.
# os=-sunos4
;;
m68*-cisco)
os=-aout
;;
mips*-cisco)
os=-elf
;;
mips*-*)
os=-elf
;;
*-tti) # must be before sparc entry or we get the wrong os.
os=-sysv3
;;
sparc-* | *-sun)
os=-sunos4.1.1
;;
*-be)
os=-beos
;;
*-ibm)
os=-aix
;;
*-wec)
os=-proelf
;;
*-winbond)
os=-proelf
;;
*-oki)
os=-proelf
;;
*-hp)
os=-hpux
;;
*-hitachi)
os=-hiux
;;
i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent)
os=-sysv
;;
*-cbm)
os=-amigaos
;;
*-dg)
os=-dgux
;;
*-dolphin)
os=-sysv3
;;
m68k-ccur)
os=-rtu
;;
m88k-omron*)
os=-luna
;;
*-next )
os=-nextstep
;;
*-sequent)
os=-ptx
;;
*-crds)
os=-unos
;;
*-ns)
os=-genix
;;
i370-*)
os=-mvs
;;
*-next)
os=-nextstep3
;;
*-gould)
os=-sysv
;;
*-highlevel)
os=-bsd
;;
*-encore)
os=-bsd
;;
*-sgi)
os=-irix
;;
*-siemens)
os=-sysv4
;;
*-masscomp)
os=-rtu
;;
f30[01]-fujitsu | f700-fujitsu)
os=-uxpv
;;
*-rom68k)
os=-coff
;;
*-*bug)
os=-coff
;;
*-apple)
os=-macos
;;
*-atari*)
os=-mint
;;
*)
os=-none
;;
esac
fi
# Here we handle the case where we know the os, and the CPU type, but not the
# manufacturer. We pick the logical manufacturer.
vendor=unknown
case $basic_machine in
*-unknown)
case $os in
-riscix*)
vendor=acorn
;;
-sunos*)
vendor=sun
;;
-aix*)
vendor=ibm
;;
-beos*)
vendor=be
;;
-hpux*)
vendor=hp
;;
-mpeix*)
vendor=hp
;;
-hiux*)
vendor=hitachi
;;
-unos*)
vendor=crds
;;
-dgux*)
vendor=dg
;;
-luna*)
vendor=omron
;;
-genix*)
vendor=ns
;;
-mvs* | -opened*)
vendor=ibm
;;
-ptx*)
vendor=sequent
;;
-vxsim* | -vxworks*)
vendor=wrs
;;
-aux*)
vendor=apple
;;
-hms*)
vendor=hitachi
;;
-mpw* | -macos*)
vendor=apple
;;
-*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)
vendor=atari
;;
-vos*)
vendor=stratus
;;
esac
basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"`
;;
esac
echo $basic_machine$os
exit 0
# Local variables:
# eval: (add-hook 'write-file-hooks 'time-stamp)
# time-stamp-start: "timestamp='"
# time-stamp-format: "%:y-%02m-%02d"
# time-stamp-end: "'"
# End:
gprbuild-gpl-2014-src/known-problems-163 0000644 0000767 0000145 00000012344 12115157055 017347 0 ustar gnatmail gnat ========================================
Known problems in GPRBUILD version 1.6.3
========================================
Copyright (C) 2012-2013, AdaCore
The following is a listing of known problems in release 1.6.3. Except where
specifically noted, all these problems have been corrected in the development
tree of the 2.0 technology. This means they are corrected in any 1.7.0w/2.0.0w
wavefront issued subsequent to the date specified (in ISO format YYYY-MM-DD) in
the status line. This can be used to determine if a given wavefront has the fix
identified in the entry.
KP-163-M214-016 VxWorks: incompatible system headers in RTP
Problem: When compiling a C file for a RTP on VxWorks, path to
incompatible system headers are added to the configuration
and can provoke a compilation error.
Status: This was fixed in 2.0 on 2012-07-10
Workaround: Remove the following lines from the .cgpr file:
for Leading_Required_Switches ("C") use
Compiler'Leading_Required_Switches ("C")
& ("-I" & Wind_Base & "/target/h",
"-I" & Wind_Base & "/target/h/wrn/coreip");
KP-163-L921-007 Resolve --RTS relative pathes
Problem: The behaviour of --RTS switch using a relative path is different
when the switch appears on the gprbuild command line and when
the switch appears in the Builder package.
Status: This was fixed in 2.1 on 2012-12-23
Workaround: Specify the switch on the command line
KP-163-L717-025 gprconfig crashes with exception Expression_Error
Problem: If a query for the target of a compiler, such as
"gcc -dumpmachine", returns a string that includes special
characters or sequence of characters in regular expressions,
gprconfig may crash with exception Expression_error.
Status: This was fixed in 2.0 on 2012-07-18
Workaround: Remove from the path the compilers that returns such malformed
targets.
KP-163-L713-021 Exception DIRECTORY_ERROR raised when missing obj directory
Problem: The exception DIRECTORY_ERROR is raised when an externally
build project defines an object directory which does not
exists.
Status: This was fixed in 2.0 on 2012-07-13
Workaround: Create the missing object directory manually
KP-163-L624-002 Knowledge base must_match node may not have desired effect
Problem: In some cases, the toolchain that should have been ignored
by gprconfig because it doesn't satisfy must_match criterion
is added to the list of candidates anyway.
Status: This was fixed in 2.0 on 2012-06-28
Workaround: Describe a toolchain in a way that doesn't use must_match
criterion, or simply do not select a candidate that is incorrect.
KP-163-L530-060 Allow the same library project in multiple tree
Problem: An error message is reported when the same library
project is found in different aggregated projects.
Status: This was fixed in 2.0 on 2012-06-06
Workaround: Compile aggregated projects separately
KP-163-L503-024 gprbuild crashes with exception names in virtual project
Problem: gprbuild crashes if a project that is virtually extended
has one or several sources with exception names specified in
its package Naming.
Status: This was fixed in 2.0 on 2012-07-05
Workaround: Use only names that follows the naming scheme of the project.
KP-163-L321-006 Extra recompilation when using gprbuild -s -m
Problem: When gprbuild is invoked with both -s and -m and the timestamp
of a source (or the comments, but not the code) has changed,
gprbuild still recompiles the source because the switches file is
older than the source.
Status: This was fixed in 2.0 on 2012-03-21
Workaround: Use only -m.
KP-163-L320-047 gprbuild --no-indirect-imports and generic instantiations
Problem: When --no-indirect-imports is used and an imported units
is instantiated or contains an instantiation, there may be units
imported by the generic body that are sources of a project that
is not imported. In this case, gprbuild reports an error.
Status: This was fixed in 2.0 on 2012-03-27
Workaround: Import the additional projects.
KP-163-L315-021 gprbuild --no-object-check and main in project file
Problem: When gprbuild is called with --no-object-check and no main on
the command line, and there is one or several mains specified in
the project file, all sources of the project files were compiled
instead of just the closure of the mains.
Status: This was fixed in 2.0 on 2012-03-16
Workaround: Call gprbuild with a main on the command line.
KP-163-L215-032 Remove duplicate stack size option on Windows
Problem: On Windows, a stack size option such as "-XLinker --stack="
in the linker switches in the project file or on the command line
is not taken into account.
Status: This was fixed in 2.0 on 2012-02-16
Workaround: Make sure that the default stack size option is sufficient
for the execution of the program.
gprbuild-gpl-2014-src/configure 0000755 0000767 0000145 00000247272 12046434747 016072 0 ustar gnatmail gnat #! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.61 for gprbuild 2.1.
#
# Report bugs to .
#
# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
# 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
## --------------------- ##
## M4sh Initialization. ##
## --------------------- ##
# Be more Bourne compatible
DUALCASE=1; export DUALCASE # for MKS sh
if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
emulate sh
NULLCMD=:
# Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
# is contrary to our usage. Disable this feature.
alias -g '${1+"$@"}'='"$@"'
setopt NO_GLOB_SUBST
else
case `(set -o) 2>/dev/null` in
*posix*) set -o posix ;;
esac
fi
# PATH needs CR
# Avoid depending upon Character Ranges.
as_cr_letters='abcdefghijklmnopqrstuvwxyz'
as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
as_cr_Letters=$as_cr_letters$as_cr_LETTERS
as_cr_digits='0123456789'
as_cr_alnum=$as_cr_Letters$as_cr_digits
# The user is always right.
if test "${PATH_SEPARATOR+set}" != set; then
echo "#! /bin/sh" >conf$$.sh
echo "exit 0" >>conf$$.sh
chmod +x conf$$.sh
if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
PATH_SEPARATOR=';'
else
PATH_SEPARATOR=:
fi
rm -f conf$$.sh
fi
# Support unset when possible.
if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
as_unset=unset
else
as_unset=false
fi
# IFS
# We need space, tab and new line, in precisely that order. Quoting is
# there to prevent editors from complaining about space-tab.
# (If _AS_PATH_WALK were called with IFS unset, it would disable word
# splitting by setting IFS to empty value.)
as_nl='
'
IFS=" "" $as_nl"
# Find who we are. Look in the path if we contain no directory separator.
case $0 in
*[\\/]* ) as_myself=$0 ;;
*) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break
done
IFS=$as_save_IFS
;;
esac
# We did not find ourselves, most probably we were run as `sh COMMAND'
# in which case we are not to be found in the path.
if test "x$as_myself" = x; then
as_myself=$0
fi
if test ! -f "$as_myself"; then
echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
{ (exit 1); exit 1; }
fi
# Work around bugs in pre-3.0 UWIN ksh.
for as_var in ENV MAIL MAILPATH
do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
done
PS1='$ '
PS2='> '
PS4='+ '
# NLS nuisances.
for as_var in \
LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
LC_TELEPHONE LC_TIME
do
if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
eval $as_var=C; export $as_var
else
($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
fi
done
# Required to use basename.
if expr a : '\(a\)' >/dev/null 2>&1 &&
test "X`expr 00001 : '.*\(...\)'`" = X001; then
as_expr=expr
else
as_expr=false
fi
if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then
as_basename=basename
else
as_basename=false
fi
# Name of the executable.
as_me=`$as_basename -- "$0" ||
$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
X"$0" : 'X\(//\)$' \| \
X"$0" : 'X\(/\)' \| . 2>/dev/null ||
echo X/"$0" |
sed '/^.*\/\([^/][^/]*\)\/*$/{
s//\1/
q
}
/^X\/\(\/\/\)$/{
s//\1/
q
}
/^X\/\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
# CDPATH.
$as_unset CDPATH
if test "x$CONFIG_SHELL" = x; then
if (eval ":") 2>/dev/null; then
as_have_required=yes
else
as_have_required=no
fi
if test $as_have_required = yes && (eval ":
(as_func_return () {
(exit \$1)
}
as_func_success () {
as_func_return 0
}
as_func_failure () {
as_func_return 1
}
as_func_ret_success () {
return 0
}
as_func_ret_failure () {
return 1
}
exitcode=0
if as_func_success; then
:
else
exitcode=1
echo as_func_success failed.
fi
if as_func_failure; then
exitcode=1
echo as_func_failure succeeded.
fi
if as_func_ret_success; then
:
else
exitcode=1
echo as_func_ret_success failed.
fi
if as_func_ret_failure; then
exitcode=1
echo as_func_ret_failure succeeded.
fi
if ( set x; as_func_ret_success y && test x = \"\$1\" ); then
:
else
exitcode=1
echo positional parameters were not saved.
fi
test \$exitcode = 0) || { (exit 1); exit 1; }
(
as_lineno_1=\$LINENO
as_lineno_2=\$LINENO
test \"x\$as_lineno_1\" != \"x\$as_lineno_2\" &&
test \"x\`expr \$as_lineno_1 + 1\`\" = \"x\$as_lineno_2\") || { (exit 1); exit 1; }
") 2> /dev/null; then
:
else
as_candidate_shells=
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
case $as_dir in
/*)
for as_base in sh bash ksh sh5; do
as_candidate_shells="$as_candidate_shells $as_dir/$as_base"
done;;
esac
done
IFS=$as_save_IFS
for as_shell in $as_candidate_shells $SHELL; do
# Try only shells that exist, to save several forks.
if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&
{ ("$as_shell") 2> /dev/null <<\_ASEOF
if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
emulate sh
NULLCMD=:
# Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
# is contrary to our usage. Disable this feature.
alias -g '${1+"$@"}'='"$@"'
setopt NO_GLOB_SUBST
else
case `(set -o) 2>/dev/null` in
*posix*) set -o posix ;;
esac
fi
:
_ASEOF
}; then
CONFIG_SHELL=$as_shell
as_have_required=yes
if { "$as_shell" 2> /dev/null <<\_ASEOF
if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
emulate sh
NULLCMD=:
# Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
# is contrary to our usage. Disable this feature.
alias -g '${1+"$@"}'='"$@"'
setopt NO_GLOB_SUBST
else
case `(set -o) 2>/dev/null` in
*posix*) set -o posix ;;
esac
fi
:
(as_func_return () {
(exit $1)
}
as_func_success () {
as_func_return 0
}
as_func_failure () {
as_func_return 1
}
as_func_ret_success () {
return 0
}
as_func_ret_failure () {
return 1
}
exitcode=0
if as_func_success; then
:
else
exitcode=1
echo as_func_success failed.
fi
if as_func_failure; then
exitcode=1
echo as_func_failure succeeded.
fi
if as_func_ret_success; then
:
else
exitcode=1
echo as_func_ret_success failed.
fi
if as_func_ret_failure; then
exitcode=1
echo as_func_ret_failure succeeded.
fi
if ( set x; as_func_ret_success y && test x = "$1" ); then
:
else
exitcode=1
echo positional parameters were not saved.
fi
test $exitcode = 0) || { (exit 1); exit 1; }
(
as_lineno_1=$LINENO
as_lineno_2=$LINENO
test "x$as_lineno_1" != "x$as_lineno_2" &&
test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2") || { (exit 1); exit 1; }
_ASEOF
}; then
break
fi
fi
done
if test "x$CONFIG_SHELL" != x; then
for as_var in BASH_ENV ENV
do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
done
export CONFIG_SHELL
exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"}
fi
if test $as_have_required = no; then
echo This script requires a shell more modern than all the
echo shells that I found on your system. Please install a
echo modern shell, or manually run the script under such a
echo shell if you do have one.
{ (exit 1); exit 1; }
fi
fi
fi
(eval "as_func_return () {
(exit \$1)
}
as_func_success () {
as_func_return 0
}
as_func_failure () {
as_func_return 1
}
as_func_ret_success () {
return 0
}
as_func_ret_failure () {
return 1
}
exitcode=0
if as_func_success; then
:
else
exitcode=1
echo as_func_success failed.
fi
if as_func_failure; then
exitcode=1
echo as_func_failure succeeded.
fi
if as_func_ret_success; then
:
else
exitcode=1
echo as_func_ret_success failed.
fi
if as_func_ret_failure; then
exitcode=1
echo as_func_ret_failure succeeded.
fi
if ( set x; as_func_ret_success y && test x = \"\$1\" ); then
:
else
exitcode=1
echo positional parameters were not saved.
fi
test \$exitcode = 0") || {
echo No shell found that supports shell functions.
echo Please tell autoconf@gnu.org about your system,
echo including any error possibly output before this
echo message
}
as_lineno_1=$LINENO
as_lineno_2=$LINENO
test "x$as_lineno_1" != "x$as_lineno_2" &&
test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || {
# Create $as_me.lineno as a copy of $as_myself, but with $LINENO
# uniformly replaced by the line number. The first 'sed' inserts a
# line-number line after each line using $LINENO; the second 'sed'
# does the real work. The second script uses 'N' to pair each
# line-number line with the line containing $LINENO, and appends
# trailing '-' during substitution so that $LINENO is not a special
# case at line end.
# (Raja R Harinath suggested sed '=', and Paul Eggert wrote the
# scripts with optimization help from Paolo Bonzini. Blame Lee
# E. McMahon (1931-1989) for sed's syntax. :-)
sed -n '
p
/[$]LINENO/=
' <$as_myself |
sed '
s/[$]LINENO.*/&-/
t lineno
b
:lineno
N
:loop
s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
t loop
s/-\n.*//
' >$as_me.lineno &&
chmod +x "$as_me.lineno" ||
{ echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2
{ (exit 1); exit 1; }; }
# Don't try to exec as it changes $[0], causing all sort of problems
# (the dirname of $[0] is not the place where we might find the
# original and so on. Autoconf is especially sensitive to this).
. "./$as_me.lineno"
# Exit status is that of the last command.
exit
}
if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
as_dirname=dirname
else
as_dirname=false
fi
ECHO_C= ECHO_N= ECHO_T=
case `echo -n x` in
-n*)
case `echo 'x\c'` in
*c*) ECHO_T=' ';; # ECHO_T is single tab character.
*) ECHO_C='\c';;
esac;;
*)
ECHO_N='-n';;
esac
if expr a : '\(a\)' >/dev/null 2>&1 &&
test "X`expr 00001 : '.*\(...\)'`" = X001; then
as_expr=expr
else
as_expr=false
fi
rm -f conf$$ conf$$.exe conf$$.file
if test -d conf$$.dir; then
rm -f conf$$.dir/conf$$.file
else
rm -f conf$$.dir
mkdir conf$$.dir
fi
echo >conf$$.file
if ln -s conf$$.file conf$$ 2>/dev/null; then
as_ln_s='ln -s'
# ... but there are two gotchas:
# 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
# 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
# In both cases, we have to default to `cp -p'.
ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
as_ln_s='cp -p'
elif ln conf$$.file conf$$ 2>/dev/null; then
as_ln_s=ln
else
as_ln_s='cp -p'
fi
rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
rmdir conf$$.dir 2>/dev/null
if mkdir -p . 2>/dev/null; then
as_mkdir_p=:
else
test -d ./-p && rmdir ./-p
as_mkdir_p=false
fi
if test -x / >/dev/null 2>&1; then
as_test_x='test -x'
else
if ls -dL / >/dev/null 2>&1; then
as_ls_L_option=L
else
as_ls_L_option=
fi
as_test_x='
eval sh -c '\''
if test -d "$1"; then
test -d "$1/.";
else
case $1 in
-*)set "./$1";;
esac;
case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in
???[sx]*):;;*)false;;esac;fi
'\'' sh
'
fi
as_executable_p=$as_test_x
# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
# Sed expression to map a string onto a valid variable name.
as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
exec 7<&0 &1
# Name of the host.
# hostname on some systems (SVR3.2, Linux) returns a bogus exit status,
# so uname gets run too.
ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q`
#
# Initializations.
#
ac_default_prefix=/usr/local
ac_clean_files=
ac_config_libobj_dir=.
LIBOBJS=
cross_compiling=no
subdirs=
MFLAGS=
MAKEFLAGS=
SHELL=${CONFIG_SHELL-/bin/sh}
# Identity of this package.
PACKAGE_NAME='gprbuild'
PACKAGE_TARNAME='gprbuild'
PACKAGE_VERSION='2.1'
PACKAGE_STRING='gprbuild 2.1'
PACKAGE_BUGREPORT='report@adacore.com'
ac_subst_vars='SHELL
PATH_SEPARATOR
PACKAGE_NAME
PACKAGE_TARNAME
PACKAGE_VERSION
PACKAGE_STRING
PACKAGE_BUGREPORT
exec_prefix
prefix
program_transform_name
bindir
sbindir
libexecdir
datarootdir
datadir
sysconfdir
sharedstatedir
localstatedir
includedir
oldincludedir
docdir
infodir
htmldir
dvidir
pdfdir
psdir
libdir
localedir
mandir
DEFS
ECHO_C
ECHO_N
ECHO_T
LIBS
build_alias
host_alias
target_alias
build
build_cpu
build_vendor
build_os
host
host_cpu
host_vendor
host_os
target
target_cpu
target_vendor
target_os
ac_prefix_program
INSTALL_PROGRAM
INSTALL_SCRIPT
INSTALL_DATA
objdir
is_windows
xmlada_build_target
xmlada_prj_flags
LIBOBJS
LTLIBOBJS'
ac_subst_files=''
ac_precious_vars='build_alias
host_alias
target_alias'
# Initialize some variables set by options.
ac_init_help=
ac_init_version=false
# The variables have the same names as the options, with
# dashes changed to underlines.
cache_file=/dev/null
exec_prefix=NONE
no_create=
no_recursion=
prefix=NONE
program_prefix=NONE
program_suffix=NONE
program_transform_name=s,x,x,
silent=
site=
srcdir=
verbose=
x_includes=NONE
x_libraries=NONE
# Installation directory options.
# These are left unexpanded so users can "make install exec_prefix=/foo"
# and all the variables that are supposed to be based on exec_prefix
# by default will actually change.
# Use braces instead of parens because sh, perl, etc. also accept them.
# (The list follows the same order as the GNU Coding Standards.)
bindir='${exec_prefix}/bin'
sbindir='${exec_prefix}/sbin'
libexecdir='${exec_prefix}/libexec'
datarootdir='${prefix}/share'
datadir='${datarootdir}'
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
includedir='${prefix}/include'
oldincludedir='/usr/include'
docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
infodir='${datarootdir}/info'
htmldir='${docdir}'
dvidir='${docdir}'
pdfdir='${docdir}'
psdir='${docdir}'
libdir='${exec_prefix}/lib'
localedir='${datarootdir}/locale'
mandir='${datarootdir}/man'
ac_prev=
ac_dashdash=
for ac_option
do
# If the previous option needs an argument, assign it.
if test -n "$ac_prev"; then
eval $ac_prev=\$ac_option
ac_prev=
continue
fi
case $ac_option in
*=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;
*) ac_optarg=yes ;;
esac
# Accept the important Cygnus configure options, so we can diagnose typos.
case $ac_dashdash$ac_option in
--)
ac_dashdash=yes ;;
-bindir | --bindir | --bindi | --bind | --bin | --bi)
ac_prev=bindir ;;
-bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
bindir=$ac_optarg ;;
-build | --build | --buil | --bui | --bu)
ac_prev=build_alias ;;
-build=* | --build=* | --buil=* | --bui=* | --bu=*)
build_alias=$ac_optarg ;;
-cache-file | --cache-file | --cache-fil | --cache-fi \
| --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
ac_prev=cache_file ;;
-cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
| --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
cache_file=$ac_optarg ;;
--config-cache | -C)
cache_file=config.cache ;;
-datadir | --datadir | --datadi | --datad)
ac_prev=datadir ;;
-datadir=* | --datadir=* | --datadi=* | --datad=*)
datadir=$ac_optarg ;;
-datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \
| --dataroo | --dataro | --datar)
ac_prev=datarootdir ;;
-datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \
| --dataroot=* | --dataroo=* | --dataro=* | --datar=*)
datarootdir=$ac_optarg ;;
-disable-* | --disable-*)
ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_feature" : ".*[^-._$as_cr_alnum]" >/dev/null &&
{ echo "$as_me: error: invalid feature name: $ac_feature" >&2
{ (exit 1); exit 1; }; }
ac_feature=`echo $ac_feature | sed 's/[-.]/_/g'`
eval enable_$ac_feature=no ;;
-docdir | --docdir | --docdi | --doc | --do)
ac_prev=docdir ;;
-docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*)
docdir=$ac_optarg ;;
-dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv)
ac_prev=dvidir ;;
-dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)
dvidir=$ac_optarg ;;
-enable-* | --enable-*)
ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_feature" : ".*[^-._$as_cr_alnum]" >/dev/null &&
{ echo "$as_me: error: invalid feature name: $ac_feature" >&2
{ (exit 1); exit 1; }; }
ac_feature=`echo $ac_feature | sed 's/[-.]/_/g'`
eval enable_$ac_feature=\$ac_optarg ;;
-exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
| --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
| --exec | --exe | --ex)
ac_prev=exec_prefix ;;
-exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
| --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
| --exec=* | --exe=* | --ex=*)
exec_prefix=$ac_optarg ;;
-gas | --gas | --ga | --g)
# Obsolete; use --with-gas.
with_gas=yes ;;
-help | --help | --hel | --he | -h)
ac_init_help=long ;;
-help=r* | --help=r* | --hel=r* | --he=r* | -hr*)
ac_init_help=recursive ;;
-help=s* | --help=s* | --hel=s* | --he=s* | -hs*)
ac_init_help=short ;;
-host | --host | --hos | --ho)
ac_prev=host_alias ;;
-host=* | --host=* | --hos=* | --ho=*)
host_alias=$ac_optarg ;;
-htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht)
ac_prev=htmldir ;;
-htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \
| --ht=*)
htmldir=$ac_optarg ;;
-includedir | --includedir | --includedi | --included | --include \
| --includ | --inclu | --incl | --inc)
ac_prev=includedir ;;
-includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
| --includ=* | --inclu=* | --incl=* | --inc=*)
includedir=$ac_optarg ;;
-infodir | --infodir | --infodi | --infod | --info | --inf)
ac_prev=infodir ;;
-infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
infodir=$ac_optarg ;;
-libdir | --libdir | --libdi | --libd)
ac_prev=libdir ;;
-libdir=* | --libdir=* | --libdi=* | --libd=*)
libdir=$ac_optarg ;;
-libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
| --libexe | --libex | --libe)
ac_prev=libexecdir ;;
-libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
| --libexe=* | --libex=* | --libe=*)
libexecdir=$ac_optarg ;;
-localedir | --localedir | --localedi | --localed | --locale)
ac_prev=localedir ;;
-localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*)
localedir=$ac_optarg ;;
-localstatedir | --localstatedir | --localstatedi | --localstated \
| --localstate | --localstat | --localsta | --localst | --locals)
ac_prev=localstatedir ;;
-localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
| --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*)
localstatedir=$ac_optarg ;;
-mandir | --mandir | --mandi | --mand | --man | --ma | --m)
ac_prev=mandir ;;
-mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
mandir=$ac_optarg ;;
-nfp | --nfp | --nf)
# Obsolete; use --without-fp.
with_fp=no ;;
-no-create | --no-create | --no-creat | --no-crea | --no-cre \
| --no-cr | --no-c | -n)
no_create=yes ;;
-no-recursion | --no-recursion | --no-recursio | --no-recursi \
| --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
no_recursion=yes ;;
-oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
| --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
| --oldin | --oldi | --old | --ol | --o)
ac_prev=oldincludedir ;;
-oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
| --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
| --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
oldincludedir=$ac_optarg ;;
-prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
ac_prev=prefix ;;
-prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
prefix=$ac_optarg ;;
-program-prefix | --program-prefix | --program-prefi | --program-pref \
| --program-pre | --program-pr | --program-p)
ac_prev=program_prefix ;;
-program-prefix=* | --program-prefix=* | --program-prefi=* \
| --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
program_prefix=$ac_optarg ;;
-program-suffix | --program-suffix | --program-suffi | --program-suff \
| --program-suf | --program-su | --program-s)
ac_prev=program_suffix ;;
-program-suffix=* | --program-suffix=* | --program-suffi=* \
| --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
program_suffix=$ac_optarg ;;
-program-transform-name | --program-transform-name \
| --program-transform-nam | --program-transform-na \
| --program-transform-n | --program-transform- \
| --program-transform | --program-transfor \
| --program-transfo | --program-transf \
| --program-trans | --program-tran \
| --progr-tra | --program-tr | --program-t)
ac_prev=program_transform_name ;;
-program-transform-name=* | --program-transform-name=* \
| --program-transform-nam=* | --program-transform-na=* \
| --program-transform-n=* | --program-transform-=* \
| --program-transform=* | --program-transfor=* \
| --program-transfo=* | --program-transf=* \
| --program-trans=* | --program-tran=* \
| --progr-tra=* | --program-tr=* | --program-t=*)
program_transform_name=$ac_optarg ;;
-pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd)
ac_prev=pdfdir ;;
-pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*)
pdfdir=$ac_optarg ;;
-psdir | --psdir | --psdi | --psd | --ps)
ac_prev=psdir ;;
-psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)
psdir=$ac_optarg ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
silent=yes ;;
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
ac_prev=sbindir ;;
-sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
| --sbi=* | --sb=*)
sbindir=$ac_optarg ;;
-sharedstatedir | --sharedstatedir | --sharedstatedi \
| --sharedstated | --sharedstate | --sharedstat | --sharedsta \
| --sharedst | --shareds | --shared | --share | --shar \
| --sha | --sh)
ac_prev=sharedstatedir ;;
-sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
| --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
| --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
| --sha=* | --sh=*)
sharedstatedir=$ac_optarg ;;
-site | --site | --sit)
ac_prev=site ;;
-site=* | --site=* | --sit=*)
site=$ac_optarg ;;
-srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
ac_prev=srcdir ;;
-srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
srcdir=$ac_optarg ;;
-sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
| --syscon | --sysco | --sysc | --sys | --sy)
ac_prev=sysconfdir ;;
-sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
| --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
sysconfdir=$ac_optarg ;;
-target | --target | --targe | --targ | --tar | --ta | --t)
ac_prev=target_alias ;;
-target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
target_alias=$ac_optarg ;;
-v | -verbose | --verbose | --verbos | --verbo | --verb)
verbose=yes ;;
-version | --version | --versio | --versi | --vers | -V)
ac_init_version=: ;;
-with-* | --with-*)
ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null &&
{ echo "$as_me: error: invalid package name: $ac_package" >&2
{ (exit 1); exit 1; }; }
ac_package=`echo $ac_package | sed 's/[-.]/_/g'`
eval with_$ac_package=\$ac_optarg ;;
-without-* | --without-*)
ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null &&
{ echo "$as_me: error: invalid package name: $ac_package" >&2
{ (exit 1); exit 1; }; }
ac_package=`echo $ac_package | sed 's/[-.]/_/g'`
eval with_$ac_package=no ;;
--x)
# Obsolete; use --with-x.
with_x=yes ;;
-x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
| --x-incl | --x-inc | --x-in | --x-i)
ac_prev=x_includes ;;
-x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
| --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
x_includes=$ac_optarg ;;
-x-libraries | --x-libraries | --x-librarie | --x-librari \
| --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
ac_prev=x_libraries ;;
-x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
| --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
x_libraries=$ac_optarg ;;
-*) { echo "$as_me: error: unrecognized option: $ac_option
Try \`$0 --help' for more information." >&2
{ (exit 1); exit 1; }; }
;;
*=*)
ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='`
# Reject names that are not valid shell variable names.
expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null &&
{ echo "$as_me: error: invalid variable name: $ac_envvar" >&2
{ (exit 1); exit 1; }; }
eval $ac_envvar=\$ac_optarg
export $ac_envvar ;;
*)
# FIXME: should be removed in autoconf 3.0.
echo "$as_me: WARNING: you should use --build, --host, --target" >&2
expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&
echo "$as_me: WARNING: invalid host type: $ac_option" >&2
: ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}
;;
esac
done
if test -n "$ac_prev"; then
ac_option=--`echo $ac_prev | sed 's/_/-/g'`
{ echo "$as_me: error: missing argument to $ac_option" >&2
{ (exit 1); exit 1; }; }
fi
# Be sure to have absolute directory names.
for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \
datadir sysconfdir sharedstatedir localstatedir includedir \
oldincludedir docdir infodir htmldir dvidir pdfdir psdir \
libdir localedir mandir
do
eval ac_val=\$$ac_var
case $ac_val in
[\\/$]* | ?:[\\/]* ) continue;;
NONE | '' ) case $ac_var in *prefix ) continue;; esac;;
esac
{ echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
{ (exit 1); exit 1; }; }
done
# There might be people who depend on the old broken behavior: `$host'
# used to hold the argument of --host etc.
# FIXME: To remove some day.
build=$build_alias
host=$host_alias
target=$target_alias
# FIXME: To remove some day.
if test "x$host_alias" != x; then
if test "x$build_alias" = x; then
cross_compiling=maybe
echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host.
If a cross compiler is detected then cross compile mode will be used." >&2
elif test "x$build_alias" != "x$host_alias"; then
cross_compiling=yes
fi
fi
ac_tool_prefix=
test -n "$host_alias" && ac_tool_prefix=$host_alias-
test "$silent" = yes && exec 6>/dev/null
ac_pwd=`pwd` && test -n "$ac_pwd" &&
ac_ls_di=`ls -di .` &&
ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` ||
{ echo "$as_me: error: Working directory cannot be determined" >&2
{ (exit 1); exit 1; }; }
test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||
{ echo "$as_me: error: pwd does not report name of working directory" >&2
{ (exit 1); exit 1; }; }
# Find the source files, if location was not specified.
if test -z "$srcdir"; then
ac_srcdir_defaulted=yes
# Try the directory containing this script, then the parent directory.
ac_confdir=`$as_dirname -- "$0" ||
$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$0" : 'X\(//\)[^/]' \| \
X"$0" : 'X\(//\)$' \| \
X"$0" : 'X\(/\)' \| . 2>/dev/null ||
echo X"$0" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
}
/^X\(\/\/\)$/{
s//\1/
q
}
/^X\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
srcdir=$ac_confdir
if test ! -r "$srcdir/$ac_unique_file"; then
srcdir=..
fi
else
ac_srcdir_defaulted=no
fi
if test ! -r "$srcdir/$ac_unique_file"; then
test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .."
{ echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2
{ (exit 1); exit 1; }; }
fi
ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work"
ac_abs_confdir=`(
cd "$srcdir" && test -r "./$ac_unique_file" || { echo "$as_me: error: $ac_msg" >&2
{ (exit 1); exit 1; }; }
pwd)`
# When building in place, set srcdir=.
if test "$ac_abs_confdir" = "$ac_pwd"; then
srcdir=.
fi
# Remove unnecessary trailing slashes from srcdir.
# Double slashes in file names in object file debugging info
# mess up M-x gdb in Emacs.
case $srcdir in
*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;;
esac
for ac_var in $ac_precious_vars; do
eval ac_env_${ac_var}_set=\${${ac_var}+set}
eval ac_env_${ac_var}_value=\$${ac_var}
eval ac_cv_env_${ac_var}_set=\${${ac_var}+set}
eval ac_cv_env_${ac_var}_value=\$${ac_var}
done
#
# Report the --help message.
#
if test "$ac_init_help" = "long"; then
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat <<_ACEOF
\`configure' configures gprbuild 2.1 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
To assign environment variables (e.g., CC, CFLAGS...), specify them as
VAR=VALUE. See below for descriptions of some of the useful variables.
Defaults for the options are specified in brackets.
Configuration:
-h, --help display this help and exit
--help=short display options specific to this package
--help=recursive display the short help of all the included packages
-V, --version display version information and exit
-q, --quiet, --silent do not print \`checking...' messages
--cache-file=FILE cache test results in FILE [disabled]
-C, --config-cache alias for \`--cache-file=config.cache'
-n, --no-create do not create output files
--srcdir=DIR find the sources in DIR [configure dir or \`..']
Installation directories:
--prefix=PREFIX install architecture-independent files in PREFIX
[$ac_default_prefix]
--exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
[PREFIX]
By default, \`make install' will install all the files in
\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify
an installation prefix other than \`$ac_default_prefix' using \`--prefix',
for instance \`--prefix=\$HOME'.
For better control, use the options below.
Fine tuning of the installation directories:
--bindir=DIR user executables [EPREFIX/bin]
--sbindir=DIR system admin executables [EPREFIX/sbin]
--libexecdir=DIR program executables [EPREFIX/libexec]
--sysconfdir=DIR read-only single-machine data [PREFIX/etc]
--sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com]
--localstatedir=DIR modifiable single-machine data [PREFIX/var]
--libdir=DIR object code libraries [EPREFIX/lib]
--includedir=DIR C header files [PREFIX/include]
--oldincludedir=DIR C header files for non-gcc [/usr/include]
--datarootdir=DIR read-only arch.-independent data root [PREFIX/share]
--datadir=DIR read-only architecture-independent data [DATAROOTDIR]
--infodir=DIR info documentation [DATAROOTDIR/info]
--localedir=DIR locale-dependent data [DATAROOTDIR/locale]
--mandir=DIR man documentation [DATAROOTDIR/man]
--docdir=DIR documentation root [DATAROOTDIR/doc/gprbuild]
--htmldir=DIR html documentation [DOCDIR]
--dvidir=DIR dvi documentation [DOCDIR]
--pdfdir=DIR pdf documentation [DOCDIR]
--psdir=DIR ps documentation [DOCDIR]
_ACEOF
cat <<\_ACEOF
System types:
--build=BUILD configure for building on BUILD [guessed]
--host=HOST cross-compile to build programs to run on HOST [BUILD]
--target=TARGET configure for building compilers for TARGET [HOST]
_ACEOF
fi
if test -n "$ac_init_help"; then
case $ac_init_help in
short | recursive ) echo "Configuration of gprbuild 2.1:";;
esac
cat <<\_ACEOF
Report bugs to .
_ACEOF
ac_status=$?
fi
if test "$ac_init_help" = "recursive"; then
# If there are subdirs, report their specific --help.
for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue
test -d "$ac_dir" || continue
ac_builddir=.
case "$ac_dir" in
.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
*)
ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
# A ".." for each directory in $ac_dir_suffix.
ac_top_builddir_sub=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,/..,g;s,/,,'`
case $ac_top_builddir_sub in
"") ac_top_builddir_sub=. ac_top_build_prefix= ;;
*) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
esac ;;
esac
ac_abs_top_builddir=$ac_pwd
ac_abs_builddir=$ac_pwd$ac_dir_suffix
# for backward compatibility:
ac_top_builddir=$ac_top_build_prefix
case $srcdir in
.) # We are building in place.
ac_srcdir=.
ac_top_srcdir=$ac_top_builddir_sub
ac_abs_top_srcdir=$ac_pwd ;;
[\\/]* | ?:[\\/]* ) # Absolute name.
ac_srcdir=$srcdir$ac_dir_suffix;
ac_top_srcdir=$srcdir
ac_abs_top_srcdir=$srcdir ;;
*) # Relative name.
ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
ac_top_srcdir=$ac_top_build_prefix$srcdir
ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
esac
ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
cd "$ac_dir" || { ac_status=$?; continue; }
# Check for guested configure.
if test -f "$ac_srcdir/configure.gnu"; then
echo &&
$SHELL "$ac_srcdir/configure.gnu" --help=recursive
elif test -f "$ac_srcdir/configure"; then
echo &&
$SHELL "$ac_srcdir/configure" --help=recursive
else
echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
fi || ac_status=$?
cd "$ac_pwd" || { ac_status=$?; break; }
done
fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
gprbuild configure 2.1
generated by GNU Autoconf 2.61
Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
exit
fi
cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
It was created by gprbuild $as_me 2.1, which was
generated by GNU Autoconf 2.61. Invocation command line was
$ $0 $@
_ACEOF
exec 5>>config.log
{
cat <<_ASUNAME
## --------- ##
## Platform. ##
## --------- ##
hostname = `(hostname || uname -n) 2>/dev/null | sed 1q`
uname -m = `(uname -m) 2>/dev/null || echo unknown`
uname -r = `(uname -r) 2>/dev/null || echo unknown`
uname -s = `(uname -s) 2>/dev/null || echo unknown`
uname -v = `(uname -v) 2>/dev/null || echo unknown`
/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown`
/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown`
/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown`
/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown`
/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown`
/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown`
/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown`
/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown`
/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown`
_ASUNAME
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
echo "PATH: $as_dir"
done
IFS=$as_save_IFS
} >&5
cat >&5 <<_ACEOF
## ----------- ##
## Core tests. ##
## ----------- ##
_ACEOF
# Keep a trace of the command line.
# Strip out --no-create and --no-recursion so they do not pile up.
# Strip out --silent because we don't want to record it for future runs.
# Also quote any args containing shell meta-characters.
# Make two passes to allow for proper duplicate-argument suppression.
ac_configure_args=
ac_configure_args0=
ac_configure_args1=
ac_must_keep_next=false
for ac_pass in 1 2
do
for ac_arg
do
case $ac_arg in
-no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
continue ;;
*\'*)
ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
esac
case $ac_pass in
1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;
2)
ac_configure_args1="$ac_configure_args1 '$ac_arg'"
if test $ac_must_keep_next = true; then
ac_must_keep_next=false # Got value, back to normal.
else
case $ac_arg in
*=* | --config-cache | -C | -disable-* | --disable-* \
| -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \
| -q | -quiet | --q* | -silent | --sil* | -v | -verb* \
| -with-* | --with-* | -without-* | --without-* | --x)
case "$ac_configure_args0 " in
"$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
esac
;;
-* ) ac_must_keep_next=true ;;
esac
fi
ac_configure_args="$ac_configure_args '$ac_arg'"
;;
esac
done
done
$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; }
$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; }
# When interrupted or exit'd, cleanup temporary files, and complete
# config.log. We remove comments because anyway the quotes in there
# would cause problems or look ugly.
# WARNING: Use '\'' to represent an apostrophe within the trap.
# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.
trap 'exit_status=$?
# Save into config.log some information that might help in debugging.
{
echo
cat <<\_ASBOX
## ---------------- ##
## Cache variables. ##
## ---------------- ##
_ASBOX
echo
# The following way of writing the cache mishandles newlines in values,
(
for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do
eval ac_val=\$$ac_var
case $ac_val in #(
*${as_nl}*)
case $ac_var in #(
*_cv_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5
echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;;
esac
case $ac_var in #(
_ | IFS | as_nl) ;; #(
*) $as_unset $ac_var ;;
esac ;;
esac
done
(set) 2>&1 |
case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #(
*${as_nl}ac_space=\ *)
sed -n \
"s/'\''/'\''\\\\'\'''\''/g;
s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p"
;; #(
*)
sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
;;
esac |
sort
)
echo
cat <<\_ASBOX
## ----------------- ##
## Output variables. ##
## ----------------- ##
_ASBOX
echo
for ac_var in $ac_subst_vars
do
eval ac_val=\$$ac_var
case $ac_val in
*\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
esac
echo "$ac_var='\''$ac_val'\''"
done | sort
echo
if test -n "$ac_subst_files"; then
cat <<\_ASBOX
## ------------------- ##
## File substitutions. ##
## ------------------- ##
_ASBOX
echo
for ac_var in $ac_subst_files
do
eval ac_val=\$$ac_var
case $ac_val in
*\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
esac
echo "$ac_var='\''$ac_val'\''"
done | sort
echo
fi
if test -s confdefs.h; then
cat <<\_ASBOX
## ----------- ##
## confdefs.h. ##
## ----------- ##
_ASBOX
echo
cat confdefs.h
echo
fi
test "$ac_signal" != 0 &&
echo "$as_me: caught signal $ac_signal"
echo "$as_me: exit $exit_status"
} >&5
rm -f core *.core core.conftest.* &&
rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&
exit $exit_status
' 0
for ac_signal in 1 2 13 15; do
trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal
done
ac_signal=0
# confdefs.h avoids OS command line length limits that DEFS can exceed.
rm -f -r conftest* confdefs.h
# Predefined preprocessor variables.
cat >>confdefs.h <<_ACEOF
#define PACKAGE_NAME "$PACKAGE_NAME"
_ACEOF
cat >>confdefs.h <<_ACEOF
#define PACKAGE_TARNAME "$PACKAGE_TARNAME"
_ACEOF
cat >>confdefs.h <<_ACEOF
#define PACKAGE_VERSION "$PACKAGE_VERSION"
_ACEOF
cat >>confdefs.h <<_ACEOF
#define PACKAGE_STRING "$PACKAGE_STRING"
_ACEOF
cat >>confdefs.h <<_ACEOF
#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT"
_ACEOF
# Let the site file select an alternate cache file if it wants to.
# Prefer explicitly selected file to automatically selected ones.
if test -n "$CONFIG_SITE"; then
set x "$CONFIG_SITE"
elif test "x$prefix" != xNONE; then
set x "$prefix/share/config.site" "$prefix/etc/config.site"
else
set x "$ac_default_prefix/share/config.site" \
"$ac_default_prefix/etc/config.site"
fi
shift
for ac_site_file
do
if test -r "$ac_site_file"; then
{ echo "$as_me:$LINENO: loading site script $ac_site_file" >&5
echo "$as_me: loading site script $ac_site_file" >&6;}
sed 's/^/| /' "$ac_site_file" >&5
. "$ac_site_file"
fi
done
if test -r "$cache_file"; then
# Some versions of bash will fail to source /dev/null (special
# files actually), so we avoid doing that.
if test -f "$cache_file"; then
{ echo "$as_me:$LINENO: loading cache $cache_file" >&5
echo "$as_me: loading cache $cache_file" >&6;}
case $cache_file in
[\\/]* | ?:[\\/]* ) . "$cache_file";;
*) . "./$cache_file";;
esac
fi
else
{ echo "$as_me:$LINENO: creating cache $cache_file" >&5
echo "$as_me: creating cache $cache_file" >&6;}
>$cache_file
fi
# Check that the precious variables saved in the cache have kept the same
# value.
ac_cache_corrupted=false
for ac_var in $ac_precious_vars; do
eval ac_old_set=\$ac_cv_env_${ac_var}_set
eval ac_new_set=\$ac_env_${ac_var}_set
eval ac_old_val=\$ac_cv_env_${ac_var}_value
eval ac_new_val=\$ac_env_${ac_var}_value
case $ac_old_set,$ac_new_set in
set,)
{ echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}
ac_cache_corrupted=: ;;
,set)
{ echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5
echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}
ac_cache_corrupted=: ;;
,);;
*)
if test "x$ac_old_val" != "x$ac_new_val"; then
{ echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5
echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
{ echo "$as_me:$LINENO: former value: $ac_old_val" >&5
echo "$as_me: former value: $ac_old_val" >&2;}
{ echo "$as_me:$LINENO: current value: $ac_new_val" >&5
echo "$as_me: current value: $ac_new_val" >&2;}
ac_cache_corrupted=:
fi;;
esac
# Pass precious variables to config.status.
if test "$ac_new_set" = set; then
case $ac_new_val in
*\'*) ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;
*) ac_arg=$ac_var=$ac_new_val ;;
esac
case " $ac_configure_args " in
*" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy.
*) ac_configure_args="$ac_configure_args '$ac_arg'" ;;
esac
fi
done
if $ac_cache_corrupted; then
{ echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5
echo "$as_me: error: changes in the environment can compromise the build" >&2;}
{ { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5
echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;}
{ (exit 1); exit 1; }; }
fi
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
ac_aux_dir=
for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do
if test -f "$ac_dir/install-sh"; then
ac_aux_dir=$ac_dir
ac_install_sh="$ac_aux_dir/install-sh -c"
break
elif test -f "$ac_dir/install.sh"; then
ac_aux_dir=$ac_dir
ac_install_sh="$ac_aux_dir/install.sh -c"
break
elif test -f "$ac_dir/shtool"; then
ac_aux_dir=$ac_dir
ac_install_sh="$ac_aux_dir/shtool install -c"
break
fi
done
if test -z "$ac_aux_dir"; then
{ { echo "$as_me:$LINENO: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&5
echo "$as_me: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&2;}
{ (exit 1); exit 1; }; }
fi
# These three variables are undocumented and unsupported,
# and are intended to be withdrawn in a future Autoconf release.
# They can cause serious problems if a builder's source tree is in a directory
# whose full name contains unusual characters.
ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var.
ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var.
ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var.
# Make sure we can run config.sub.
$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 ||
{ { echo "$as_me:$LINENO: error: cannot run $SHELL $ac_aux_dir/config.sub" >&5
echo "$as_me: error: cannot run $SHELL $ac_aux_dir/config.sub" >&2;}
{ (exit 1); exit 1; }; }
{ echo "$as_me:$LINENO: checking build system type" >&5
echo $ECHO_N "checking build system type... $ECHO_C" >&6; }
if test "${ac_cv_build+set}" = set; then
echo $ECHO_N "(cached) $ECHO_C" >&6
else
ac_build_alias=$build_alias
test "x$ac_build_alias" = x &&
ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"`
test "x$ac_build_alias" = x &&
{ { echo "$as_me:$LINENO: error: cannot guess build type; you must specify one" >&5
echo "$as_me: error: cannot guess build type; you must specify one" >&2;}
{ (exit 1); exit 1; }; }
ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` ||
{ { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&5
echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&2;}
{ (exit 1); exit 1; }; }
fi
{ echo "$as_me:$LINENO: result: $ac_cv_build" >&5
echo "${ECHO_T}$ac_cv_build" >&6; }
case $ac_cv_build in
*-*-*) ;;
*) { { echo "$as_me:$LINENO: error: invalid value of canonical build" >&5
echo "$as_me: error: invalid value of canonical build" >&2;}
{ (exit 1); exit 1; }; };;
esac
build=$ac_cv_build
ac_save_IFS=$IFS; IFS='-'
set x $ac_cv_build
shift
build_cpu=$1
build_vendor=$2
shift; shift
# Remember, the first character of IFS is used to create $*,
# except with old shells:
build_os=$*
IFS=$ac_save_IFS
case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac
{ echo "$as_me:$LINENO: checking host system type" >&5
echo $ECHO_N "checking host system type... $ECHO_C" >&6; }
if test "${ac_cv_host+set}" = set; then
echo $ECHO_N "(cached) $ECHO_C" >&6
else
if test "x$host_alias" = x; then
ac_cv_host=$ac_cv_build
else
ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` ||
{ { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&5
echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&2;}
{ (exit 1); exit 1; }; }
fi
fi
{ echo "$as_me:$LINENO: result: $ac_cv_host" >&5
echo "${ECHO_T}$ac_cv_host" >&6; }
case $ac_cv_host in
*-*-*) ;;
*) { { echo "$as_me:$LINENO: error: invalid value of canonical host" >&5
echo "$as_me: error: invalid value of canonical host" >&2;}
{ (exit 1); exit 1; }; };;
esac
host=$ac_cv_host
ac_save_IFS=$IFS; IFS='-'
set x $ac_cv_host
shift
host_cpu=$1
host_vendor=$2
shift; shift
# Remember, the first character of IFS is used to create $*,
# except with old shells:
host_os=$*
IFS=$ac_save_IFS
case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac
{ echo "$as_me:$LINENO: checking target system type" >&5
echo $ECHO_N "checking target system type... $ECHO_C" >&6; }
if test "${ac_cv_target+set}" = set; then
echo $ECHO_N "(cached) $ECHO_C" >&6
else
if test "x$target_alias" = x; then
ac_cv_target=$ac_cv_host
else
ac_cv_target=`$SHELL "$ac_aux_dir/config.sub" $target_alias` ||
{ { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $target_alias failed" >&5
echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $target_alias failed" >&2;}
{ (exit 1); exit 1; }; }
fi
fi
{ echo "$as_me:$LINENO: result: $ac_cv_target" >&5
echo "${ECHO_T}$ac_cv_target" >&6; }
case $ac_cv_target in
*-*-*) ;;
*) { { echo "$as_me:$LINENO: error: invalid value of canonical target" >&5
echo "$as_me: error: invalid value of canonical target" >&2;}
{ (exit 1); exit 1; }; };;
esac
target=$ac_cv_target
ac_save_IFS=$IFS; IFS='-'
set x $ac_cv_target
shift
target_cpu=$1
target_vendor=$2
shift; shift
# Remember, the first character of IFS is used to create $*,
# except with old shells:
target_os=$*
IFS=$ac_save_IFS
case $target_os in *\ *) target_os=`echo "$target_os" | sed 's/ /-/g'`;; esac
# The aliases save the names the user supplied, while $host etc.
# will get canonicalized.
test -n "$target_alias" &&
test "$program_prefix$program_suffix$program_transform_name" = \
NONENONEs,x,x, &&
program_prefix=${target_alias}-
if test "x$prefix" = xNONE; then
echo $ECHO_N "checking for prefix by $ECHO_C" >&6
# Extract the first word of "gnatmake", so it can be a program name with args.
set dummy gnatmake; ac_word=$2
{ echo "$as_me:$LINENO: checking for $ac_word" >&5
echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
if test "${ac_cv_path_ac_prefix_program+set}" = set; then
echo $ECHO_N "(cached) $ECHO_C" >&6
else
case $ac_prefix_program in
[\\/]* | ?:[\\/]*)
ac_cv_path_ac_prefix_program="$ac_prefix_program" # Let the user override the test with a path.
;;
*)
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
ac_cv_path_ac_prefix_program="$as_dir/$ac_word$ac_exec_ext"
echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
;;
esac
fi
ac_prefix_program=$ac_cv_path_ac_prefix_program
if test -n "$ac_prefix_program"; then
{ echo "$as_me:$LINENO: result: $ac_prefix_program" >&5
echo "${ECHO_T}$ac_prefix_program" >&6; }
else
{ echo "$as_me:$LINENO: result: no" >&5
echo "${ECHO_T}no" >&6; }
fi
if test -n "$ac_prefix_program"; then
prefix=`$as_dirname -- "$ac_prefix_program" ||
$as_expr X"$ac_prefix_program" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$ac_prefix_program" : 'X\(//\)[^/]' \| \
X"$ac_prefix_program" : 'X\(//\)$' \| \
X"$ac_prefix_program" : 'X\(/\)' \| . 2>/dev/null ||
echo X"$ac_prefix_program" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
}
/^X\(\/\/\)$/{
s//\1/
q
}
/^X\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
prefix=`$as_dirname -- "$prefix" ||
$as_expr X"$prefix" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$prefix" : 'X\(//\)[^/]' \| \
X"$prefix" : 'X\(//\)$' \| \
X"$prefix" : 'X\(/\)' \| . 2>/dev/null ||
echo X"$prefix" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
}
/^X\(\/\/\)$/{
s//\1/
q
}
/^X\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
fi
fi
# Find a good install program. We prefer a C program (faster),
# so one script is as good as another. But avoid the broken or
# incompatible versions:
# SysV /etc/install, /usr/sbin/install
# SunOS /usr/etc/install
# IRIX /sbin/install
# AIX /bin/install
# AmigaOS /C/install, which installs bootblocks on floppy discs
# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag
# AFS /usr/afsws/bin/install, which mishandles nonexistent args
# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"
# OS/2's system install, which has a completely different semantic
# ./install, which can be erroneously created by make from ./install.sh.
{ echo "$as_me:$LINENO: checking for a BSD-compatible install" >&5
echo $ECHO_N "checking for a BSD-compatible install... $ECHO_C" >&6; }
if test -z "$INSTALL"; then
if test "${ac_cv_path_install+set}" = set; then
echo $ECHO_N "(cached) $ECHO_C" >&6
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
# Account for people who put trailing slashes in PATH elements.
case $as_dir/ in
./ | .// | /cC/* | \
/etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \
?:\\/os2\\/install\\/* | ?:\\/OS2\\/INSTALL\\/* | \
/usr/ucb/* ) ;;
*)
# OSF1 and SCO ODT 3.0 have their own names for install.
# Don't use installbsd from OSF since it installs stuff as root
# by default.
for ac_prog in ginstall scoinst install; do
for ac_exec_ext in '' $ac_executable_extensions; do
if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then
if test $ac_prog = install &&
grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then
# AIX install. It has an incompatible calling convention.
:
elif test $ac_prog = install &&
grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then
# program-specific install script used by HP pwplus--don't use.
:
else
ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c"
break 3
fi
fi
done
done
;;
esac
done
IFS=$as_save_IFS
fi
if test "${ac_cv_path_install+set}" = set; then
INSTALL=$ac_cv_path_install
else
# As a last resort, use the slow shell script. Don't cache a
# value for INSTALL within a source directory, because that will
# break other packages using the cache if that directory is
# removed, or if the value is a relative name.
INSTALL=$ac_install_sh
fi
fi
{ echo "$as_me:$LINENO: result: $INSTALL" >&5
echo "${ECHO_T}$INSTALL" >&6; }
# Use test -z because SunOS4 sh mishandles braces in ${var-val}.
# It thinks the first close brace ends the variable substitution.
test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'
test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}'
test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
objdir=`pwd`
case $host in
*mingw*|*cygwin*) is_windows="true";;
*) is_windows="false";;
esac
{ echo "$as_me:$LINENO: checking for xmlada" >&5
echo $ECHO_N "checking for xmlada... $ECHO_C" >&6; }
xmlada_build_target=
xmlada_prj_flags=
if test -d $srcdir/xmlada; then
xmlada_build_target=build_xmlada
xmlada_prj_flags="-aP$srcdir/xmlada/install/lib/gnat"
{ echo "$as_me:$LINENO: result: yes (sources in gprbuild tree)" >&5
echo "${ECHO_T}yes (sources in gprbuild tree)" >&6; }
else
# Create a temporary directory (from "info autoconf")
: ${TMPDIR=/tmp}
{
tmp=`(umask 077 && mktemp -d "$TMPDIR/fooXXXXXX") 2>/dev/null` \
&& test -n "$tmp" && test -d "$tmp"
} || {
tmp=$TMPDIR/foo$$-$RANDOM
(umask 077 && mkdir -p "$tmp")
} || exit $?
mkdir $tmp/lib
cat > $tmp/conftest.gpr << EOF
with "xmlada.gpr";
project Conftest is
for Source_Dirs use ();
end Conftest;
EOF
if gnatmake -P$tmp/conftest.gpr >&5 2>&1; then
{ echo "$as_me:$LINENO: result: yes (precompiled)" >&5
echo "${ECHO_T}yes (precompiled)" >&6; }
else
{ echo "$as_me:$LINENO: result: no" >&5
echo "${ECHO_T}no" >&6; }
{ { echo "$as_me:$LINENO: error: cannot find xmlada
See \`config.log' for more details." >&5
echo "$as_me: error: cannot find xmlada
See \`config.log' for more details." >&2;}
{ (exit 1); exit 1; }; }
fi
fi
ac_config_files="$ac_config_files src/gprconfig-sdefault.ads Makefile"
cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
# tests run on this system so they can be shared between configure
# scripts and configure runs, see configure's option --config-cache.
# It is not useful on other systems. If it contains results you don't
# want to keep, you may remove or edit it.
#
# config.status only pays attention to the cache file if you give it
# the --recheck option to rerun configure.
#
# `ac_cv_env_foo' variables (set or unset) will be overridden when
# loading this file, other *unset* `ac_cv_foo' will be assigned the
# following values.
_ACEOF
# The following way of writing the cache mishandles newlines in values,
# but we know of no workaround that is simple, portable, and efficient.
# So, we kill variables containing newlines.
# Ultrix sh set writes to stderr and can't be redirected directly,
# and sets the high bit in the cache file unless we assign to the vars.
(
for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do
eval ac_val=\$$ac_var
case $ac_val in #(
*${as_nl}*)
case $ac_var in #(
*_cv_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5
echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;;
esac
case $ac_var in #(
_ | IFS | as_nl) ;; #(
*) $as_unset $ac_var ;;
esac ;;
esac
done
(set) 2>&1 |
case $as_nl`(ac_space=' '; set) 2>&1` in #(
*${as_nl}ac_space=\ *)
# `set' does not quote correctly, so add quotes (double-quote
# substitution turns \\\\ into \\, and sed turns \\ into \).
sed -n \
"s/'/'\\\\''/g;
s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p"
;; #(
*)
# `set' quotes correctly as required by POSIX, so do not add quotes.
sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
;;
esac |
sort
) |
sed '
/^ac_cv_env_/b end
t clear
:clear
s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/
t end
s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/
:end' >>confcache
if diff "$cache_file" confcache >/dev/null 2>&1; then :; else
if test -w "$cache_file"; then
test "x$cache_file" != "x/dev/null" &&
{ echo "$as_me:$LINENO: updating cache $cache_file" >&5
echo "$as_me: updating cache $cache_file" >&6;}
cat confcache >$cache_file
else
{ echo "$as_me:$LINENO: not updating unwritable cache $cache_file" >&5
echo "$as_me: not updating unwritable cache $cache_file" >&6;}
fi
fi
rm -f confcache
test "x$prefix" = xNONE && prefix=$ac_default_prefix
# Let make expand exec_prefix.
test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
# Transform confdefs.h into DEFS.
# Protect against shell expansion while executing Makefile rules.
# Protect against Makefile macro expansion.
#
# If the first sed substitution is executed (which looks for macros that
# take arguments), then branch to the quote section. Otherwise,
# look for a macro that doesn't take arguments.
ac_script='
t clear
:clear
s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g
t quote
s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g
t quote
b any
:quote
s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g
s/\[/\\&/g
s/\]/\\&/g
s/\$/$$/g
H
:any
${
g
s/^\n//
s/\n/ /g
p
}
'
DEFS=`sed -n "$ac_script" confdefs.h`
ac_libobjs=
ac_ltlibobjs=
for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue
# 1. Remove the extension, and $U if already installed.
ac_script='s/\$U\././;s/\.o$//;s/\.obj$//'
ac_i=`echo "$ac_i" | sed "$ac_script"`
# 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR
# will be set to the directory where LIBOBJS objects are built.
ac_libobjs="$ac_libobjs \${LIBOBJDIR}$ac_i\$U.$ac_objext"
ac_ltlibobjs="$ac_ltlibobjs \${LIBOBJDIR}$ac_i"'$U.lo'
done
LIBOBJS=$ac_libobjs
LTLIBOBJS=$ac_ltlibobjs
: ${CONFIG_STATUS=./config.status}
ac_clean_files_save=$ac_clean_files
ac_clean_files="$ac_clean_files $CONFIG_STATUS"
{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5
echo "$as_me: creating $CONFIG_STATUS" >&6;}
cat >$CONFIG_STATUS <<_ACEOF
#! $SHELL
# Generated by $as_me.
# Run this file to recreate the current configuration.
# Compiler output produced by configure, useful for debugging
# configure, is in config.log if it exists.
debug=false
ac_cs_recheck=false
ac_cs_silent=false
SHELL=\${CONFIG_SHELL-$SHELL}
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
## --------------------- ##
## M4sh Initialization. ##
## --------------------- ##
# Be more Bourne compatible
DUALCASE=1; export DUALCASE # for MKS sh
if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
emulate sh
NULLCMD=:
# Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
# is contrary to our usage. Disable this feature.
alias -g '${1+"$@"}'='"$@"'
setopt NO_GLOB_SUBST
else
case `(set -o) 2>/dev/null` in
*posix*) set -o posix ;;
esac
fi
# PATH needs CR
# Avoid depending upon Character Ranges.
as_cr_letters='abcdefghijklmnopqrstuvwxyz'
as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
as_cr_Letters=$as_cr_letters$as_cr_LETTERS
as_cr_digits='0123456789'
as_cr_alnum=$as_cr_Letters$as_cr_digits
# The user is always right.
if test "${PATH_SEPARATOR+set}" != set; then
echo "#! /bin/sh" >conf$$.sh
echo "exit 0" >>conf$$.sh
chmod +x conf$$.sh
if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
PATH_SEPARATOR=';'
else
PATH_SEPARATOR=:
fi
rm -f conf$$.sh
fi
# Support unset when possible.
if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
as_unset=unset
else
as_unset=false
fi
# IFS
# We need space, tab and new line, in precisely that order. Quoting is
# there to prevent editors from complaining about space-tab.
# (If _AS_PATH_WALK were called with IFS unset, it would disable word
# splitting by setting IFS to empty value.)
as_nl='
'
IFS=" "" $as_nl"
# Find who we are. Look in the path if we contain no directory separator.
case $0 in
*[\\/]* ) as_myself=$0 ;;
*) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break
done
IFS=$as_save_IFS
;;
esac
# We did not find ourselves, most probably we were run as `sh COMMAND'
# in which case we are not to be found in the path.
if test "x$as_myself" = x; then
as_myself=$0
fi
if test ! -f "$as_myself"; then
echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
{ (exit 1); exit 1; }
fi
# Work around bugs in pre-3.0 UWIN ksh.
for as_var in ENV MAIL MAILPATH
do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
done
PS1='$ '
PS2='> '
PS4='+ '
# NLS nuisances.
for as_var in \
LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
LC_TELEPHONE LC_TIME
do
if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
eval $as_var=C; export $as_var
else
($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var
fi
done
# Required to use basename.
if expr a : '\(a\)' >/dev/null 2>&1 &&
test "X`expr 00001 : '.*\(...\)'`" = X001; then
as_expr=expr
else
as_expr=false
fi
if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then
as_basename=basename
else
as_basename=false
fi
# Name of the executable.
as_me=`$as_basename -- "$0" ||
$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
X"$0" : 'X\(//\)$' \| \
X"$0" : 'X\(/\)' \| . 2>/dev/null ||
echo X/"$0" |
sed '/^.*\/\([^/][^/]*\)\/*$/{
s//\1/
q
}
/^X\/\(\/\/\)$/{
s//\1/
q
}
/^X\/\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
# CDPATH.
$as_unset CDPATH
as_lineno_1=$LINENO
as_lineno_2=$LINENO
test "x$as_lineno_1" != "x$as_lineno_2" &&
test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || {
# Create $as_me.lineno as a copy of $as_myself, but with $LINENO
# uniformly replaced by the line number. The first 'sed' inserts a
# line-number line after each line using $LINENO; the second 'sed'
# does the real work. The second script uses 'N' to pair each
# line-number line with the line containing $LINENO, and appends
# trailing '-' during substitution so that $LINENO is not a special
# case at line end.
# (Raja R Harinath suggested sed '=', and Paul Eggert wrote the
# scripts with optimization help from Paolo Bonzini. Blame Lee
# E. McMahon (1931-1989) for sed's syntax. :-)
sed -n '
p
/[$]LINENO/=
' <$as_myself |
sed '
s/[$]LINENO.*/&-/
t lineno
b
:lineno
N
:loop
s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
t loop
s/-\n.*//
' >$as_me.lineno &&
chmod +x "$as_me.lineno" ||
{ echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2
{ (exit 1); exit 1; }; }
# Don't try to exec as it changes $[0], causing all sort of problems
# (the dirname of $[0] is not the place where we might find the
# original and so on. Autoconf is especially sensitive to this).
. "./$as_me.lineno"
# Exit status is that of the last command.
exit
}
if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
as_dirname=dirname
else
as_dirname=false
fi
ECHO_C= ECHO_N= ECHO_T=
case `echo -n x` in
-n*)
case `echo 'x\c'` in
*c*) ECHO_T=' ';; # ECHO_T is single tab character.
*) ECHO_C='\c';;
esac;;
*)
ECHO_N='-n';;
esac
if expr a : '\(a\)' >/dev/null 2>&1 &&
test "X`expr 00001 : '.*\(...\)'`" = X001; then
as_expr=expr
else
as_expr=false
fi
rm -f conf$$ conf$$.exe conf$$.file
if test -d conf$$.dir; then
rm -f conf$$.dir/conf$$.file
else
rm -f conf$$.dir
mkdir conf$$.dir
fi
echo >conf$$.file
if ln -s conf$$.file conf$$ 2>/dev/null; then
as_ln_s='ln -s'
# ... but there are two gotchas:
# 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
# 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
# In both cases, we have to default to `cp -p'.
ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
as_ln_s='cp -p'
elif ln conf$$.file conf$$ 2>/dev/null; then
as_ln_s=ln
else
as_ln_s='cp -p'
fi
rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
rmdir conf$$.dir 2>/dev/null
if mkdir -p . 2>/dev/null; then
as_mkdir_p=:
else
test -d ./-p && rmdir ./-p
as_mkdir_p=false
fi
if test -x / >/dev/null 2>&1; then
as_test_x='test -x'
else
if ls -dL / >/dev/null 2>&1; then
as_ls_L_option=L
else
as_ls_L_option=
fi
as_test_x='
eval sh -c '\''
if test -d "$1"; then
test -d "$1/.";
else
case $1 in
-*)set "./$1";;
esac;
case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in
???[sx]*):;;*)false;;esac;fi
'\'' sh
'
fi
as_executable_p=$as_test_x
# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
# Sed expression to map a string onto a valid variable name.
as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
exec 6>&1
# Save the log message, to keep $[0] and so on meaningful, and to
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
This file was extended by gprbuild $as_me 2.1, which was
generated by GNU Autoconf 2.61. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
CONFIG_HEADERS = $CONFIG_HEADERS
CONFIG_LINKS = $CONFIG_LINKS
CONFIG_COMMANDS = $CONFIG_COMMANDS
$ $0 $@
on `(hostname || uname -n) 2>/dev/null | sed 1q`
"
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
# Files that config.status was made for.
config_files="$ac_config_files"
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
ac_cs_usage="\
\`$as_me' instantiates files from templates according to the
current configuration.
Usage: $0 [OPTIONS] [FILE]...
-h, --help print this help, then exit
-V, --version print version number and configuration settings, then exit
-q, --quiet do not print progress messages
-d, --debug don't remove temporary files
--recheck update $as_me by reconfiguring in the same conditions
--file=FILE[:TEMPLATE]
instantiate the configuration file FILE
Configuration files:
$config_files
Report bugs to ."
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
ac_cs_version="\\
gprbuild config.status 2.1
configured by $0, generated by GNU Autoconf 2.61,
with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\"
Copyright (C) 2006 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
ac_pwd='$ac_pwd'
srcdir='$srcdir'
INSTALL='$INSTALL'
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
# If no file are specified by the user, then we need to provide default
# value. By we need to know if files were specified by the user.
ac_need_defaults=:
while test $# != 0
do
case $1 in
--*=*)
ac_option=`expr "X$1" : 'X\([^=]*\)='`
ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'`
ac_shift=:
;;
*)
ac_option=$1
ac_optarg=$2
ac_shift=shift
;;
esac
case $ac_option in
# Handling of the options.
-recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
ac_cs_recheck=: ;;
--version | --versio | --versi | --vers | --ver | --ve | --v | -V )
echo "$ac_cs_version"; exit ;;
--debug | --debu | --deb | --de | --d | -d )
debug=: ;;
--file | --fil | --fi | --f )
$ac_shift
CONFIG_FILES="$CONFIG_FILES $ac_optarg"
ac_need_defaults=false;;
--he | --h | --help | --hel | -h )
echo "$ac_cs_usage"; exit ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil | --si | --s)
ac_cs_silent=: ;;
# This is an error.
-*) { echo "$as_me: error: unrecognized option: $1
Try \`$0 --help' for more information." >&2
{ (exit 1); exit 1; }; } ;;
*) ac_config_targets="$ac_config_targets $1"
ac_need_defaults=false ;;
esac
shift
done
ac_configure_extra_args=
if $ac_cs_silent; then
exec 6>/dev/null
ac_configure_extra_args="$ac_configure_extra_args --silent"
fi
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
if \$ac_cs_recheck; then
echo "running CONFIG_SHELL=$SHELL $SHELL $0 "$ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6
CONFIG_SHELL=$SHELL
export CONFIG_SHELL
exec $SHELL "$0"$ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
fi
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
exec 5>>config.log
{
echo
sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
## Running $as_me. ##
_ASBOX
echo "$ac_log"
} >&5
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
# Handling of arguments.
for ac_config_target in $ac_config_targets
do
case $ac_config_target in
"src/gprconfig-sdefault.ads") CONFIG_FILES="$CONFIG_FILES src/gprconfig-sdefault.ads" ;;
"Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
*) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5
echo "$as_me: error: invalid argument: $ac_config_target" >&2;}
{ (exit 1); exit 1; }; };;
esac
done
# If the user did not use the arguments to specify the items to instantiate,
# then the envvar interface is used. Set only those that are not.
# We use the long form for the default assignment because of an extremely
# bizarre bug on SunOS 4.1.3.
if $ac_need_defaults; then
test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files
fi
# Have a temporary directory for convenience. Make it in the build tree
# simply because there is no reason against having it here, and in addition,
# creating and moving files from /tmp can sometimes cause problems.
# Hook for its removal unless debugging.
# Note that there is a small window in which the directory will not be cleaned:
# after its creation but before its name has been assigned to `$tmp'.
$debug ||
{
tmp=
trap 'exit_status=$?
{ test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status
' 0
trap '{ (exit 1); exit 1; }' 1 2 13 15
}
# Create a (secure) tmp directory for tmp files.
{
tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&
test -n "$tmp" && test -d "$tmp"
} ||
{
tmp=./conf$$-$RANDOM
(umask 077 && mkdir "$tmp")
} ||
{
echo "$me: cannot create a temporary directory in ." >&2
{ (exit 1); exit 1; }
}
#
# Set up the sed scripts for CONFIG_FILES section.
#
# No need to generate the scripts if there are no CONFIG_FILES.
# This happens for instance when ./config.status config.h
if test -n "$CONFIG_FILES"; then
_ACEOF
ac_delim='%!_!# '
for ac_last_try in false false false false false :; do
cat >conf$$subs.sed <<_ACEOF
SHELL!$SHELL$ac_delim
PATH_SEPARATOR!$PATH_SEPARATOR$ac_delim
PACKAGE_NAME!$PACKAGE_NAME$ac_delim
PACKAGE_TARNAME!$PACKAGE_TARNAME$ac_delim
PACKAGE_VERSION!$PACKAGE_VERSION$ac_delim
PACKAGE_STRING!$PACKAGE_STRING$ac_delim
PACKAGE_BUGREPORT!$PACKAGE_BUGREPORT$ac_delim
exec_prefix!$exec_prefix$ac_delim
prefix!$prefix$ac_delim
program_transform_name!$program_transform_name$ac_delim
bindir!$bindir$ac_delim
sbindir!$sbindir$ac_delim
libexecdir!$libexecdir$ac_delim
datarootdir!$datarootdir$ac_delim
datadir!$datadir$ac_delim
sysconfdir!$sysconfdir$ac_delim
sharedstatedir!$sharedstatedir$ac_delim
localstatedir!$localstatedir$ac_delim
includedir!$includedir$ac_delim
oldincludedir!$oldincludedir$ac_delim
docdir!$docdir$ac_delim
infodir!$infodir$ac_delim
htmldir!$htmldir$ac_delim
dvidir!$dvidir$ac_delim
pdfdir!$pdfdir$ac_delim
psdir!$psdir$ac_delim
libdir!$libdir$ac_delim
localedir!$localedir$ac_delim
mandir!$mandir$ac_delim
DEFS!$DEFS$ac_delim
ECHO_C!$ECHO_C$ac_delim
ECHO_N!$ECHO_N$ac_delim
ECHO_T!$ECHO_T$ac_delim
LIBS!$LIBS$ac_delim
build_alias!$build_alias$ac_delim
host_alias!$host_alias$ac_delim
target_alias!$target_alias$ac_delim
build!$build$ac_delim
build_cpu!$build_cpu$ac_delim
build_vendor!$build_vendor$ac_delim
build_os!$build_os$ac_delim
host!$host$ac_delim
host_cpu!$host_cpu$ac_delim
host_vendor!$host_vendor$ac_delim
host_os!$host_os$ac_delim
target!$target$ac_delim
target_cpu!$target_cpu$ac_delim
target_vendor!$target_vendor$ac_delim
target_os!$target_os$ac_delim
ac_prefix_program!$ac_prefix_program$ac_delim
INSTALL_PROGRAM!$INSTALL_PROGRAM$ac_delim
INSTALL_SCRIPT!$INSTALL_SCRIPT$ac_delim
INSTALL_DATA!$INSTALL_DATA$ac_delim
objdir!$objdir$ac_delim
is_windows!$is_windows$ac_delim
xmlada_build_target!$xmlada_build_target$ac_delim
xmlada_prj_flags!$xmlada_prj_flags$ac_delim
LIBOBJS!$LIBOBJS$ac_delim
LTLIBOBJS!$LTLIBOBJS$ac_delim
_ACEOF
if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 59; then
break
elif $ac_last_try; then
{ { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5
echo "$as_me: error: could not make $CONFIG_STATUS" >&2;}
{ (exit 1); exit 1; }; }
else
ac_delim="$ac_delim!$ac_delim _$ac_delim!! "
fi
done
ac_eof=`sed -n '/^CEOF[0-9]*$/s/CEOF/0/p' conf$$subs.sed`
if test -n "$ac_eof"; then
ac_eof=`echo "$ac_eof" | sort -nru | sed 1q`
ac_eof=`expr $ac_eof + 1`
fi
cat >>$CONFIG_STATUS <<_ACEOF
cat >"\$tmp/subs-1.sed" <<\CEOF$ac_eof
/@[a-zA-Z_][a-zA-Z_0-9]*@/!b end
_ACEOF
sed '
s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g
s/^/s,@/; s/!/@,|#_!!_#|/
:n
t n
s/'"$ac_delim"'$/,g/; t
s/$/\\/; p
N; s/^.*\n//; s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g; b n
' >>$CONFIG_STATUS >$CONFIG_STATUS <<_ACEOF
:end
s/|#_!!_#|//g
CEOF$ac_eof
_ACEOF
# VPATH may cause trouble with some makes, so we remove $(srcdir),
# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and
# trailing colons and then remove the whole line if VPATH becomes empty
# (actually we leave an empty line to preserve line numbers).
if test "x$srcdir" = x.; then
ac_vpsub='/^[ ]*VPATH[ ]*=/{
s/:*\$(srcdir):*/:/
s/:*\${srcdir}:*/:/
s/:*@srcdir@:*/:/
s/^\([^=]*=[ ]*\):*/\1/
s/:*$//
s/^[^=]*=[ ]*$//
}'
fi
cat >>$CONFIG_STATUS <<\_ACEOF
fi # test -n "$CONFIG_FILES"
for ac_tag in :F $CONFIG_FILES
do
case $ac_tag in
:[FHLC]) ac_mode=$ac_tag; continue;;
esac
case $ac_mode$ac_tag in
:[FHL]*:*);;
:L* | :C*:*) { { echo "$as_me:$LINENO: error: Invalid tag $ac_tag." >&5
echo "$as_me: error: Invalid tag $ac_tag." >&2;}
{ (exit 1); exit 1; }; };;
:[FH]-) ac_tag=-:-;;
:[FH]*) ac_tag=$ac_tag:$ac_tag.in;;
esac
ac_save_IFS=$IFS
IFS=:
set x $ac_tag
IFS=$ac_save_IFS
shift
ac_file=$1
shift
case $ac_mode in
:L) ac_source=$1;;
:[FH])
ac_file_inputs=
for ac_f
do
case $ac_f in
-) ac_f="$tmp/stdin";;
*) # Look for the file first in the build tree, then in the source tree
# (if the path is not absolute). The absolute path cannot be DOS-style,
# because $ac_f cannot contain `:'.
test -f "$ac_f" ||
case $ac_f in
[\\/$]*) false;;
*) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;
esac ||
{ { echo "$as_me:$LINENO: error: cannot find input file: $ac_f" >&5
echo "$as_me: error: cannot find input file: $ac_f" >&2;}
{ (exit 1); exit 1; }; };;
esac
ac_file_inputs="$ac_file_inputs $ac_f"
done
# Let's still pretend it is `configure' which instantiates (i.e., don't
# use $as_me), people would be surprised to read:
# /* config.h. Generated by config.status. */
configure_input="Generated from "`IFS=:
echo $* | sed 's|^[^:]*/||;s|:[^:]*/|, |g'`" by configure."
if test x"$ac_file" != x-; then
configure_input="$ac_file. $configure_input"
{ echo "$as_me:$LINENO: creating $ac_file" >&5
echo "$as_me: creating $ac_file" >&6;}
fi
case $ac_tag in
*:-:* | *:-) cat >"$tmp/stdin";;
esac
;;
esac
ac_dir=`$as_dirname -- "$ac_file" ||
$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$ac_file" : 'X\(//\)[^/]' \| \
X"$ac_file" : 'X\(//\)$' \| \
X"$ac_file" : 'X\(/\)' \| . 2>/dev/null ||
echo X"$ac_file" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
}
/^X\(\/\/\)$/{
s//\1/
q
}
/^X\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
{ as_dir="$ac_dir"
case $as_dir in #(
-*) as_dir=./$as_dir;;
esac
test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || {
as_dirs=
while :; do
case $as_dir in #(
*\'*) as_qdir=`echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #(
*) as_qdir=$as_dir;;
esac
as_dirs="'$as_qdir' $as_dirs"
as_dir=`$as_dirname -- "$as_dir" ||
$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$as_dir" : 'X\(//\)[^/]' \| \
X"$as_dir" : 'X\(//\)$' \| \
X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
echo X"$as_dir" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
}
/^X\(\/\/\)$/{
s//\1/
q
}
/^X\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
test -d "$as_dir" && break
done
test -z "$as_dirs" || eval "mkdir $as_dirs"
} || test -d "$as_dir" || { { echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5
echo "$as_me: error: cannot create directory $as_dir" >&2;}
{ (exit 1); exit 1; }; }; }
ac_builddir=.
case "$ac_dir" in
.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
*)
ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
# A ".." for each directory in $ac_dir_suffix.
ac_top_builddir_sub=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,/..,g;s,/,,'`
case $ac_top_builddir_sub in
"") ac_top_builddir_sub=. ac_top_build_prefix= ;;
*) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
esac ;;
esac
ac_abs_top_builddir=$ac_pwd
ac_abs_builddir=$ac_pwd$ac_dir_suffix
# for backward compatibility:
ac_top_builddir=$ac_top_build_prefix
case $srcdir in
.) # We are building in place.
ac_srcdir=.
ac_top_srcdir=$ac_top_builddir_sub
ac_abs_top_srcdir=$ac_pwd ;;
[\\/]* | ?:[\\/]* ) # Absolute name.
ac_srcdir=$srcdir$ac_dir_suffix;
ac_top_srcdir=$srcdir
ac_abs_top_srcdir=$srcdir ;;
*) # Relative name.
ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
ac_top_srcdir=$ac_top_build_prefix$srcdir
ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
esac
ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
case $ac_mode in
:F)
#
# CONFIG_FILE
#
case $INSTALL in
[\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;;
*) ac_INSTALL=$ac_top_build_prefix$INSTALL ;;
esac
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
# If the template does not know about datarootdir, expand it.
# FIXME: This hack should be removed a few years after 2.60.
ac_datarootdir_hack=; ac_datarootdir_seen=
case `sed -n '/datarootdir/ {
p
q
}
/@datadir@/p
/@docdir@/p
/@infodir@/p
/@localedir@/p
/@mandir@/p
' $ac_file_inputs` in
*datarootdir*) ac_datarootdir_seen=yes;;
*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)
{ echo "$as_me:$LINENO: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5
echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF
ac_datarootdir_hack='
s&@datadir@&$datadir&g
s&@docdir@&$docdir&g
s&@infodir@&$infodir&g
s&@localedir@&$localedir&g
s&@mandir@&$mandir&g
s&\\\${datarootdir}&$datarootdir&g' ;;
esac
_ACEOF
# Neutralize VPATH when `$srcdir' = `.'.
# Shell code in configure.ac might set extrasub.
# FIXME: do we really want to maintain this feature?
cat >>$CONFIG_STATUS <<_ACEOF
sed "$ac_vpsub
$extrasub
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF
:t
/@[a-zA-Z_][a-zA-Z_0-9]*@/!b
s&@configure_input@&$configure_input&;t t
s&@top_builddir@&$ac_top_builddir_sub&;t t
s&@srcdir@&$ac_srcdir&;t t
s&@abs_srcdir@&$ac_abs_srcdir&;t t
s&@top_srcdir@&$ac_top_srcdir&;t t
s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t
s&@builddir@&$ac_builddir&;t t
s&@abs_builddir@&$ac_abs_builddir&;t t
s&@abs_top_builddir@&$ac_abs_top_builddir&;t t
s&@INSTALL@&$ac_INSTALL&;t t
$ac_datarootdir_hack
" $ac_file_inputs | sed -f "$tmp/subs-1.sed" >$tmp/out
test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&
{ ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } &&
{ ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } &&
{ echo "$as_me:$LINENO: WARNING: $ac_file contains a reference to the variable \`datarootdir'
which seems to be undefined. Please make sure it is defined." >&5
echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir'
which seems to be undefined. Please make sure it is defined." >&2;}
rm -f "$tmp/stdin"
case $ac_file in
-) cat "$tmp/out"; rm -f "$tmp/out";;
*) rm -f "$ac_file"; mv "$tmp/out" $ac_file;;
esac
;;
esac
done # for ac_tag
{ (exit 0); exit 0; }
_ACEOF
chmod +x $CONFIG_STATUS
ac_clean_files=$ac_clean_files_save
# configure is writing to config.log, and then calls config.status.
# config.status does its own redirection, appending to config.log.
# Unfortunately, on DOS this fails, as config.log is still kept open
# by configure, so config.status won't be able to write to it; its
# output is simply discarded. So we exec the FD to /dev/null,
# effectively closing config.log, so it can be properly (re)opened and
# appended to by config.status. When coming back to configure, we
# need to make the FD available again.
if test "$no_create" != yes; then
ac_cs_success=:
ac_config_status_args=
test "$silent" = yes &&
ac_config_status_args="$ac_config_status_args --quiet"
exec 5>/dev/null
$SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false
exec 5>>config.log
# Use ||, not &&, to avoid exiting from the if with $? = 1, which
# would make configure fail if this is the last instruction.
$ac_cs_success || { (exit 1); exit 1; }
fi
gprbuild-gpl-2014-src/vms_gprbuild.gpr 0000644 0000767 0000145 00000006140 12323721731 017343 0 ustar gnatmail gnat project VMS_Gprbuild is
type OS_Type is ("avms", "ivms");
OS : OS_Type := external ("OS", "ivms");
type Build_Type is ("debug", "production", "coverage", "profiling");
Bld : Build_Type := external ("BUILD", "debug");
type VCS_Type is ("Subversion", "Git", "auto");
VCS_Kind : VCS_Type := external ("PRJ_VCS", "Subversion");
for Main use
("gprbuild.adb",
"gprbind.adb",
"gprlib.adb",
"gprclean.adb",
"ccomp.adb",
"forcomp.adb");
for Source_Dirs use ("src", "gnat");
case Bld is
when "production" => for Object_Dir use "obj";
when "coverage" => for Object_Dir use "obj-cov";
when "profiling" => for Object_Dir use "obj-prof";
when "debug" => for Object_Dir use "obj-debug";
end case;
for Exec_Dir use ".";
for Languages use ("Ada", "C");
package Compiler is
common_switches := ("-gnat05", "-gnaty", "-gnatQ");
case Bld is
when "debug" =>
for Default_Switches ("Ada") use common_switches &
("-g", "-gnata", "-gnatVa", "-gnatwaCJI"
-- , "-gnatwe"
, "-gnatyg"
);
for Local_Configuration_Pragmas use "debug.adc";
when "coverage" =>
for Default_Switches ("Ada") use common_switches &
("-ftest-coverage", "-fprofile-arcs");
when "profiling" =>
for Default_Switches ("Ada") use common_switches &
("-pg", "-g");
when "production" =>
for Default_Switches ("Ada") use common_switches &
("-O2", "-gnatpn", "-gnatws");
end case;
end Compiler;
package Binder is
common_switches := ("-E", "-static");
case Bld is
when "debug" =>
for Default_Switches ("Ada") use common_switches;
when "coverage" | "profiling" | "production" =>
for Default_Switches ("Ada") use common_switches;
end case;
end Binder;
package Linker is
Common_Switches_VMS :=
(project'Object_Dir & "/gprbuild_dummies.obj",
project'Object_Dir & "/link.obj");
case Bld is
when "production" | "debug" | "coverage" =>
for Default_Switches ("Ada") use Common_Switches_VMS;
when "profiling" =>
for Default_Switches ("Ada")
use Common_Switches_VMS & ("-pg", "-g");
end case;
end Linker;
Common_Excluded_Source_Files :=
("gprlib-build_shared_lib.adb",
"gprlib-build_shared_lib-nosymbols.adb",
"gprlib-build_shared_lib-vms.adb",
"mlib-tgt-vms-alpha.adb",
"mlib-tgt-vms-ia64.adb");
package Naming is
for Body ("gprlib.build_shared_lib")
use "gprlib-build_shared_lib-vms.adb";
for Body ("gpr_util.knowledge") use "gpr_util-knowledge-vms.adb";
case OS is
when "avms" =>
for Body ("mlib.tgt.specific")
use "mlib-tgt-specific-vms-alpha.adb";
when "ivms" =>
for Body ("mlib.tgt.specific")
use "mlib-tgt-specific-vms-ia64.adb";
end case;
end Naming;
end VMS_Gprbuild;
gprbuild-gpl-2014-src/features-14 0000644 0000767 0000145 00000005542 11370043134 016117 0 ustar gnatmail gnat ==============================
GPRBUILD 1.4 NEW FEATURES LIST
==============================
Copyright (C) 2009-2010, AdaCore
This file contains a complete list of new features in version 1.4 of GPRBUILD.
A full description of all GPRBUILD features can be found in the GPRBUILD
User's Guide.
An ISO date (YYYY-MM-DD) appears in parentheses after the description line.
This date shows the implementation date of the feature. Any 1.4.0w
wavefront subsequent to this date will contain the indicated feature, as
will any subsequent releases.
NF-14-J107-014 Compilation switches and Stand-Alone Libraries (2010-01-11)
The Ada leading and trailing switches are now used to compile the binder
generated files of Stand-Alone Libraries.
NF-14-IA01-036 No relink if non interfaces of shared SALs changed (2009-10-01)
When only non interface units are modified in a shared Stand-Alone Library,
the shared SAL needs to be rebuilt but the executable no longer needs to be
rebound and relinked.
NF-14-I930-029 Ignore Builder switches -x for Ada (2009-09-30)
For better compatibility with gnatmake, switch -x is ignored when found
in the Builder switches for Ada.
NF-14-I928-023 Library_Interface of SALs enforced (2009-09-30)
When attribute Interfaces is not declared in a Stand-Alone Library,
the units declared in Library_Interface constitutes the interface of
the library. If an external unit imports a unit of the library that
is not in Library_Interface, its compilation will be invalidated and
gprbuild will fail.
NF-14-I814-016 gprbuild no longer outputs "creating auto.cgpr" (2009-08-20)
When running in the default auto configuration mode, gprbuild will no
longer display the message "creating auto.cgpr"
NF-14-I728-026 gprclean warns when object dir does not exist (2009-08-11)
When the object dir of a project does not exist, gprclean used to exit
with an error. Instead, it will now display a warning, and skip this
project, but continue cleaning the other projects if required.
NF-14-I415-016 Binder generated file compiled with all options (2009-05-06)
gprbind now compiles the binder generated file with the required trailing
compilation switches specified in the configuration project file.
NF-14-I401-028 Support for Ada multi-unit source files (2009-09-20)
gprbuild now supports Ada multi-unit source files
NF-14-HA27-001 New switch --no-split-units (2009-10-07)
A new switch --no-split-units is added. When this switch is specified, the
spec, body and subunits of an Ada unit must be sources of the same project
or of projects extending each others.
NF-14-H828-007 Compilers working on all targets (2009-09-03)
It is now possible in the knowledge base for gprconfig to specify
compilers that work on all targets, by omitting the node. In
particular, you can add support for tools that generate code instead of
object code.
gprbuild-gpl-2014-src/known-problems-21 0000644 0000767 0000145 00000015626 12312367513 017267 0 ustar gnatmail gnat ======================================
Known problems in GPRBUILD version 2.1
======================================
Copyright (C) 2013-2014, AdaCore
The following is a listing of known problems in releases 2.1.1 and 2.1.2.
Each entry contains a status line stating when the problem was fixed, and on
which release(s). In addition, any wavefront issued subsequent to the date
specified (in ISO format YYYY-MM-DD) also contains the fix. This can be used
to determine if a given release or wavefront has the fix identified in the
entry.
Note that older releases might or might not be affected by the problems listed
in this document.
Known problems fixed in 2.2.1 and above
---------------------------------------
KP-21-N319-020 gprbuild fails with binder switch "-s"
Problem: When gprbuild is invoked with the binder switch "-s". the binding
phase will fail as gnatbind is unable to find the sources.
Status: This was fixed in 2.2 on 2014-03-19
Workaround: Do not use binder switch "-s" when using gprbuild.
KP-21-N318-025 gprinstall does not recognized -d option
Problem: The -d option (short version of --dry-run) is documented
but not recognized by gprinstall.
Status: This was fixed in 2.2 on 2014-03-19
Workaround: Uses --dry-run instead.
KP-21-N313-008 gprinstall fails with spec naming exception
Problem: When gprinstall is invoked to install a library project file
that is not a Stand-Alone Library and there is a spec with
a naming exception, the installation will fail.
Status: This was fixed in 2.2 on 2014-03-13
Workaround: Avoid spec naming exceptions in library project file.
KP-21-N310-027 gprbuild wait indefinitely for some compilation results
Problem: If the Remote package Root_Dir attribute is not properly set
gprbuild may not terminate.
Status: This was fixed in 2.2 on 2014-03-10
Workaround: fix the Root_Dir attribute value.
KP-21-N207-022 Fail to compile sources in distributed mode
Problem: Top level sources (sources found at the project's root
directory) will fail to compile on remote compilation slaves.
Status: This was fixed in 2.2 on 2014-02-07
Workaround: do not use the distributed compilation mode
KP-21-N206-041 wrong permissions set by gprinstall for binaries
Problem: On UNIX, a binary installed with gprinstall will have the
executable permission set only for the owner. This will prevent
others to execute this binary. It is a problem when installing
an application in a shared computer for example.
Status: This was fixed in 2.2 on 2014-02-06
Workaround: change the permissions manually using chmod
KP-21-N120-075 gprclean -r and cycles in externally built projects
Problem: When there are several externally built projects in the project
tree and some of them form a cycle, through limited withs,
invoking gprclean with switch -r will result in a crash.
Status: This was fixed in 2.2 on 2014-01-21
Workaround: Avoid circularities in externally built projects or invoke
gprclean without switch -r.
KP-21-N103-018 Failure to link on target powerpc-xcoff-lynxos178
Problem: For target powerpc-xcoff-lynxos178, when there are two many
object files to be linked, because a response file is not used,
the linking phase may fail.
Status: This was fixed in 2.2 on 2014-01-06
Workaround: Add these two lines in package Linker of the main project:
for Response_File_Format use "GCC_GNU";
for Max_Command_Line_Length use "8192";
KP-21-MB30-011 Garbled output from parallel invocations of gnatbind
Problem: When gprbuild is invoked with -jnn and there are several mains,
several invocations of gprbind may be running in parallel and
their displayed gnatbind invocations may be garbled.
Status: This was fixed in 2.2 on 2013-12-01
Workaround: Ignore the problem or invoke gprbuild without -jnn.
KP-21-MB26-007 Dependency builder must be invoked from the object directory
Problem: When gprbuild performs parallel compilations and for some
language a dependency builder is invoked to build a dependency
file, the dependency builder may be invoked from the object
directory of another project and thus may fail if some of its
arguments are relative paths.
Status: This was fixed in 2.2 on 2013-11-27
Workaround: Use absolute paths for the arguments of a dependency builder.
KP-21-MB05-034 gprinstall fails to install projects built with sub-dirs
Problem: gprinstall is not able to install a code which has been
built with gprbuild's --subdirs option.
Status: This was fixed in 2.2 on 2013-11-05
Workaround: Install the code manually.
KP-21-MA31-004 Aggregated libraries and externally built
Problem: gprbuild was not properly dealing with externally built
projects on the dependencies. First it was trying to add the
object code from such libraries and failed to pass the library
on to the linker.
Status: This was fixed in 2.2 on 2013-11-01
Workaround: Remove the externally built projects from the dependencies if
possible and pass the corresponding library to the linker.
KP-21-MA30-041 Aggregated libraries and gprinstall
Problem: gprinstall was not properly handling aggregate libraries. The
installation was failing and/or the generated project was not
usable.
Status: This was fixed in 2.2 on 2013-11-02
Workaround: Install the software using a script.
Known problems fixed in 2.1.2 and above
---------------------------------------
Known problems fixed in 2.1.1 and above
---------------------------------------
KP-21-MB06-054 gprinstall and shared library with version on windows
Problem: On Windows, gprinstall fails while installing a shared library
project when the attribute Library_Version is defined.
Status: This was fixed in 2.2 on 2013-11-06
This was fixed in 2.1.1 on 2013-11-27
Workaround: Manually install the library.
KP-21-MB06-015 gprinstall and standalone libraries
Problem: gprinstall does not generate a usable project file for
standalone libraries.
Status: This was fixed in 2.2 on 2013-11-06
This was fixed in 2.1.1 on 2013-11-27
Workaround: Manually adds the Library_Interface and Library_Standalone
attributes.
KP-21-MB05-020 gprconfig does not detect non GNAT gcc C and g++ compilers
Problem: gprconfig does not find all non GNAT gcc C and g++ compilers.
Status: This was fixed in 2.2 on 2013-11-07
This was fixed in 2.1.1 on 2013-12-10
Workaround: Manually edit a configuration project file and use it with
gprbuild.
gprbuild-gpl-2014-src/known-problems-152 0000644 0000767 0000145 00000003435 11673621721 017352 0 ustar gnatmail gnat ========================================
Known problems in GPRBUILD version 1.5.2
========================================
Copyright (C) 2011, AdaCore
The following is a listing of known problems in release 1.5.2. Except where
specifically noted, all these problems have been corrected in the development
tree of the 1.6 technology. This means they are corrected in any 1.6.0w
wavefront issued subsequent to the date specified (in ISO format YYYY-MM-DD) in
the status line. This can be used to determine if a given wavefront has the fix
identified in the entry.
KP-152-KA13-044 Crash when attempting to compile an header file
Problem: gprbuild crashes when asked to compile an header file,
for example with: gprbuild -u -c prj.gpr toro.h
Status: This was fixed in 1.6.0 on 2011-10-14
Workaround: Do not attempt to compile header files.
KP-152-KA04-012 Pragma Linker_Options not honored
Problem: gprbuild does not pass libraries specified with a pragma
Linker_Options to the linker.
Status: This was fixed in 1.6.0 on 2011-10-06
Workaround: Pass the corresponding libraries explicitly to the linker.
KP-152-K801-014 Crash for library projects with no sources
Problem: gprbuild and gprclean crash with a library project with no
sources that is not externally built.
Status: This was fixed in 1.6.0 on 2011-08-02
Workaround: Declare the library project as externally built.
KP-152-K711-032 Failure to build archive on Windows
Problem: On Windows, gprbuild may fail to build an archive if the
length of the command line is greater than 8192.
Status: This was fixed in 1.6.0 on 2011-07-22
Workaround: Reduce the length of the object path names to reduce the
length of the command line.
gprbuild-gpl-2014-src/CHANGES 0000644 0000767 0000145 00000000147 12323721732 015131 0 ustar gnatmail gnat {doc: 303217, gnat: 303554, gprbuild: 225341, gprbuild.anod: 7807aabc8a6be77aca4e121b12238a2da15898cd}
gprbuild-gpl-2014-src/known-problems-162 0000644 0000767 0000145 00000001073 12032613023 017331 0 ustar gnatmail gnat ========================================
Known problems in GPRBUILD version 1.6.2
========================================
Copyright (C) 2012, AdaCore
The following is a listing of known problems in release 1.6.2. Except where
specifically noted, all these problems have been corrected in the development
tree of the 2.0 technology. This means they are corrected in any 1.7.0w/2.0.0w
wavefront issued subsequent to the date specified (in ISO format YYYY-MM-DD) in
the status line. This can be used to determine if a given wavefront has the fix
identified in the entry.
gprbuild-gpl-2014-src/features-12 0000644 0000767 0000145 00000007131 11265233506 016120 0 ustar gnatmail gnat ==============================
GPRBUILD 1.2 NEW FEATURES LIST
==============================
Copyright (C) 2008-2009, AdaCore
This file contains a complete list of new features in version 1.2 of GPRBUILD.
A full description of all GPRBUILD features can be found in the GPRBUILD
User's Guide.
An ISO date (YYYY-MM-DD) appears in parentheses after the description line.
This date shows the implementation date of the feature. Any 1.2.0w
wavefront subsequent to this date will contain the indicated feature, as
will any subsequent releases.
NF-12-HA21-031 Support for -margs switch (2008-10-21)
The -margs switch, equivalent to -gargs is now supported, for better
compatibility with gnatmake.
NF-12-H903-021 Better error messages for qualified lib projects (2008-09-04)
When a project qualified as a "library project" is not a library project
because one or both of the attributes Library_Dir and Library_Name is
missing, the error message will now indicate which attribute is not
declared.
NF-12-H821-015 Use response files when available (2008-09-22)
When supported, and when the command line is too long, gprlib now uses
response files to link shared libraries.
NF-12-H812-005 Support for Diab C compiler (2008-08-28)
The Diab C compiler is now supported for powerpc-elf (using the
ppc750 variant).
NF-12-H808-006 Specifying executable name in gprconfig (2008-08-11)
The --config switch parameter to gprconfig can now be used to specify
the base name of the executable you want to use. This can be used to
easily select a type of compiler over another type, no matter whether it
appears first in the path or not.
NF-12-H806-009 Switch files only created when -s is used (2008-09-10)
Switch files (with the .cswi suffix) are now only created when the
switch -s is used.
NF-12-H712-006 Partial linker to link shared libraries (2008-07-18)
The partial linker, when declared, is now used to build shared libraries,
in chunks if the command line length would be too long to build the
shared library in one chunk.
NF-12-H518-002 New attribute Builder'Global_Compilation_Switches (2008-06-03)
A new attribute Global_Compilation_Switches ("") is created in
package Builder. This attribute is taken into account in the main project
when attribute Default_Switches ("") is not take into account.
The switches specified in Global_Compilation_Switches ("") are used
when compiling a source of language "" anywhere in the project tree.
NF-12-H501-004 Improve backward compatibility with gnatmake (2008-05-05)
Compatibility with projects accepted by gnatmake is improved:
- a main may be truncated: the body suffix may be missing
- switches from Builder'Switches () that are not recognized
by gprbuild are for the compiler of the language of the main.
NF-12-H408-020 New attributes Object_Generated and Objects_Linked (2008-04-16)
New attributes for languages are created: Object_Generated (when "false",
it means that no object file is created by the "compiler") and
Objects_Linked (when "false", it means that the object files of the
languages are not linked in an executable or put in a library).
NF-12-H404-015 Warning when no source of a language (2008-04-05)
When a language is declared or defaulted in a project file and there is
no source of the language, gprbuild now issues a warning indicating this,
unless warnings are suppressed.
NF-12-H116-039 Partial linking in chunks (2008-07-18)
When the partial linker is declared, a static stand-alone library is
linked in chunks if the command line would be too long to link it in
one chunk.
gprbuild-gpl-2014-src/known-problems-200 0000644 0000767 0000145 00000001634 12072675335 017347 0 ustar gnatmail gnat ========================================
Known problems in GPRBUILD version 2.0.0
========================================
Copyright (C) 2013, AdaCore
The following is a listing of known problems in release 2.0.0. Except where
specifically noted, all these problems have been corrected in the development
tree of the 2.1 technology. This means they are corrected in any 2.1.0w
wavefront issued subsequent to the date specified (in ISO format YYYY-MM-DD) in
the status line. This can be used to determine if a given wavefront has the fix
identified in the entry.
KP-200-M104-032 Modified library in externally built library project
Problem: When the library file of an externally built library project
is modified, executables that depend on this library are not
always relinked.
Status: This was fixed in 2.1.0 on 2012-01-07
Workaround: Force recompilation of the executables.
gprbuild-gpl-2014-src/known-problems-161 0000644 0000767 0000145 00000001572 12032613023 017334 0 ustar gnatmail gnat ========================================
Known problems in GPRBUILD version 1.6.1
========================================
Copyright (C) 2012, AdaCore
The following is a listing of known problems in release 1.6.1. Except where
specifically noted, all these problems have been corrected in the development
tree of the 2.0 technology. This means they are corrected in any 1.7.0w/2.0.0w
wavefront issued subsequent to the date specified (in ISO format YYYY-MM-DD) in
the status line. This can be used to determine if a given wavefront has the fix
identified in the entry.
KP-161-KC01-033 gprconfig: duplicate runtimes detected on Windows
Problem: On Windows, gprconfig will sometimes report the "default" runtime
multiple times for a given Ada compiler.
Status: This was fixed in 1.6.2 on 2012-03-28
Workaround: Selecting any of the lines has the same effect.
gprbuild-gpl-2014-src/known-problems-150 0000644 0000767 0000145 00000003272 11522317416 017343 0 ustar gnatmail gnat ========================================
Known problems in GPRBUILD version 1.5.0
========================================
Copyright (C) 2010-2011, AdaCore
The following is a listing of known problems in release 1.5.0. All these
problems have been corrected in the release 1.5.1 and in any wavefront
issued subsequent to the date specified (in ISO format YYYY-MM-DD) in the
status line. This can be used to determine if a given wavefront has the fix
identified in the entry.
KP-150-JC22-022 Duplicate rpaths when there are several mains
Problem: gprbuild keeps the rpaths from the previous mains when linking
another main. That may leads to reach a limit in some platforms,
and the link may then fail.
Status: This was fixed in 1.5.1 on 2010-12-29
Workaround: Invoke gprbuild to link one main at a time.
KP-150-JC09-012 Main in mixed cases on Windows
Problem: On Windows, if the mains in attributes Mains contain capital
letters, linking executables may fail.
Status: This was fixed in 1.5.1 on 2011-01-07
Workaround: Use only small letters in attribute Main.
KP-150-JB09-027 Improper attempt to compile locally removed body
Problem: gprbuild attempts to compiled the body of a package that has
been "locally removed" in an extended project.
Status: This was fixed in 1.5.1 on 2010-11-09
Workaround: Make sure the spec needs a body.
KP-150-J512-013 gprconfig's requires a prefix
Problem: In its knowledge base, gprconfig requires a valid prefix
attribute for nodes.
Status: This was fixed in 1.5.1 on 2010-12-01
Workaround: Add prefix="-1" to
gprbuild-gpl-2014-src/features-21 0000644 0000767 0000145 00000011256 12301444157 016121 0 ustar gnatmail gnat ==============================
GPRBUILD 2.1 NEW FEATURES LIST
==============================
Copyright (C) 2012-2014, AdaCore
This file contains a complete list of new features in version 2.1 of GPRBUILD.
A full description of all GPRBUILD features can be found in the GPRBUILD
User's Guide.
NF-21-MC01-007 Add support for artifacts in gprinstall (2013-12-22)
It is now possible to install files or directories not part of the
project (source or object). Those artifacts are described into the
project's Install package and can be used to install documentation
or examples.
NF-21-M918-043 Attributes External and environment variables (2013-09-19)
In main aggregate project, when attribute External is specified, the
corresponding environment variable is set, if it is not already set in the
environment.
NF-21-M719-035 -b, -c and -l may be used in package Builder (2013-08-08)
The switches -c, -b and -l are no longer restricted to the command line. They
may be specified in package Builder of the main project.
NF-21-M719-029 --no-object-check may be used in package Builder (2013-07-21)
The gprbuild switch --no-object-check is no longer restricted to the command
line. It may be specified in package Builder of the main project file.
NF-21-M714-001 Bind and link several executables simultaneously (2013-07-17)
gprbuild is now able to bind several executables simultaneously when
switch -jnnn is used, with nnn other than 1. It is also able to link
these executables simultaneously with the same switch -jnnn.
NF-21-M529-021 Clean artifacts in object and exec directories (2013-06-18)
gprclean now cleans from the object directory the files specified in
new attribute Artifacts_In_Object_Dir in package Clean and for main projects
cleans from the exec directory the files specified in new attribute
Artifacts_In_Exec_Dir in package Clean.
NF-21-M405-028 gprinstall now supports cross-environment (2013-04-05)
gprinstall will work in cross-environment by using the newly added
--target option. This way it is possible to install a .dll created
from a Windows cross-compiler on GNU/Linux for example.
NF-21-M304-056 gprinstall now preserves timestamps (2013-03-05)
gprinstall now preserves timestamps when copying the source files,
object files and libraries.
NF-21-LC19-034 Project_Path searched before ADA_PROJECT_PATH (2013-01-04)
Project_Path values are searched before ADA_PROJECT_PATH. This behavior
is better as if Project_Path is defined for the aggregate project we
do not want to pick a random project found in ADA_PROJECT_PATH.
NF-21-LA25-026 Aggregate projects and auto-configuration (2012-01-11)
gprbuild fails when the project tree includes only aggregate projects and
aggregate libraries projects. When gprbuild is called with a main project
that is either an aggregate project or an aggregate library project,
if auto-configuration is used, the configuration project file is created
in the object directory of one of the non aggregate projects in the project
tree.
NF-21-LA22-030 New Linker attribute Trailing_Switches (2012-12-29)
A new attribute Trailing_Switches has been added in package Linker of
project files. These switches are added in the linking command line
after the required switches, so that they can override these switches.
NF-21-LA05-034 --config= in Builder switches (2012-12-24)
gprbuild now takes into account a switch --config= in package Builder
of the main project.
NF-21-L809-007 Non Ada sources copied to the Library_Src_Dir (2013-06-24)
In a library project, when attributes Library_Src_Dir and Interfaces are
declared and there are non Ada sources/templates in the Interfaces,
these sources/templates are now copied to the Library_Src_Dir.
NF-21-L724-003 Empty Run_Path_Origin (2013-02-05)
It is now allowed to specify attribute Run_Path_Origin as an empty
string. This allows the run paths to be absolute paths. Then an executable
may be moved to another directory without moving the shared libraries
it needs.
NF-21-KB01-015 libstdc++.so directory in run path option (2013-06-26)
A new configuration attribute Library_Rpath_Options is created. The main
goal of this attribute is to make sure that shared libraries with C++ code
are linked with a run path option that includes the directory of the
correct libstdc++.so.
NF-21-K826-028 Add support for distributed compilation (2012-12-19)
It is now possible to use multiple computers to conduct the compilations.
This can give good speed-up for large projects.
NF-21-K314-016 Linking several executables simultaneously (2013-07-14)
gprbuild is now able to link several executables simultaneously when
switch -jnnn is used, with nnn other than 1.
gprbuild-gpl-2014-src/known-problems-141 0000644 0000767 0000145 00000014323 11403143521 017332 0 ustar gnatmail gnat ========================================
Known problems in GPRBUILD version 1.4.1
========================================
Copyright (c) 2010 AdaCore
The following is a listing of known problems in release 1.4.1. Except where
specifically noted, all these problems have been corrected in the development
tree of the 1.5 technology. This means they are corrected in any wavefront
issued subsequent to the date specified (in ISO format YYYY-MM-DD) in the
status line. This can be used to determine if a given wavefront has the fix
identified in the entry.
KP-141-J513-012 Same source file name in different projects and languages
Problem: gprbuild does not accept an Ada source to have the same file name
as the source of another language in another project.
Status: This was fixed in 1.5.0 on 2010-05-17
Workaround: Do not put the two projects in the same project tree.
KP-141-J512-013 gprconfig always appends .exe on Windows
Problem: On windows, gprconfig will always add ".exe" to the executable
name specified in the XML files (node ), even if
this extension is already specified.
Status: This was fixed in 1.5.0 on 2010-05-12
Workaround: This is only a problem when trying to share the same XML file
on Unix and Windows systems, and naming the executables with
".exe" on the unix platform. In such a case, use two different
XML files.
KP-141-J506-012 Linking command line too long on VxWorks cross platforms
Problem: On VxWorks cross platforms hosted on Windows, if the linking
command line is too long (>32K) because there are two many
Ada object files, the linking phase will fail.
Status: This was fixed in 1.5.0 on 2010-05-07
Workaround: Reduce the linking command line length by changing some
project files to non shared library project files.
KP-141-J504-020 Shared SAL cannot import non library project
Problem: When building a shared Stand-Alone Library project that imports
a non library project with switch --unchecked-shared-lib-imports,
the binding of the library fails.
Status: This was fixed in 1.4.2 on 2010-05-05
Workaround: Do not import a non library project in a shared SAL
KP-141-J325-035 Fake object files for header files in libraries
Problem: When in a library project a header file has the same base name
as an Ada source in the main project and the library project has
the same object directory as the main project, linking
executables may fail, as the object files corresponding to the
Ada source is not specified to the linker.
Status: This was fixed in 1.4.2 on 2010-03-30
Workaround: Specify a different object directory for the library project.
KP-141-J316-017 Recompilation with switches -I in package Compiler
Problem: When switches -I are specified in package Compiler for languages
other than Ada, gprbuild may recompile up-to-date sources of
these languages.
Status: This was fixed in 1.5.0 on 2010-03-18
Workaround: Avoid switches -I. Use sourceless auxiliary project files to
specify the header directories.
KP-141-J310-029 Builder'Switches (others) not taken into account
Problem: When there are no mains (for example in a library project) or
several mains with different languages, the switches specified in
Builder'Switches (others) are not taken into account.
Status: This was fixed in 1.4.2 on 2010-03-11
Workaround: Specify the switches on the command line.
KP-141-J309-023 Crash with pragma Restrictions (No_Dependence => ...)
Problem gprbuild may crash when an ALI file contains R lines to record
pragmas Restrictions (No_Dependence => ...).
Status: This was fixed in 1.5.0 on 2010-03-11
Workaround: Remove the pragmas Restrictions (No_Dependence => ...).
KP-141-J305-007 gprbuild fails to scan properly ALI files
Problem: When gprbuild is used with an Ada compiler with sources more
recent than those of gprbuild, it may happen that the compiler
put lines in the ALI files that are not known by gprbuild, and
then gprbuild fails to scan properly ALI files.
Status: This was fixed in 1.4.2 on 2010-03-07
Workaround: Use a new version of gprbuild.
KP-141-J301-025 Builder switch -p passed to the compiler
Problem: When gprbuild find the switch -p in package Builder of the
main project, it invoke the compiler with this switch.
Status: This was fixed in 1.5.0 on 2010-03-02
Workaround: Remove switch -p from package Builder.
KP-141-J107-023 Extending project and --no-indirect-imports
Problem: gprbuild fails to compile a source in a project being extended
that imports from the extending project when invoked with
--no-indirect-imports.
Status: This was fixed in 1.4.2 on 2010-01-07
Workaround: Invoke gprbuild without --no-indirect-imports.
KP-141-IC08-014 Duplicate Linker_Options for extending projects
Problem: An project extending another project inherits
Linker'Linker_Options which may result in failure to link because
of duplicate inker options.
Status: This was fixed in 1.5.0 on 2009-12-08
Workaround: Declare empty Linker_Options in the extending project
KP-141-IB16-009 Language configuration redefined in extending project
Problem: When the compiler of a language is defined as non existent and
an existing driver is declared in an extending project, the
the sources of the original project are not compiled.
Status: This was fixed in 1.5.0 on 2009-11-25
Workaround: Avoid declaring non existent compiler if the project is extended.
KP-141-I925-022 No language detected when extending a project with no languages
Problem: A project that extends another project with no languages may
not have a default language, as no languages were found during
auto configuration.
Status: This was fixed in 1.5.0 on 2009-10-23
Workaround: Declare the Ada language in the extending project.
gprbuild-gpl-2014-src/src/ 0000755 0000767 0000145 00000000000 12317234544 014726 5 ustar gnatmail gnat gprbuild-gpl-2014-src/src/gprbuild-link.ads 0000644 0000767 0000145 00000003332 12323721731 020157 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . L I N K --
-- --
-- S p e c --
-- --
-- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
package Gprbuild.Link is
procedure Run;
-- Perform linking, if necessary, for all registered mains: main project,
-- aggregated projects,...
end Gprbuild.Link;
gprbuild-gpl-2014-src/src/ccomp.adb 0000644 0000767 0000145 00000017340 12323721731 016500 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- C C O M P --
-- --
-- B o d y --
-- --
-- Copyright (C) 2010-2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- This program is used on VMS as a front end to invoke the DEC C compiler CC
pragma Extend_System (Aux_DEC);
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Osint; use Osint;
with System; use System;
procedure Ccomp is
subtype Cond_Value_Type is System.Unsigned_Longword;
Output_File_Name : String_Access;
procedure Spawn (Status : out Cond_Value_Type; Command : String;
Input_File : String := String'Null_Parameter;
Output_File : String := String'Null_Parameter);
pragma Import (External, Spawn);
pragma Import_Valued_Procedure
(Spawn, "LIB$SPAWN",
(Cond_Value_Type, String, String, String),
(Value, Descriptor (S), Descriptor (S), Descriptor (S)));
-- LIB$SPAWN is used to invoke the CC compiler
procedure Stop (Status : Cond_Value_Type);
pragma Import (External, Stop);
pragma Import_Procedure (Stop, "LIB$STOP", Mechanism => Value);
-- LIB$STOP is used to set the error code when the invocation of CC fails
Success : constant Cond_Value_Type := 1;
Command : constant String := "cc";
Status : Cond_Value_Type;
Include_Directory : constant String := "/INCLUDE_DIRECTORY=";
Mms_Dependencies : constant String := "/MMS_DEPENDENCIES=FILE=";
Output_File : constant String := "-o";
Verbose : Boolean := False;
procedure Add
(S : in out String_Access;
Last : in out Natural;
Value : String);
-- Add string Value to string variable S, updating Last
---------
-- Add --
---------
procedure Add
(S : in out String_Access;
Last : in out Natural;
Value : String)
is
begin
while S'Last < Last + Value'Length loop
declare
New_S : constant String_Access := new String (1 .. 2 * S'Last);
begin
New_S (1 .. Last) := S (1 .. Last);
Free (S);
S := New_S;
end;
end loop;
S (Last + 1 .. Last + Value'Length) := Value;
Last := Last + Value'Length;
end Add;
begin
declare
Command_String : String_Access := new String (1 .. 40);
-- This is the command string that will be used to invoke CC
Last_Command : Natural := 0;
Includes : String_Access := new String (1 .. 40);
-- As they can be only one /INCLUDE_DIRECTORY= option, we regroupe all
-- directories in string Includes.
Last_Include : Natural := 0;
Arg_Num : Natural;
begin
Add (Command_String, Last_Command, Command);
Arg_Num := 0;
while Arg_Num < Argument_Count loop
Arg_Num := Arg_Num + 1;
declare
Arg : constant String := Argument (Arg_Num);
begin
-- If this command is /INCLUDE_DIRECTORY=, add the directory to
-- string Includes.
if Arg'Length > Include_Directory'Length and then
Arg (Arg'First .. Arg'First + Include_Directory'Length - 1) =
Include_Directory
then
if Last_Include = 0 then
Add (Includes, Last_Include, Include_Directory & "(");
else
Add (Includes, Last_Include, ",");
end if;
declare
Dir : constant String :=
Arg (Arg'First + Include_Directory'Length .. Arg'Last);
New_Dir : String_Access;
begin
if Is_Directory (Dir) then
New_Dir := To_Host_Dir_Spec (Dir, False);
Add (Includes, Last_Include, New_Dir.all);
else
Add (Includes, Last_Include, Dir);
end if;
end;
elsif Arg'Length > Mms_Dependencies'Length and then
Arg (Arg'First .. Arg'First + Mms_Dependencies'Length - 1) =
Mms_Dependencies
then
Add (Command_String,
Last_Command,
" " & Mms_Dependencies &
To_Host_File_Spec
(Arg
(Arg'First + Mms_Dependencies'Length ..
Arg'Last)).all);
-- If it is "-o", the next argument is the output file
elsif Arg = Output_File then
if Arg_Num < Argument_Count then
Arg_Num := Arg_Num + 1;
Output_File_Name := To_Host_File_Spec (Argument (Arg_Num));
end if;
-- If it is "-v", skip the argument and set Verbose to True
elsif Arg = "-v" then
Verbose := True;
-- Otherwise, add argument to the command string
else
declare
New_Arg : String_Access;
begin
if Is_Regular_File (Arg) then
New_Arg := To_Host_File_Spec (Arg);
elsif Is_Directory (Arg) then
New_Arg := To_Host_Dir_Spec (Arg, False);
end if;
if New_Arg /= null then
Add (Command_String, Last_Command, " " & New_Arg.all);
else
Add (Command_String, Last_Command, " " & Arg);
end if;
end;
end if;
end;
end loop;
-- If there was at least one /INCLUDE_DIRECTORY= switch, add
-- /INCLUDE_DIRECTORY= with all directories to the command string.
if Last_Include /= 0 then
Add
(Command_String,
Last_Command,
" " & Includes (1 .. Last_Include) & ")");
end if;
-- Invoke CC
declare
Cmd : constant String (1 .. Last_Command) :=
Command_String (1 .. Last_Command);
begin
if Verbose then
Put_Line (Cmd);
end if;
if Output_File_Name /= null then
Spawn (Status, Cmd, Output_File => Output_File_Name.all);
else
Spawn (Status, Cmd);
end if;
if (Status mod 2) /= Success then
Stop (Status);
end if;
end;
end;
end Ccomp;
gprbuild-gpl-2014-src/src/gprbuild-post_compile.adb 0000644 0000767 0000145 00000361713 12323721731 021710 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . P O S T _ C O M P I L E --
-- --
-- B o d y --
-- --
-- Copyright (C) 2011-2013, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Containers.Ordered_Sets;
with Ada.Text_IO; use Ada, Ada.Text_IO;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Debug; use Debug;
with Gpr_Util; use Gpr_Util;
with Gprexch; use Gprexch;
with Makeutl; use Makeutl;
with Opt;
with Osint; use Osint;
with Output; use Output;
with Prj.Env;
with Prj.Util; use Prj.Util;
with Snames; use Snames;
with Tempdir;
package body Gprbuild.Post_Compile is
type Lang_Names is array (Positive range <>) of Language_Ptr;
type Lang_Names_Ptr is access Lang_Names;
Langs : Lang_Names_Ptr := new Lang_Names (1 .. 4);
Last_Lang : Natural := 0;
procedure Build_Library
(For_Project : Project_Id;
Project_Tree : Project_Tree_Ref;
No_Create : Boolean);
-- Build, if necessary, the library of a library project. If No_Create
-- is True then the actual static or shared library is not built, yet
-- the exchange file with dependencies is created.
procedure Post_Compilation_Phase
(Main_Project : Project_Id; Project_Tree : Project_Tree_Ref);
function Is_Included_In_Global_Archive
(Object_Name : File_Name_Type;
Project : Project_Id) return Boolean;
-- Return True if the object Object_Name is not overridden by a source
-- in a project extending project Project.
type Library_Object is record
Path : Path_Name_Type;
TS : Time_Stamp_Type;
Known : Boolean;
end record;
package Library_Objs is new Table.Table
(Table_Component_Type => Library_Object,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 10,
Table_Name => "Buildgpr.Library_Objs");
-- Library objects with their time stamps
package Project_File_Paths is new GNAT.HTable.Simple_HTable
(Header_Num => Prj.Header_Num,
Element => Boolean,
No_Element => False,
Key => Name_Id,
Hash => Hash,
Equal => "=");
procedure CodePeer_Globalize;
-- Call the codepeer_globalizer for each of the object directories
-------------------
-- Build_Library --
-------------------
procedure Build_Library
(For_Project : Project_Id;
Project_Tree : Project_Tree_Ref;
No_Create : Boolean)
is
package Lang_Set is new Containers.Ordered_Sets (Name_Id);
procedure Get_Objects;
-- Get the paths of the object files of the library in table
-- Library_Objs.
procedure Write_List
(File : Text_IO.File_Type;
Label : Library_Section;
List : String_List_Id);
-- Write values in list into section Label in the given file. Ouptut
-- Label if it is not the current section.
procedure Write_Name_List
(File : Text_IO.File_Type;
Label : Library_Section;
List : Name_List_Index);
-- Write name list values into the File, output Label first. Ouptut
-- Label if it is not the current section.
-- Procedures to write specific sections of the exchange file
procedure Write_Object_Files;
procedure Write_Object_Directory;
procedure Write_Compilers;
procedure Write_Compiler_Leading_Switches;
procedure Write_Compiler_Trailing_Switches;
procedure Write_Partial_Linker;
procedure Write_Shared_Lib_Minimum_Options;
procedure Write_Library_Version;
procedure Write_Runtime_Library_Dir;
procedure Write_Auto_Init;
procedure Write_Run_Path_Option;
procedure Write_Leading_Library_Options;
procedure Write_Library_Options;
procedure Write_Library_Rpath_Options;
procedure Write_Imported_Libraries;
procedure Write_Dependency_Files;
procedure Write_Toolchain_Version;
procedure Write_Interface_Dep_Files;
procedure Write_Other_Interfaces;
procedure Write_Sources;
procedure Write_Response_Files;
Object_Directory_Path : String_Access;
Project_Name : constant String :=
Get_Name_String (For_Project.Name);
Current_Dir : constant String := Get_Current_Dir;
Exchange_File : Text_IO.File_Type;
Exchange_File_Name : String_Access;
Latest_Object_TS : Time_Stamp_Type := Empty_Time_Stamp;
Library_Builder_Name : String_Access;
Library_Builder : String_Access;
Library_Needs_To_Be_Built : Boolean := False;
Object_Path : Path_Name_Type;
Object_TS : Time_Stamp_Type;
Source : Source_Id;
Project : Project_Id;
Disregard : Boolean;
Path_Found : Boolean;
Iter : Source_Iterator;
Current_Section : Library_Section := No_Library_Section;
-----------------
-- Get_Objects --
-----------------
procedure Get_Objects is
procedure Process
(Proj : Project_Id;
Tree : Project_Tree_Ref;
S : in out Boolean);
-- Get objects for corresponding project
-------------
-- Process --
-------------
procedure Process
(Proj : Project_Id;
Tree : Project_Tree_Ref;
S : in out Boolean)
is
pragma Unreferenced (S);
Never : constant Time_Stamp_Type := (others => '9');
-- A time stamp that is greater than any real one
Source : Source_Id;
Iter : Source_Iterator;
begin
Iter := For_Each_Source (Tree, Proj);
loop
Source := Prj.Element (Iter);
exit when Source = No_Source;
Change_To_Object_Directory (Source.Project);
Initialize_Source_Record (Source);
if Is_Compilable (Source)
and then Source.Language.Config.Objects_Linked
and then
((Source.Unit = No_Unit_Index
and then Source.Kind = Impl)
or else
(Source.Unit /= No_Unit_Index
and then (Source.Kind = Impl
or else Other_Part (Source) = No_Source)
and then not Is_Subunit (Source)))
and then
(not Source.Project.Externally_Built
or else Source.Project.Extended_By /= No_Project)
then
Library_Objs.Append
((Path => Source.Object_Path,
TS => Source.Object_TS,
Known => False));
if Source.Object_TS = Empty_Time_Stamp then
Latest_Object_TS := Never;
if not Library_Needs_To_Be_Built then
Library_Needs_To_Be_Built := True;
if Opt.Verbose_Mode then
Write_Str (" -> missing object file: ");
Get_Name_String (Source.Object);
Write_Line (Name_Buffer (1 .. Name_Len));
end if;
end if;
elsif Source.Object_TS > Latest_Object_TS then
Latest_Object_TS := Source.Object_TS;
end if;
end if;
Next (Iter);
end loop;
end Process;
procedure Process_Project_And_Imported is
new For_Every_Project_Imported (Boolean, Process);
S : Boolean := False;
Proj : Project_Id := For_Project;
begin
Library_Objs.Init;
if For_Project.Qualifier = Aggregate_Library then
Process_Project_And_Imported
(For_Project, Project_Tree, S, Include_Aggregated => False);
else
while Proj /= No_Project loop
Process (Proj, Project_Tree, S);
Proj := Proj.Extends;
end loop;
end if;
end Get_Objects;
------------------------
-- Write_Object_Files --
------------------------
procedure Write_Object_Files is
begin
if Library_Objs.Last > 0 then
Put_Line (Exchange_File, Library_Label (Object_Files));
for J in 1 .. Library_Objs.Last loop
Put_Line
(Exchange_File,
Get_Name_String (Library_Objs.Table (J).Path));
end loop;
end if;
end Write_Object_Files;
----------------------------
-- Write_Object_Directory --
----------------------------
procedure Write_Object_Directory is
begin
Put_Line (Exchange_File, Library_Label (Object_Directory));
-- Do not output object directory for an aggregate library as such
-- library does not have objects by themselves.
if For_Project.Qualifier /= Aggregate_Library then
Put_Line (Exchange_File, Object_Directory_Path.all);
end if;
-- Add object directory of project being extended, if any
declare
Proj : Project_Id := For_Project.Extends;
begin
while Proj /= No_Project loop
if Proj.Object_Directory /= No_Path_Information then
Put_Line
(Exchange_File,
Get_Name_String (Proj.Object_Directory.Display_Name));
end if;
Proj := Proj.Extends;
end loop;
end;
-- Add object directories of imported non library projects
Process_Imported_Non_Libraries (For_Project);
declare
Proj : Project_Id;
begin
for J in 1 .. Non_Library_Projs.Last loop
Proj := Non_Library_Projs.Table (J);
if Proj.Object_Directory /= No_Path_Information then
Put_Line
(Exchange_File,
Get_Name_String (Proj.Object_Directory.Display_Name));
end if;
end loop;
end;
-- Add ALI dir directories of imported projects (only if it is not an
-- externally built project or if the project has sources). This skip
-- the library projects with no sources used for example to add a
-- system library to the linker.
declare
List : Project_List := For_Project.All_Imported_Projects;
begin
while List /= null loop
if not List.Project.Externally_Built
or else List.Project.Source_Dirs /= Nil_String
then
if List.Project.Library_ALI_Dir /= No_Path_Information then
Put_Line
(Exchange_File,
Get_Name_String
(List.Project.Library_ALI_Dir.Display_Name));
elsif List.Project.Library_Dir /= No_Path_Information then
Put_Line
(Exchange_File,
Get_Name_String
(List.Project.Library_Dir.Display_Name));
end if;
end if;
List := List.Next;
end loop;
end;
end Write_Object_Directory;
---------------------
-- Write_Compilers --
---------------------
procedure Write_Compilers is
procedure Compilers_For
(Project : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Boolean);
-- Write compilers for the given project
Dummy : Boolean := True;
Lang_Seen : Lang_Set.Set;
-------------------
-- Compilers_For --
-------------------
procedure Compilers_For
(Project : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Boolean)
is
pragma Unreferenced (Tree, Dummy);
Lang : Language_Ptr := Project.Languages;
Compiler : String_Access;
begin
-- Exchange file, Compilers section
while Lang /= No_Language_Index loop
if not Lang_Seen.Contains (Lang.Name) then
Lang_Seen.Insert (Lang.Name);
Compiler := Get_Compiler_Driver_Path (Project_Tree, Lang);
if Compiler /= null then
Put_Line (Exchange_File, Get_Name_String (Lang.Name));
Put_Line (Exchange_File, Compiler.all);
elsif Lang.Config.Compiler_Driver /= No_File then
Put_Line (Exchange_File, Get_Name_String (Lang.Name));
Put_Line
(Exchange_File,
Get_Name_String (Lang.Config.Compiler_Driver));
end if;
end if;
Lang := Lang.Next;
end loop;
end Compilers_For;
procedure For_Imported is
new For_Every_Project_Imported (Boolean, Compilers_For);
begin
Put_Line (Exchange_File, Library_Label (Compilers));
Compilers_For (For_Project, Project_Tree, Dummy);
if For_Project.Qualifier = Aggregate_Library then
For_Imported (For_Project, Project_Tree, Dummy);
end if;
end Write_Compilers;
-------------------------------------
-- Write_Compiler_Leading_Switches --
-------------------------------------
procedure Write_Compiler_Leading_Switches is
procedure Compiler_Leading_Switches_For
(Project : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Boolean);
-- Write compilers for the given project
Dummy : Boolean := True;
Lang_Seen : Lang_Set.Set;
-----------------------------------
-- Compiler_Leading_Switches_For --
-----------------------------------
procedure Compiler_Leading_Switches_For
(Project : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Boolean)
is
pragma Unreferenced (Tree, Dummy);
Lang : Language_Ptr := Project.Languages;
Indx : Name_List_Index;
Node : Name_Node;
begin
while Lang /= No_Language_Index loop
if not Lang_Seen.Contains (Lang.Name) then
Lang_Seen.Insert (Lang.Name);
Indx := Lang.Config.Compiler_Leading_Required_Switches;
if Indx /= No_Name_List then
Put_Line
(Exchange_File,
"language=" & Get_Name_String (Lang.Name));
while Indx /= No_Name_List loop
Node := Project_Tree.Shared.Name_Lists.Table (Indx);
Put_Line (Exchange_File, Get_Name_String (Node.Name));
Indx := Node.Next;
end loop;
end if;
end if;
Lang := Lang.Next;
end loop;
end Compiler_Leading_Switches_For;
procedure For_Imported is new For_Every_Project_Imported
(Boolean, Compiler_Leading_Switches_For);
begin
Put_Line (Exchange_File, Library_Label (Compiler_Leading_Switches));
Compiler_Leading_Switches_For (For_Project, Project_Tree, Dummy);
if For_Project.Qualifier = Aggregate_Library then
For_Imported (For_Project, Project_Tree, Dummy);
end if;
end Write_Compiler_Leading_Switches;
--------------------------------------
-- Write_Compiler_Trailing_Switches --
--------------------------------------
procedure Write_Compiler_Trailing_Switches is
procedure Compiler_Trailing_Switches_For
(Project : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Boolean);
-- Write compilers for the given project
Dummy : Boolean := True;
Lang_Seen : Lang_Set.Set;
------------------------------------
-- Compiler_Trailing_Switches_For --
------------------------------------
procedure Compiler_Trailing_Switches_For
(Project : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Boolean)
is
pragma Unreferenced (Tree, Dummy);
Lang : Language_Ptr := Project.Languages;
Indx : Name_List_Index;
Node : Name_Node;
begin
while Lang /= No_Language_Index loop
if not Lang_Seen.Contains (Lang.Name) then
Lang_Seen.Insert (Lang.Name);
Indx := Lang.Config.Compiler_Trailing_Required_Switches;
if Indx /= No_Name_List then
Put_Line
(Exchange_File,
"language=" & Get_Name_String (Lang.Name));
while Indx /= No_Name_List loop
Node := Project_Tree.Shared.Name_Lists.Table (Indx);
Put_Line (Exchange_File, Get_Name_String (Node.Name));
Indx := Node.Next;
end loop;
end if;
end if;
Lang := Lang.Next;
end loop;
end Compiler_Trailing_Switches_For;
procedure For_Imported is new For_Every_Project_Imported
(Boolean, Compiler_Trailing_Switches_For);
begin
Put_Line
(Exchange_File, Library_Label (Compiler_Trailing_Switches));
Compiler_Trailing_Switches_For (For_Project, Project_Tree, Dummy);
if For_Project.Qualifier = Aggregate_Library then
For_Imported (For_Project, Project_Tree, Dummy);
end if;
end Write_Compiler_Trailing_Switches;
----------------
-- Write_List --
----------------
procedure Write_List
(File : Text_IO.File_Type;
Label : Library_Section;
List : String_List_Id)
is
Current : String_List_Id := List;
Element : String_Element;
Output_Label : Boolean := True;
begin
while Current /= Nil_String loop
Element :=
Project_Tree.Shared.String_Elements.Table (Current);
Get_Name_String (Element.Value);
if Name_Len /= 0 then
if Output_Label and then Current_Section /= Label then
Put_Line (File, Library_Label (Label));
Output_Label := False;
Current_Section := Label;
end if;
Put_Line (File, Name_Buffer (1 .. Name_Len));
end if;
Current := Element.Next;
end loop;
end Write_List;
---------------------
-- Write_Name_List --
---------------------
procedure Write_Name_List
(File : Text_IO.File_Type;
Label : Library_Section;
List : Name_List_Index)
is
Current : Name_List_Index := List;
Nam : Name_Node;
begin
if List /= No_Name_List then
if Current_Section /= Label then
Put_Line (File, Library_Label (Label));
Current_Section := Label;
end if;
while Current /= No_Name_List loop
Nam := Project_Tree.Shared.Name_Lists.Table (Current);
Put_Line (File, Get_Name_String (Nam.Name));
Current := Nam.Next;
end loop;
end if;
end Write_Name_List;
--------------------------
-- Write_Partial_Linker --
--------------------------
procedure Write_Partial_Linker is
List : constant Name_List_Index :=
For_Project.Config.Lib_Partial_Linker;
begin
if List /= No_Name_List then
Write_Name_List (Exchange_File, Partial_Linker, List);
end if;
end Write_Partial_Linker;
--------------------------------------
-- Write_Shared_Lib_Minimum_Options --
--------------------------------------
procedure Write_Shared_Lib_Minimum_Options is
Library_Options : Variable_Value := Nil_Variable_Value;
begin
-- Output the minimal options to build a shared library (standard
-- or encapsulated).
if For_Project.Standalone_Library = Encapsulated then
Library_Options :=
Value_Of
(Name_Library_Encapsulated_Options,
For_Project.Decl.Attributes, Project_Tree.Shared);
if not Library_Options.Default then
Write_List
(Exchange_File,
Gprexch.Shared_Lib_Minimum_Options,
Library_Options.Values);
end if;
else
Write_Name_List
(Exchange_File,
Shared_Lib_Minimum_Options,
For_Project.Config.Shared_Lib_Min_Options);
end if;
end Write_Shared_Lib_Minimum_Options;
---------------------------
-- Write_Library_Version --
---------------------------
procedure Write_Library_Version is
List : constant Name_List_Index :=
For_Project.Config.Lib_Version_Options;
begin
if List /= No_Name_List then
Write_Name_List (Exchange_File, Library_Version_Options, List);
end if;
end Write_Library_Version;
-------------------------------
-- Write_Runtime_Library_Dir --
-------------------------------
procedure Write_Runtime_Library_Dir is
use type Ada.Containers.Count_Type;
procedure RTL_For
(Project : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Boolean);
-- Write runtime libraries for the given project
Dummy : Boolean := True;
Lang_Seen : Lang_Set.Set;
-------------
-- RTL_For --
-------------
procedure RTL_For
(Project : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Boolean)
is
pragma Unreferenced (Tree, Dummy);
List : Language_Ptr := Project.Languages;
begin
while List /= No_Language_Index loop
if List.Config.Runtime_Library_Dir /= No_Name
and then not Lang_Seen.Contains (List.Name)
then
if Lang_Seen.Length = 0 then
Put_Line
(Exchange_File, Library_Label (Runtime_Library_Dir));
end if;
Lang_Seen.Insert (List.Name);
Put_Line (Exchange_File, Get_Name_String (List.Name));
Put_Line
(Exchange_File,
Get_Name_String (List.Config.Runtime_Library_Dir));
end if;
List := List.Next;
end loop;
end RTL_For;
procedure For_Imported is
new For_Every_Project_Imported (Boolean, RTL_For);
begin
RTL_For (For_Project, Project_Tree, Dummy);
if For_Project.Qualifier = Aggregate_Library then
For_Imported (For_Project, Project_Tree, Dummy);
end if;
end Write_Runtime_Library_Dir;
---------------------
-- Write_Auto_Init --
---------------------
procedure Write_Auto_Init is
begin
if For_Project.Standalone_Library /= No then
if For_Project.Lib_Auto_Init then
Put_Line (Exchange_File, Library_Label (Auto_Init));
end if;
declare
Binder_Package : constant Package_Id :=
Value_Of
(Name => Name_Binder,
In_Packages =>
For_Project.Decl.Packages,
Shared => Project_Tree.Shared);
begin
if Binder_Package /= No_Package then
declare
Defaults : constant Array_Element_Id :=
Value_Of
(Name => Name_Default_Switches,
In_Arrays =>
Project_Tree.Shared.Packages.Table
(Binder_Package).Decl.Arrays,
Shared => Project_Tree.Shared);
Switches : Variable_Value := Nil_Variable_Value;
begin
if Defaults /= No_Array_Element then
Switches :=
Value_Of
(Index => Name_Ada,
Src_Index => 0,
In_Array => Defaults,
Shared => Project_Tree.Shared);
if not Switches.Default then
Write_List
(Exchange_File, Gprexch.Binding_Options,
Switches.Values);
end if;
end if;
end;
end if;
end;
end if;
end Write_Auto_Init;
---------------------------
-- Write_Run_Path_Option --
---------------------------
procedure Write_Run_Path_Option is
List : constant Name_List_Index :=
For_Project.Config.Run_Path_Option;
begin
if Opt.Run_Path_Option and then List /= No_Name_List then
Write_Name_List (Exchange_File, Run_Path_Option, List);
if For_Project.Config.Separate_Run_Path_Options then
Put_Line
(Exchange_File,
Library_Label (Gprexch.Separate_Run_Path_Options));
end if;
end if;
end Write_Run_Path_Option;
-----------------------------------
-- Write_Leading_Library_Options --
-----------------------------------
procedure Write_Leading_Library_Options is
Leading_Library_Options : Variable_Value := Nil_Variable_Value;
begin
-- If attribute Leading_Library_Options was specified, add these
-- additional options.
Leading_Library_Options :=
Value_Of
(Name_Leading_Library_Options,
For_Project.Decl.Attributes, Project_Tree.Shared);
if not Leading_Library_Options.Default then
Write_List
(Exchange_File,
Gprexch.Leading_Library_Options,
Leading_Library_Options.Values);
end if;
end Write_Leading_Library_Options;
---------------------------
-- Write_Library_Options --
---------------------------
procedure Write_Library_Options is
Library_Options : Variable_Value := Nil_Variable_Value;
begin
-- If attribute Library_Options was specified, add these
-- additional options.
Library_Options :=
Value_Of
(Name_Library_Options,
For_Project.Decl.Attributes, Project_Tree.Shared);
if not Library_Options.Default then
Write_List
(Exchange_File,
Gprexch.Library_Options, Library_Options.Values);
end if;
end Write_Library_Options;
---------------------------------
-- Write_Library_Rpath_Options --
---------------------------------
procedure Write_Library_Rpath_Options is
procedure Add_Language (Lang : Language_Ptr);
-- Add language Name in array Langs if not already there
procedure Find_Languages
(Project : Project_Id;
Tree : Project_Tree_Ref;
With_State : in out Boolean);
-- Find the languages of a project
procedure Find_All_Languages is new
For_Every_Project_Imported (Boolean, Find_Languages);
procedure Get_Languages;
-- Put in Langs the languages of the project tree rooted at project
-- For_Project.
------------------
-- Add_Language --
------------------
procedure Add_Language (Lang : Language_Ptr) is
begin
-- Only add a language if it is not already in the list
for J in 1 .. Last_Lang loop
if Lang.Name = Langs (J).Name then
return;
end if;
end loop;
-- Double array Langs if already full
if Last_Lang = Langs'Last then
declare
New_Langs : constant Lang_Names_Ptr :=
new Lang_Names (1 .. 2 * Langs'Length);
begin
New_Langs (Langs'Range) := Langs.all;
Langs := New_Langs;
end;
end if;
Last_Lang := Last_Lang + 1;
Langs (Last_Lang) := Lang;
end Add_Language;
--------------------
-- Find_Languages --
--------------------
procedure Find_Languages
(Project : Project_Id;
Tree : Project_Tree_Ref;
With_State : in out Boolean)
is
pragma Unreferenced (Tree);
pragma Unreferenced (With_State);
Lang : Language_Ptr := Project.Languages;
begin
while Lang /= No_Language_Index loop
Add_Language (Lang);
Lang := Lang.Next;
end loop;
end Find_Languages;
-------------------
-- Get_Languages --
-------------------
procedure Get_Languages is
OK : Boolean := True;
begin
Last_Lang := 0;
Find_Languages (For_Project, Project_Tree, OK);
Find_All_Languages
(By => For_Project,
Tree => Project_Tree,
With_State => OK,
Include_Aggregated => False);
end Get_Languages;
List : Array_Element_Id;
Elem : Array_Element;
Label_Issued : Boolean := False;
Lang_Index : Natural;
Lang_Ptr : Language_Ptr;
Opt_List : String_List_Id;
Opt_Elem : String_Element;
begin
if Opt.Run_Path_Option
and then For_Project.Config.Run_Path_Option /= No_Name_List
then
List :=
Value_Of
(Name_Library_Rpath_Options,
For_Project.Decl.Arrays, Project_Tree.Shared);
if List /= No_Array_Element then
Get_Languages;
while Last_Lang /= 0 and then List /= No_Array_Element loop
Elem := Project_Tree.Shared.Array_Elements.Table (List);
Lang_Index := 0;
for J in 1 .. Last_Lang loop
if Elem.Index = Langs (J).Name then
Lang_Index := J;
exit;
end if;
end loop;
if Lang_Index /= 0 then
Lang_Ptr := Langs (Lang_Index);
-- Remove language from the list so that rpath options
-- are not looked for twice for the same language.
Langs (Lang_Index .. Last_Lang - 1) :=
Langs (Lang_Index + 1 .. Last_Lang);
Last_Lang := Last_Lang - 1;
-- Invoke the compiler for the language, followed by
-- the options and put the result into a temporary file.
Opt_List := Elem.Value.Values;
-- Nothing to do if there is no options
if Opt_List /= Nil_String then
declare
Opt_Nmb : Natural := 0;
begin
-- Count the options
while Opt_List /= Nil_String loop
Opt_Elem :=
Project_Tree.Shared.String_Elements.Table
(Opt_List);
Opt_Nmb := Opt_Nmb + 1;
Opt_List := Opt_Elem.Next;
end loop;
declare
Args : Argument_List (1 .. Opt_Nmb);
FD : File_Descriptor;
Pname : Path_Name_Type;
Return_Code : Integer;
pragma Warnings (Off, Return_Code);
File : Text_File;
Line : String (1 .. 1000);
Last : Natural;
Disregard : Boolean;
pragma Warnings (Off, Disregard);
begin
Opt_List := Elem.Value.Values;
Opt_Nmb := 0;
-- Put the options in Args
while Opt_List /= Nil_String loop
Opt_Elem :=
Project_Tree.Shared.String_Elements.Table
(Opt_List);
Opt_Nmb := Opt_Nmb + 1;
Args (Opt_Nmb) :=
new String'
(Get_Name_String (Opt_Elem.Value));
Opt_List := Opt_Elem.Next;
end loop;
-- Create a temporary file and invoke the
-- compiler with the options redirecting
-- the output to this temporary file.
Tempdir.Create_Temp_File (FD, Pname);
Spawn
(Program_Name =>
Lang_Ptr.Config.Compiler_Driver_Path.all,
Args => Args,
Output_File_Descriptor => FD,
Return_Code => Return_Code);
Close (FD);
-- Now read the temporary file and get the first
-- non empty line, if any.
Open (File, Get_Name_String (Pname));
if Is_Valid (File) then
Last := 0;
while not End_Of_File (File) loop
Get_Line (File, Line, Last);
exit when Last > 0;
end loop;
-- Get the directory name of the path
if Last /= 0 then
declare
Dir : constant String :=
Dir_Name
(Normalize_Pathname
(Line (1 .. Last)));
begin
-- If it is in fact a directory, put it
-- in the exchange file.
if Is_Directory (Dir) then
if not Label_Issued then
Put_Line
(Exchange_File,
Library_Label
(Gprexch.Library_Rpath_Options));
Label_Issued := True;
end if;
Put_Line
(Exchange_File, Dir);
end if;
end;
end if;
end if;
if Is_Valid (File) then
Close (File);
end if;
-- Delete the temporary file, if gprbuild was
-- not invoked with -dn.
if not Debug_Flag_N then
Delete_File
(Get_Name_String (Pname), Disregard);
end if;
end;
end;
end if;
end if;
List := Elem.Next;
end loop;
end if;
end if;
end Write_Library_Rpath_Options;
------------------------------
-- Write_Imported_Libraries --
------------------------------
procedure Write_Imported_Libraries is
begin
-- If there are imported libraries, put their data in the exchange
-- file.
if Library_Projs.Last > 0 then
Put_Line (Exchange_File, Library_Label (Imported_Libraries));
for J in reverse 1 .. Library_Projs.Last loop
if For_Project.Qualifier /= Aggregate_Library
or else Library_Projs.Table (J).Proj.Externally_Built
then
Put_Line
(Exchange_File,
Get_Name_String
(Library_Projs.Table (J).
Proj.Library_Dir.Display_Name));
Put_Line
(Exchange_File,
Get_Name_String
(Library_Projs.Table (J).Proj.Library_Name));
end if;
end loop;
end if;
end Write_Imported_Libraries;
----------------------------
-- Write_Dependency_Files --
----------------------------
procedure Write_Dependency_Files is
Current_Proj : Project_Id := For_Project;
Source : Source_Id;
begin
Put_Line (Exchange_File, Library_Label (Dependency_Files));
while Current_Proj /= No_Project loop
declare
Iter : Source_Iterator;
begin
if Current_Proj.Qualifier = Aggregate_Library then
Iter := For_Each_Source (Project_Tree);
else
Iter := For_Each_Source (Project_Tree, Current_Proj);
end if;
loop
Source := Prj.Element (Iter);
exit when Source = No_Source;
if not Source.Locally_Removed
and then Source.Dep_Path /= No_Path
and then
(not Source.Project.Externally_Built
or else Source.Project.Extended_By /= No_Project)
then
if Source.Kind = Spec then
if Other_Part (Source) = No_Source then
Put_Line
(Exchange_File,
Get_Name_String (Source.Dep_Path));
end if;
elsif not Is_Subunit (Source) then
Put_Line
(Exchange_File,
Get_Name_String (Source.Dep_Path));
end if;
end if;
Next (Iter);
end loop;
Current_Proj := Current_Proj.Extends;
end;
end loop;
end Write_Dependency_Files;
-----------------------------
-- Write_Toolchain_Version --
-----------------------------
procedure Write_Toolchain_Version is
use type Ada.Containers.Count_Type;
procedure Toolchain_Version_For
(Project : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Boolean);
-- Write runtime libraries for the given project
Dummy : Boolean := True;
Lang_Seen : Lang_Set.Set;
---------------------------
-- Toolchain_Version_For --
---------------------------
procedure Toolchain_Version_For
(Project : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Boolean)
is
pragma Unreferenced (Tree, Dummy);
List : Language_Ptr := Project.Languages;
begin
while List /= No_Language_Index loop
if List.Config.Toolchain_Version /= No_Name
and then not Lang_Seen.Contains (List.Name)
then
if Lang_Seen.Length = 0 then
Put_Line
(Exchange_File, Library_Label (Toolchain_Version));
end if;
Lang_Seen.Insert (List.Name);
Put_Line (Exchange_File, Get_Name_String (List.Name));
Put_Line
(Exchange_File,
Get_Name_String (List.Config.Toolchain_Version));
end if;
List := List.Next;
end loop;
end Toolchain_Version_For;
procedure For_Imported is
new For_Every_Project_Imported (Boolean, Toolchain_Version_For);
begin
Toolchain_Version_For (For_Project, Project_Tree, Dummy);
if For_Project.Qualifier = Aggregate_Library then
For_Imported (For_Project, Project_Tree, Dummy);
end if;
end Write_Toolchain_Version;
-------------------------------
-- Write_Interface_Dep_Files --
-------------------------------
procedure Write_Interface_Dep_Files is
Interface_ALIs : String_List_Id :=
For_Project.Lib_Interface_ALIs;
Element : String_Element;
begin
Put_Line (Exchange_File, Library_Label (Interface_Dep_Files));
while Interface_ALIs /= Nil_String loop
Element :=
Project_Tree.Shared.String_Elements.Table (Interface_ALIs);
-- Find the source to get the absolute path of the ALI file
declare
Next_Proj : Project_Id;
Iter : Source_Iterator;
begin
Next_Proj := For_Project.Extends;
if For_Project.Qualifier = Aggregate_Library then
Iter := For_Each_Source (Project_Tree);
else
Iter := For_Each_Source (Project_Tree, For_Project);
end if;
loop
while Prj.Element (Iter) /= No_Source
and then
(Prj.Element (Iter).Unit = null
or else Prj.Element (Iter).Dep_Name /=
File_Name_Type (Element.Value))
loop
Next (Iter);
end loop;
Source := Prj.Element (Iter);
exit when Source /= No_Source
or else Next_Proj = No_Project;
Iter := For_Each_Source (Project_Tree, Next_Proj);
Next_Proj := Next_Proj.Extends;
end loop;
if Source /= No_Source then
if Source.Kind = Sep then
Source := No_Source;
elsif Source.Kind = Spec
and then Other_Part (Source) /= No_Source
then
Source := Other_Part (Source);
end if;
end if;
if Source /= No_Source then
if Source.Project /= Project
and then not Is_Extending (For_Project, Source.Project)
and then not (For_Project.Qualifier = Aggregate_Library)
then
Source := No_Source;
end if;
end if;
if Source /= No_Source then
Put_Line (Exchange_File, Get_Name_String (Source.Dep_Path));
end if;
end;
Interface_ALIs := Element.Next;
end loop;
end Write_Interface_Dep_Files;
----------------------------
-- Write_Other_Interfaces --
----------------------------
procedure Write_Other_Interfaces is
Interfaces : String_List_Id :=
For_Project.Other_Interfaces;
Element : String_Element;
begin
Put_Line (Exchange_File, Library_Label (Other_Interfaces));
while Interfaces /= Nil_String loop
Element :=
Project_Tree.Shared.String_Elements.Table (Interfaces);
Put_Line (Exchange_File, Get_Name_String (Element.Value));
Interfaces := Element.Next;
end loop;
end Write_Other_Interfaces;
-------------------
-- Write_Sources --
-------------------
procedure Write_Sources is
begin
Put_Line (Exchange_File, Library_Label (Sources));
-- Copy the path of the sources
Project := For_Project;
while Project /= No_Project loop
Iter := For_Each_Source (Project_Tree, Project);
loop
Source := Prj.Element (Iter);
exit when Source = No_Source;
if not Source.Locally_Removed
and then Source.Replaced_By = No_Source
then
Put_Line
(Exchange_File,
Get_Name_String (Source.Path.Display_Name));
end if;
Next (Iter);
end loop;
Project := Project.Extends;
end loop;
end Write_Sources;
--------------------------
-- Write_Response_Files --
--------------------------
procedure Write_Response_Files is
begin
if For_Project.Config.Max_Command_Line_Length > 0
and then For_Project.Config.Resp_File_Format /= None
then
Put_Line (Exchange_File, Library_Label (Max_Command_Line_Length));
Put_Line
(Exchange_File, For_Project.Config.Max_Command_Line_Length'Img);
Put_Line
(Exchange_File, Library_Label (Gprexch.Response_File_Format));
Put_Line
(Exchange_File, For_Project.Config.Resp_File_Format'Img);
if For_Project.Config.Resp_File_Options /= No_Name_List then
Write_Name_List
(Exchange_File, Response_File_Switches,
For_Project.Config.Resp_File_Options);
end if;
if Debug.Debug_Flag_N then
Put_Line (Exchange_File, Library_Label (Keep_Response_File));
end if;
end if;
end Write_Response_Files;
-- Start of processing for Build_Library
begin
-- Check if there is an object directory
if For_Project.Object_Directory.Display_Name = No_Path then
Fail_Program
(Project_Tree,
"no object directory for library project " &
Get_Name_String (For_Project.Display_Name));
end if;
Object_Directory_Path :=
new String'(Get_Name_String
(For_Project.Object_Directory.Display_Name));
-- Check consistentcy and build environment
if For_Project.Config.Lib_Support = None then
Fail_Program (Project_Tree,
"library projects not supported on this platform");
elsif For_Project.Library_Kind /= Static
and then For_Project.Config.Lib_Support /= Full
then
Fail_Program
(Project_Tree,
"shared library projects not supported on this platform");
elsif not For_Project.Config.Lib_Encapsulated_Supported
and then For_Project.Standalone_Library = Encapsulated
then
Fail_Program
(Project_Tree,
"encapsulated library projects not supported on this platform");
end if;
if For_Project.Config.Library_Builder = No_Path then
Fail_Program (Project_Tree, "no library builder specified");
else
Library_Builder :=
Locate_Exec_On_Path
(Get_Name_String (For_Project.Config.Library_Builder));
if Library_Builder = null then
Fail_Program
(Project_Tree,
"could not locate library builder """ &
Get_Name_String (For_Project.Config.Library_Builder) & '"');
else
Library_Builder_Name :=
new String'(Base_Name (Library_Builder.all));
end if;
end if;
if For_Project.Library_Kind = Static then
Check_Archive_Builder;
end if;
Library_Needs_To_Be_Built := Opt.Force_Compilations;
if not Library_Needs_To_Be_Built and then Opt.Verbose_Mode then
Write_Str (" Checking library ");
Get_Name_String (For_Project.Library_Name);
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Line (" ...");
end if;
Get_Objects;
-- Work occurs in the object directory
Change_To_Object_Directory (For_Project);
-- Get the name of of the library exchange file
Get_Name_String (For_Project.Library_Name);
Add_Str_To_Name_Buffer (Library_Exchange_Suffix);
Exchange_File_Name := new String'(Name_Buffer (1 .. Name_Len));
if not Library_Needs_To_Be_Built then
declare
TS : constant Time_Stamp_Type :=
File_Stamp (File_Name_Type'(Name_Find));
begin
if String (TS) < String (Latest_Object_TS) then
Library_Needs_To_Be_Built := True;
if Opt.Verbose_Mode then
if TS = Empty_Time_Stamp then
Write_Line
(" -> library exchange file " &
Exchange_File_Name.all &
" does not exist");
else
Write_Line
(" -> object files more recent than" &
" library exchange file " &
Exchange_File_Name.all);
end if;
end if;
else
begin
Open (Exchange_File, In_File, Exchange_File_Name.all);
if End_Of_File (Exchange_File) then
if Opt.Verbose_Mode then
Write_Str (" -> library exchange file """);
Write_Str (Exchange_File_Name.all);
Write_Line (""" is empty");
end if;
Library_Needs_To_Be_Built := True;
end if;
exception
when others =>
if Opt.Verbose_Mode then
Write_Str
(" -> library exchange file """);
Write_Str (Exchange_File_Name.all);
Write_Line (""" cannot be open");
end if;
Library_Needs_To_Be_Built := True;
end;
end if;
end;
end if;
if not Library_Needs_To_Be_Built then
-- The exchange file is open in input
-- Get the path of the library file that should be the first field
Get_Line (Exchange_File, Name_Buffer, Name_Len);
if Name_Buffer (1 .. Name_Len) /= Library_Label (Library_Path) then
Library_Needs_To_Be_Built := True;
Close (Exchange_File);
if Opt.Verbose_Mode then
Write_Line (" -> library exchange file " &
Exchange_File_Name.all &
" has wrong format");
end if;
else
Get_Line (Exchange_File, Name_Buffer, Name_Len);
if String (File_Stamp (File_Name_Type'(Name_Find))) <
String (Latest_Object_TS)
then
Library_Needs_To_Be_Built := True;
Close (Exchange_File);
if Opt.Verbose_Mode then
Write_Line
(" -> object file(s) more recent than library file " &
Exchange_File_Name.all);
end if;
end if;
end if;
end if;
if not Library_Needs_To_Be_Built then
-- The next line should be the object file label, followed by the
-- object paths and time stamps.
Get_Line (Exchange_File, Name_Buffer, Name_Len);
if Name_Buffer (1 .. Name_Len) /= Library_Label (Object_Files) then
Library_Needs_To_Be_Built := True;
if Opt.Verbose_Mode then
Write_Line (" -> library exchange file " &
Exchange_File_Name.all & " has wrong format");
end if;
end if;
while not Library_Needs_To_Be_Built
and then not End_Of_File (Exchange_File)
loop
Get_Line (Exchange_File, Name_Buffer, Name_Len);
exit when Name_Buffer (1) = '[';
Object_Path := Name_Find;
Library_Needs_To_Be_Built := True;
if End_Of_File (Exchange_File) then
if Opt.Verbose_Mode then
Write_Line
(" -> library exchange file " &
Exchange_File_Name.all & " has wrong format");
end if;
else
Get_Line (Exchange_File, Name_Buffer, Name_Len);
if Name_Len = Time_Stamp_Length then
Object_TS :=
Time_Stamp_Type (Name_Buffer (1 .. Name_Len));
Path_Found := False;
for Index in 1 .. Library_Objs.Last loop
if Object_Path = Library_Objs.Table (Index).Path then
Path_Found := True;
Library_Needs_To_Be_Built :=
Object_TS /= Library_Objs.Table (Index).TS;
Library_Objs.Table (Index).Known := True;
exit;
end if;
end loop;
-- If the object file is not found, it may be that the path
-- in the library is the same as the path of the object
-- files, but with different symbolic links. So, we try
-- again resolving the symbolic links.
if not Path_Found then
declare
Norm_Path : constant String :=
Normalize_Pathname
(Get_Name_String (Object_Path));
begin
for Index in 1 .. Library_Objs.Last loop
if Norm_Path =
Normalize_Pathname
(Get_Name_String
(Library_Objs.Table (Index).Path))
then
Library_Needs_To_Be_Built :=
Object_TS /= Library_Objs.Table (Index).TS;
Library_Objs.Table (Index).Known := True;
exit;
end if;
end loop;
end;
end if;
if Library_Needs_To_Be_Built and then Opt.Verbose_Mode then
Write_Str (" -> object file ");
Write_Str (Get_Name_String (Object_Path));
Write_Line
(" does not exist or have wrong time stamp");
end if;
else
if Opt.Verbose_Mode then
Write_Line
(" -> library exchange file " &
Exchange_File_Name.all &
" has wrong format");
end if;
end if;
end if;
end loop;
Close (Exchange_File);
if not Library_Needs_To_Be_Built then
for Index in 1 .. Library_Objs.Last loop
if not Library_Objs.Table (Index).Known then
Library_Needs_To_Be_Built := True;
if Opt.Verbose_Mode then
Write_Str
(" -> library was built without object file ");
Write_Line
(Get_Name_String (Library_Objs.Table (Index).Path));
end if;
exit;
end if;
end loop;
end if;
end if;
if not Library_Needs_To_Be_Built then
if Opt.Verbose_Mode then
Write_Line (" -> up to date");
end if;
else
-- Create the library exchange file
begin
Create (Exchange_File, Out_File, Exchange_File_Name.all);
exception
when others =>
Fail_Program
(Project_Tree,
"unable to create library exchange file " &
Exchange_File_Name.all);
end;
if Opt.Quiet_Output then
Put_Line (Exchange_File, Library_Label (Quiet));
elsif Opt.Verbose_Mode then
Put_Line (Exchange_File, Library_Label (Verbose));
end if;
Write_Object_Files;
-- Library name
Put_Line (Exchange_File, Library_Label (Library_Name));
Put_Line (Exchange_File, Get_Name_String (For_Project.Library_Name));
-- Library version
if For_Project.Lib_Internal_Name /= No_Name then
Put_Line (Exchange_File, Library_Label (Library_Version));
Put_Line (Exchange_File,
Get_Name_String (For_Project.Lib_Internal_Name));
end if;
-- Library directory
Put_Line (Exchange_File, Library_Label (Library_Directory));
Put_Line
(Exchange_File,
Get_Name_String (For_Project.Library_Dir.Display_Name));
if For_Project.Library_ALI_Dir /= No_Path_Information
and then
For_Project.Library_ALI_Dir.Name /= For_Project.Library_Dir.Name
then
Put_Line
(Exchange_File, Library_Label (Library_Dependency_Directory));
Put_Line
(Exchange_File,
Get_Name_String (For_Project.Library_ALI_Dir.Display_Name));
end if;
Write_Object_Directory;
Write_Compilers;
Write_Compiler_Leading_Switches;
Write_Compiler_Trailing_Switches;
Write_Partial_Linker;
if No_Create then
Put_Line (Exchange_File, Library_Label (Gprexch.No_Create));
end if;
if For_Project.Qualifier = Aggregate_Library then
Put_Line (Exchange_File, Library_Label (Gprexch.No_Copy_ALI));
end if;
if For_Project.Library_Kind = Static then
Put_Line (Exchange_File, Library_Label (Static));
Put_Line (Exchange_File, Library_Label (Archive_Builder));
Put_Line (Exchange_File, Archive_Builder_Path.all);
for J in 1 .. Archive_Builder_Opts.Last loop
Put_Line (Exchange_File, Archive_Builder_Opts.Options (J).all);
end loop;
if Archive_Builder_Append_Opts.Last > 0 then
Put_Line
(Exchange_File,
Library_Label (Archive_Builder_Append_Option));
for J in 1 .. Archive_Builder_Append_Opts.Last loop
Put_Line
(Exchange_File,
Archive_Builder_Append_Opts.Options (J).all);
end loop;
end if;
if For_Project.Config.Archive_Suffix /= No_File then
Put_Line (Exchange_File, Library_Label (Archive_Suffix));
Put_Line
(Exchange_File,
Get_Name_String (For_Project.Config.Archive_Suffix));
end if;
if Archive_Indexer_Path /= null then
Put_Line (Exchange_File, Library_Label (Archive_Indexer));
Put_Line (Exchange_File, Archive_Indexer_Path.all);
for J in 1 .. Archive_Indexer_Opts.Last loop
Put_Line
(Exchange_File, Archive_Indexer_Opts.Options (J).all);
end loop;
end if;
else
-- Driver_Name
if For_Project.Config.Shared_Lib_Driver /= No_File then
Put_Line (Exchange_File, Library_Label (Driver_Name));
Put_Line
(Exchange_File,
Get_Name_String (For_Project.Config.Shared_Lib_Driver));
end if;
-- Shared_Lib_Prefix
if For_Project.Config.Shared_Lib_Prefix /= No_File then
Put_Line (Exchange_File, Library_Label (Shared_Lib_Prefix));
Put_Line
(Exchange_File,
Get_Name_String (For_Project.Config.Shared_Lib_Prefix));
end if;
-- Shared_Lib_Suffix
if For_Project.Config.Shared_Lib_Suffix /= No_File then
Put_Line (Exchange_File, Library_Label (Shared_Lib_Suffix));
Put_Line
(Exchange_File,
Get_Name_String (For_Project.Config.Shared_Lib_Suffix));
end if;
Write_Shared_Lib_Minimum_Options;
Write_Library_Version;
-- Symbolic_Link_Supported
if For_Project.Config.Symbolic_Link_Supported then
Put_Line
(Exchange_File, Library_Label (Symbolic_Link_Supported));
end if;
-- Major_Minor_Id_Supported
if For_Project.Config.Lib_Maj_Min_Id_Supported then
Put_Line
(Exchange_File, Library_Label (Major_Minor_Id_Supported));
end if;
Process_Imported_Libraries
(For_Project, There_Are_SALs => Disregard);
Write_Runtime_Library_Dir;
-- Relocatable
if For_Project.Library_Kind /= Static then
Put_Line (Exchange_File, Library_Label (Relocatable));
end if;
-- Auto_init
Write_Auto_Init;
-- Gprexch.Install_Name
if
For_Project.Config.Library_Install_Name_Option /= No_Name
then
Put_Line (Exchange_File, Library_Label (Gprexch.Install_Name));
Put_Line
(Exchange_File,
Get_Name_String
(For_Project.Config.Library_Install_Name_Option));
end if;
Write_Run_Path_Option;
Write_Leading_Library_Options;
Write_Library_Options;
Write_Library_Rpath_Options;
Write_Imported_Libraries;
end if;
Write_Dependency_Files;
Write_Toolchain_Version;
if For_Project.Standalone_Library /= No then
if For_Project.Lib_Auto_Init then
Put_Line (Exchange_File, Library_Label (Auto_Init));
end if;
Write_Interface_Dep_Files;
if For_Project.Other_Interfaces /= Nil_String then
Write_Other_Interfaces;
end if;
if For_Project.Library_Src_Dir /= No_Path_Information then
-- Copy_Source_Dir
Put_Line (Exchange_File, Library_Label (Copy_Source_Dir));
Put_Line
(Exchange_File,
Get_Name_String (For_Project.Library_Src_Dir.Display_Name));
Write_Sources;
end if;
-- Standalone mode
Put_Line (Exchange_File, Library_Label (Standalone_Mode));
Put_Line
(Exchange_File,
Standalone'Image (For_Project.Standalone_Library));
elsif For_Project.Other_Interfaces /= Nil_String then
Write_Other_Interfaces;
end if;
Write_Response_Files;
Close (Exchange_File);
declare
Arguments : constant Argument_List := (1 => Exchange_File_Name);
Success : Boolean;
begin
if not Opt.Quiet_Output then
if Opt.Verbose_Mode then
Write_Str (Library_Builder.all);
else
Write_Str (Library_Builder_Name.all);
end if;
Write_Char (' ');
Write_Line (Exchange_File_Name.all);
end if;
Spawn (Library_Builder.all, Arguments, Success);
if not Success then
Fail_Program
(Project_Tree,
"could not build library for project " & Project_Name);
end if;
end;
end if;
-- Restore the current working directory to its previous value
Change_Dir (Current_Dir);
end Build_Library;
------------------------
-- CodePeer_Globalize --
------------------------
procedure CodePeer_Globalize is
Globalizer : constant String := "codepeer_globalizer";
-- CodePeer globalizer executable name
Globalizer_Path : constant String_Access :=
GNAT.OS_Lib.Locate_Exec_On_Path (Globalizer);
-- Path for CodePeer globalizer
Quiet_Str : aliased String := "-quiet";
Globalizer_Args : constant Argument_List :=
(1 => Quiet_Str'Unchecked_Access);
Previous_Dir : String_Access := null;
Success : Boolean;
procedure Globalize_Dir (Dir : String);
-- Call CodePeer globalizer on Dir
-------------------
-- Globalize_Dir --
-------------------
procedure Globalize_Dir (Dir : String) is
Result : Boolean;
begin
if Previous_Dir = null or else Dir /= Previous_Dir.all then
Free (Previous_Dir);
Previous_Dir := new String'(Dir);
Change_Dir (Dir);
GNAT.OS_Lib.Spawn (Globalizer_Path.all, Globalizer_Args, Result);
Success := Success and Result;
end if;
end Globalize_Dir;
procedure Globalize_Dirs is new
Prj.Env.For_All_Object_Dirs (Globalize_Dir);
begin
if Globalizer_Path = null then
Fail_Program (Project_Tree, "error, unable to locate " & Globalizer);
elsif not Opt.Quiet_Output then
Write_Str (Globalizer);
Write_Char (' ');
Write_Line (Quiet_Str);
end if;
Success := True;
Globalize_Dirs (Main_Project, Project_Tree);
if not Success then
Fail_Program (Project_Tree, "codepeer_globalizer failed");
end if;
end CodePeer_Globalize;
-----------------------------------
-- Is_Included_In_Global_Archive --
-----------------------------------
function Is_Included_In_Global_Archive
(Object_Name : File_Name_Type;
Project : Project_Id) return Boolean
is
Proj : Project_Id;
Source : Source_Id;
Iter : Source_Iterator;
begin
-- If a source is overriden in an extending project, then the object
-- file is not included in the global archive.
Proj := Project.Extended_By;
while Proj /= No_Project loop
Iter := For_Each_Source (Project_Tree, Proj);
loop
Source := Prj.Element (Iter);
exit when Source = No_Source;
if Object_To_Global_Archive (Source)
and then Source.Object = Object_Name
then
return False;
end if;
Next (Iter);
end loop;
Proj := Proj.Extended_By;
end loop;
Iter := For_Each_Source (Project_Tree, Project);
loop
Source := Prj.Element (Iter);
exit when Source = No_Source;
if Object_To_Global_Archive (Source)
and then Source.Object = Object_Name
then
return Source.Language.Config.Objects_Linked;
end if;
Next (Iter);
end loop;
return True;
end Is_Included_In_Global_Archive;
---------
-- Run --
---------
procedure Run is
Data : Process_Data;
Main : Main_Info;
OK : Boolean;
procedure Do_Post (Project : Project_Id; Tree : Project_Tree_Ref);
-------------
-- Do_Post --
-------------
procedure Do_Post (Project : Project_Id; Tree : Project_Tree_Ref) is
begin
if Builder_Data (Tree).Need_Binding
and then not Stop_Spawning
then
Post_Compilation_Phase (Project, Tree);
end if;
end Do_Post;
procedure Post_Compile_All is new For_Project_And_Aggregated (Do_Post);
begin
Outstanding_Processes := 0;
Stop_Spawning := False;
if Main_Project.Qualifier = Aggregate_Library then
-- For an aggregate library we do not want to build separate
-- libraries if any, this means that at this point we want to
-- handle only the main aggregate library project.
Post_Compilation_Phase (Main_Project, Project_Tree);
else
Post_Compile_All (Main_Project, Project_Tree);
end if;
while Outstanding_Processes > 0 loop
Await_Process (Data, OK);
if not OK then
Record_Failure (Data.Main);
end if;
Display_Processes ("bind");
end loop;
if Bad_Processes.Last = 1 then
Main := Bad_Processes.Table (1);
Fail_Program
(Main.Tree,
"unable to bind " & Get_Name_String (Main.File));
elsif Bad_Processes.Last > 1 then
for J in 1 .. Bad_Processes.Last loop
Main := Bad_Processes.Table (J);
Write_Str (" binding of ");
Write_Str (Get_Name_String (Main.File));
Write_Line (" failed");
end loop;
Fail_Program (Main.Tree, "*** post compilation phase failed");
end if;
if Opt.CodePeer_Mode then
CodePeer_Globalize;
end if;
end Run;
----------------------------
-- Post_Compilation_Phase --
----------------------------
procedure Post_Compilation_Phase
(Main_Project : Project_Id; Project_Tree : Project_Tree_Ref)
is
Exchange_File : Text_IO.File_Type;
Line : String (1 .. 1_000);
Last : Natural;
Proj_List : Project_List;
Shared_Libs : Boolean := False;
Bind_Exchange_TS : Time_Stamp_Type;
Bind_Object_TS : Time_Stamp_Type;
Binder_Driver_Needs_To_Be_Called : Boolean := False;
Project_Path : Name_Id;
Project_File_TS : Time_Stamp_Type;
There_Are_Stand_Alone_Libraries : Boolean := False;
-- Set to True if there are SALS in the project tree
procedure Bind_Language
(Main_Proj : Project_Id;
Main : String;
Main_Base_Name_Index : File_Name_Type;
Main_File : Main_Info;
Main_Id : File_Name_Type;
B_Data : Binding_Data);
-- Do the "binding" phase for the language describeb in B_Data
procedure Add_Dependency_Files
(For_Project : Project_Id;
Language : Language_Ptr;
Main_Source : Source_Id;
Dep_Files : out Boolean);
-- Put the dependency files of the project in the binder exchange file
procedure Wait_For_Available_Slot;
--------------------------
-- Add_Dependency_Files --
--------------------------
procedure Add_Dependency_Files
(For_Project : Project_Id;
Language : Language_Ptr;
Main_Source : Source_Id;
Dep_Files : out Boolean)
is
Config : constant Language_Config := Language.Config;
Roots : Roots_Access;
Iter : Source_Iterator;
procedure Put_Dependency_File (Source : Source_Id);
-- Put in the exchange file the dependency file path name for source
-- Source, if applicable.
-------------------------
-- Put_Dependency_File --
-------------------------
procedure Put_Dependency_File (Source : Source_Id) is
begin
if Source.Language.Name = Language.Name
and then
((Config.Kind = File_Based and then Source.Kind = Impl)
or else
(Config.Kind = Unit_Based
and then
Source.Unit /= No_Unit_Index
and then
Source.Unit /= Main_Source.Unit
and then
(Source.Kind = Impl
or else
Other_Part (Source) = No_Source)
and then not Is_Subunit (Source)))
and then Is_Included_In_Global_Archive
(Source.Object, Source.Project)
then
if Source.Project = For_Project
or not Source.Project.Library
or Config.Kind = File_Based
then
Put_Line (Exchange_File, Get_Name_String (Source.Dep_Path));
Dep_Files := True;
elsif Source.Project.Standalone_Library = No then
Get_Name_String
(Source.Project.Library_ALI_Dir.Display_Name);
Get_Name_String_And_Append (Source.Dep_Name);
Put_Line (Exchange_File, Name_Buffer (1 .. Name_Len));
Dep_Files := True;
end if;
end if;
end Put_Dependency_File;
begin
Dep_Files := False;
Roots := Main_Source.Roots;
if Roots = null then
if Main_Source.Unit = No_Unit_Index then
if Main_Project.Qualifier = Aggregate_Library then
Iter := For_Each_Source (Project_Tree);
else
Iter := For_Each_Source
(Project_Tree, Encapsulated_Libs => False);
end if;
while Prj.Element (Iter) /= No_Source loop
Initialize_Source_Record (Prj.Element (Iter));
-- Do not bind the non compilable sources, such as those
-- that have been locally removed.
if Is_Compilable (Prj.Element (Iter)) then
Put_Dependency_File (Prj.Element (Iter));
end if;
Next (Iter);
end loop;
end if;
else
-- Put the Roots
while Roots /= null loop
Put_Dependency_File (Roots.Root);
Roots := Roots.Next;
end loop;
end if;
end Add_Dependency_Files;
-------------------
-- Bind_Language --
-------------------
procedure Bind_Language
(Main_Proj : Project_Id;
Main : String;
Main_Base_Name_Index : File_Name_Type;
Main_File : Main_Info;
Main_Id : File_Name_Type;
B_Data : Binding_Data)
is
Main_Source : constant Source_Id := Main_File.Source;
Bind_Exchange : String_Access;
Options_Instance : Bind_Option_Table_Ref :=
No_Bind_Option_Table;
Dep_Files : Boolean;
Lang_Index : Language_Ptr;
Object_File_Suffix_Label_Written : Boolean;
begin
Binder_Driver_Needs_To_Be_Called :=
Opt.Force_Compilations or Opt.CodePeer_Mode;
-- First check if the binder driver needs to be called.
-- It needs to be called if
-- 1) there is no existing binder exchange file
-- 2) there is no binder generated object file
-- 3) there is a dependency file of the language that
-- is more recent than any of these two files
if not Binder_Driver_Needs_To_Be_Called
and then Opt.Verbose_Mode
then
Write_Line
(" Checking binder generated files for " & Main & "...");
end if;
Bind_Exchange :=
Binder_Exchange_File_Name
(Main_Base_Name_Index, B_Data.Binder_Prefix);
Bind_Exchange_TS :=
File_Stamp
(Path_Name_Type'(Create_Name (Bind_Exchange.all)));
if not Binder_Driver_Needs_To_Be_Called then
if Bind_Exchange_TS = Empty_Time_Stamp then
Binder_Driver_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Line
(" -> binder exchange file " &
Bind_Exchange.all &
" does not exist");
end if;
else
begin
Open (Exchange_File, In_File, Bind_Exchange.all);
exception
when others =>
Binder_Driver_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Line
(" -> could not open " &
"binder exchange file" &
Bind_Exchange.all);
end if;
end;
end if;
end if;
if not Binder_Driver_Needs_To_Be_Called then
begin
Get_Line (Exchange_File, Line, Last);
exception
when others =>
Binder_Driver_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Line
(" -> previous gprbind failed, or " &
Bind_Exchange.all &
" corrupted");
end if;
end;
end if;
-- Check the generated object file
if not Binder_Driver_Needs_To_Be_Called then
if Line (1 .. Last) /= Binding_Label (Generated_Object_File)
or else End_Of_File (Exchange_File)
then
Binder_Driver_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Line
(" -> previous gprbind failed, or " &
Bind_Exchange.all &
" corrupted");
end if;
else
Get_Line (Exchange_File, Line, Last);
Bind_Object_TS :=
File_Stamp
(Path_Name_Type'(Create_Name (Line (1 .. Last))));
if Bind_Object_TS = Empty_Time_Stamp then
Binder_Driver_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Line
(" -> binder generated object " &
Line (1 .. Last) &
" does not exist");
end if;
end if;
end if;
end if;
if not Binder_Driver_Needs_To_Be_Called then
if End_Of_File (Exchange_File) then
Binder_Driver_Needs_To_Be_Called := True;
else
Get_Line (Exchange_File, Line, Last);
if Line (1 .. Last) /= Binding_Label (Project_Files)
or else End_Of_File (Exchange_File)
then
Binder_Driver_Needs_To_Be_Called := True;
end if;
end if;
if Binder_Driver_Needs_To_Be_Called then
if Opt.Verbose_Mode then
Write_Line
(" -> previous gprbind failed, or " &
Bind_Exchange.all & " corrupted");
end if;
else
-- Populate the hash table Project_File_Paths with
-- the paths of all project files in the closure
-- of the main project.
Project_File_Paths.Reset;
Project_File_Paths.Set
(Name_Id (Main_Proj.Path.Display_Name), True);
Proj_List := Main_Proj.All_Imported_Projects;
while Proj_List /= null loop
Project_File_Paths.Set
(Name_Id (Proj_List.Project.Path.Display_Name),
True);
Proj_List := Proj_List.Next;
end loop;
-- Get the project file paths from the exchange
-- file and check if they are the expected project
-- files with the same time stamps.
while not End_Of_File (Exchange_File) loop
Get_Line (Exchange_File, Name_Buffer, Name_Len);
exit when Name_Len > 0 and then Name_Buffer (1) = '[';
if End_Of_File (Exchange_File) then
Binder_Driver_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Line
(" -> previous gprbind failed, " &
"or " &
Bind_Exchange.all &
" corrupted");
end if;
exit;
end if;
Project_Path := Name_Find;
if Project_File_Paths.Get (Project_Path) then
Project_File_Paths.Remove (Project_Path);
Get_Line (Exchange_File, Line, Last);
Project_File_TS :=
File_Stamp (Path_Name_Type (Project_Path));
if String (Project_File_TS) /= Line (1 .. Last) then
Binder_Driver_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Line
(" -> project file " &
Get_Name_String (Project_Path) &
" has been modified");
end if;
exit;
end if;
else
Binder_Driver_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Line
(" -> unknown project file " &
Get_Name_String (Project_Path));
end if;
exit;
end if;
end loop;
-- Check if there are still project file paths in
-- the has table.
if not Binder_Driver_Needs_To_Be_Called
and then Project_File_Paths.Get_First
then
Binder_Driver_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Line
(" -> more project files");
end if;
end if;
end if;
end if;
if Is_Open (Exchange_File) then
Close (Exchange_File);
end if;
if not Binder_Driver_Needs_To_Be_Called then
Queue.Initialize (Opt.One_Compilation_Per_Obj_Dir, Force => True);
declare
Config : constant Language_Config :=
B_Data.Language.Config;
Source_Identity : Source_Id;
Roots : Roots_Access;
Source : Source_Id;
Iter : Source_Iterator;
begin
-- Put the root sources in the queue
if Main_Source.Language.Name = B_Data.Language.Name then
Queue.Insert
(Source => (Format => Format_Gprbuild,
Tree => Main_File.Tree,
Id => Main_File.Source));
end if;
Roots := Main_Source.Roots;
while Roots /= null loop
Queue.Insert
(Source => (Format => Format_Gprbuild,
Tree => Main_File.Tree,
Id => Roots.Root));
Roots := Roots.Next;
end loop;
-- If main is not unit base and there is no root,
-- check all sources with the language name of the
-- binder, except those that are not interfaces of
-- their project.
if Queue.Is_Empty then
Iter := For_Each_Source (Project_Tree);
Loop1 : loop
Source := Prj.Element (Iter);
exit Loop1 when Source = No_Source;
if Source.Language.Name = B_Data.Language.Name
and then not Source.Locally_Removed
and then Is_Compilable (Source)
and then
((Config.Kind = File_Based
and then Source.Kind = Impl)
or else
(Config.Kind = Unit_Based
and then Source.Unit /= No_Unit_Index
and then Source.Unit /= Main_Source.Unit
and then (Source.Kind = Impl
or else Other_Part (Source) = No_Source)
and then not Is_Subunit (Source)))
and then Source.In_Interfaces
then
declare
Proj : Project_Id;
Src : Source_Id;
Iter2 : Source_Iterator;
begin
-- If a source is overriden in an
-- extending project, then the object file
-- is not included in the global archive.
Proj := Source.Project.Extended_By;
Loop2 : while Proj /= No_Project loop
Iter2 := For_Each_Source (Project_Tree, Proj);
loop
Src := Prj.Element (Iter2);
exit when Src = No_Source;
exit Loop1 when
Src.Object = Source.Object;
Next (Iter2);
end loop;
Proj := Proj.Extended_By;
end loop Loop2;
end;
Queue.Insert
(Source => (Format => Format_Gprbuild,
Tree => Main_File.Tree,
Id => Source));
end if;
Next (Iter);
end loop Loop1;
end if;
-- Get each file from the queue and check its
-- dependency file.
declare
Dep_TS : aliased File_Attributes := Unknown_Attributes;
Dep_File : File_Name_Type;
Dep_Path : Path_Name_Type;
Stamp : Time_Stamp_Type;
The_ALI : ALI.ALI_Id;
Text : Text_Buffer_Ptr;
Found : Boolean;
Source : Queue.Source_Info;
begin
while not Queue.Is_Empty loop
Queue.Extract (Found, Source);
Source_Identity := Source.Id;
Initialize_Source_Record (Source_Identity);
-- Get the dependency file for this source
Dep_File := Source_Identity.Dep_Name;
Dep_Path := Source_Identity.Dep_Path;
Dep_TS := Source_Identity.Dep_TS;
-- For a library file, if there is no ALI file
-- in the object directory, check in the Library
-- ALI directory.
if not Is_Regular_File (Get_Name_String (Dep_Path))
and then Source_Identity.Project.Library
and then
Source_Identity.Project.Library_ALI_Dir /=
No_Path_Information
then
Name_Len := 0;
Add_Str_To_Name_Buffer
(Get_Name_String
(Source_Identity.Project
.Library_ALI_Dir.Display_Name));
Add_Char_To_Name_Buffer (Directory_Separator);
Add_Str_To_Name_Buffer (Get_Name_String (Dep_File));
Name_Buffer (Name_Len + 1) := ASCII.NUL;
Dep_TS := Unknown_Attributes;
if Is_Regular_File
(Name_Buffer'Address, Dep_TS'Access)
then
Dep_Path := Name_Find;
end if;
end if;
declare
Proj : Project_Id :=
Source_Identity.Project.Extended_By;
begin
while Proj /= No_Project loop
Name_Len := 0;
if Proj.Library
and then
Proj.Library_ALI_Dir /= No_Path_Information
then
Add_Str_To_Name_Buffer
(Get_Name_String
(Proj.Library_ALI_Dir.Display_Name));
else
Add_Str_To_Name_Buffer
(Get_Name_String
(Proj.Object_Directory.Display_Name));
end if;
Add_Char_To_Name_Buffer
(Directory_Separator);
Add_Str_To_Name_Buffer
(Get_Name_String (Dep_File));
Name_Buffer (Name_Len + 1) := ASCII.NUL;
-- Check if the dependency file exists in
-- the extended project, and if it does,
-- replace both Dep_Path and Dep_TS with
-- the information for it.
declare
NDT : aliased File_Attributes :=
Unknown_Attributes;
begin
if Is_Regular_File
(Name_Buffer'Address, NDT'Access)
then
Dep_Path := Name_Find;
Dep_TS := NDT;
end if;
end;
Proj := Proj.Extended_By;
end loop;
end;
Stamp := File_Time_Stamp (Dep_Path, Dep_TS'Access);
-- Check the time stamp against the binder
-- exchange file time stamp.
if Stamp = Empty_Time_Stamp then
Binder_Driver_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Str (" -> cannot find ");
Write_Line (Get_Name_String (Dep_Path));
end if;
exit;
elsif Stamp > Bind_Exchange_TS then
Binder_Driver_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Str (" -> ");
Write_Str (Get_Name_String (Dep_Path));
Write_Line
(" is more recent that the binder " &
"exchange file");
end if;
exit;
else
Text := Read_Library_Info_From_Full
(File_Name_Type (Dep_Path), Dep_TS'Access);
if Text /= null then
The_ALI :=
ALI.Scan_ALI
(File_Name_Type (Dep_Path),
Text,
Ignore_ED => False,
Err => True,
Ignore_Errors => True,
Read_Lines => "W");
Free (Text);
Queue.Insert_Withed_Sources_For
(The_ALI,
Project_Tree,
Excluding_Shared_SALs => True);
end if;
end if;
end loop;
end;
end;
end if;
if not Binder_Driver_Needs_To_Be_Called then
if Opt.Verbose_Mode then
Write_Line (" -> up to date");
end if;
else
Create (Exchange_File, Out_File, Bind_Exchange.all);
-- Optional line: Quiet or Verbose
if Opt.Quiet_Output then
Put_Line (Exchange_File, Binding_Label (Quiet));
elsif Opt.Verbose_Mode then
Put_Line (Exchange_File, Binding_Label (Verbose));
end if;
-- If -dn was used, indicate to gprbind that the
-- temporary response file, if created, should not
-- deleted.
if Debug_Flag_N then
Put_Line (Exchange_File, Binding_Label (Delete_Temp_Files));
Put_Line (Exchange_File, "False");
end if;
-- If there are Stand-Alone Libraries, tell it to gprbind
if There_Are_Stand_Alone_Libraries then
Put_Line
(Exchange_File,
Binding_Label (Gprexch.There_Are_Stand_Alone_Libraries));
end if;
-- If the language is Ada, create a binder mapping file
-- and pass it to gprbind.
if B_Data.Language_Name = Name_Ada then
declare
Mapping_Path : constant Path_Name_Type :=
Create_Binder_Mapping_File (Project_Tree);
begin
if Mapping_Path /= No_Path then
Put_Line
(Exchange_File,
Binding_Label (Gprexch.Mapping_File));
Put_Line
(Exchange_File,
Get_Name_String (Mapping_Path));
end if;
end;
end if;
-- Send the Toolchain Version if there is one for the language
if B_Data.Language.Config.Toolchain_Version /= No_Name then
Put_Line (Exchange_File, Binding_Label (Toolchain_Version));
Put_Line
(Exchange_File,
Get_Name_String (B_Data.Language.Name));
Put_Line
(Exchange_File,
Get_Name_String (B_Data.Language.Config.Toolchain_Version));
end if;
-- Send the object file suffix for each language where it
-- is declared.
Lang_Index := Main_Proj.Languages;
Object_File_Suffix_Label_Written := False;
while Lang_Index /= No_Language_Index loop
if Lang_Index.Config.Object_File_Suffix /= No_Name then
if not Object_File_Suffix_Label_Written then
Put_Line
(Exchange_File, Binding_Label
(Gprexch.Object_File_Suffix));
Object_File_Suffix_Label_Written := True;
end if;
Put_Line
(Exchange_File, Get_Name_String (Lang_Index.Name));
Put_Line
(Exchange_File,
Get_Name_String (Lang_Index.Config.Object_File_Suffix));
end if;
Lang_Index := Lang_Index.Next;
end loop;
-- Optional line: shared libs
if Shared_Libs then
Put_Line (Exchange_File, Binding_Label (Gprexch.Shared_Libs));
end if;
-- First, the main base name
Put_Line (Exchange_File, Binding_Label (Gprexch.Main_Base_Name));
Put_Line (Exchange_File, Get_Name_String (Main_Base_Name_Index));
-- Then, the compiler path and required switches
declare
Config : Language_Config renames B_Data.Language.Config;
List : Name_List_Index;
Nam_Nod : Name_Node;
Previous_Was_x : Boolean := False;
begin
-- Compiler path
Put_Line
(Exchange_File, Binding_Label (Gprexch.Compiler_Path));
Put_Line
(Exchange_File,
Get_Compiler_Driver_Path
(Project_Tree, B_Data.Language).all);
-- Leading required switches, if any
List := Config.Compiler_Leading_Required_Switches;
if List /= No_Name_List then
Put_Line
(Exchange_File,
Binding_Label (Gprexch.Compiler_Leading_Switches));
while List /= No_Name_List loop
Nam_Nod := Project_Tree.Shared.Name_Lists.Table (List);
if Opt.CodePeer_Mode and then Previous_Was_x then
Put_Line (Exchange_File, "adascil");
else
Put_Line
(Exchange_File,
Get_Name_String (Nam_Nod.Name));
end if;
Previous_Was_x := Get_Name_String (Nam_Nod.Name) = "-x";
List := Nam_Nod.Next;
end loop;
if Opt.CodePeer_Mode then
Put_Line (Exchange_File, "-gnatcC");
end if;
end if;
-- Trailing required switches, if any
List := Config.Compiler_Trailing_Required_Switches;
if List /= No_Name_List then
Put_Line
(Exchange_File,
Binding_Label
(Gprexch.Compiler_Trailing_Switches));
while List /= No_Name_List loop
Nam_Nod :=
Project_Tree.Shared.Name_Lists.Table (List);
Put_Line
(Exchange_File, Get_Name_String (Nam_Nod.Name));
List := Nam_Nod.Next;
end loop;
end if;
end;
-- Then, the Dependency files
if Main_Source.Unit /= No_Unit_Index then
Initialize_Source_Record (Main_Source);
Put_Line
(Exchange_File, Binding_Label (Main_Dependency_File));
Put_Line
(Exchange_File, Get_Name_String (Main_Source.Dep_Path));
end if;
-- Add the relevant dependency files, either those in
-- Roots () for the project, or all dependency
-- files in the project tree, if Roots () is not
-- specified .
Put_Line (Exchange_File, Binding_Label (Dependency_Files));
Add_Dependency_Files
(Main_Proj, B_Data.Language, Main_Source, Dep_Files);
-- Put the options, if any
declare
The_Packages : constant Package_Id :=
Main_Proj.Decl.Packages;
Binder_Package : constant Prj.Package_Id :=
Prj.Util.Value_Of
(Name => Name_Binder,
In_Packages => The_Packages,
Shared => Project_Tree.Shared);
Config : constant Language_Config :=
B_Data.Language.Config;
Switches : Variable_Value;
Switch_List : String_List_Id;
Element : String_Element;
begin
-- First, check if there are binder options
-- specified in the main project file.
if Binder_Package /= No_Package then
declare
Defaults : constant Array_Element_Id :=
Prj.Util.Value_Of
(Name => Name_Default_Switches,
In_Arrays =>
Project_Tree.Shared.Packages.Table
(Binder_Package).Decl.Arrays,
Shared => Project_Tree.Shared);
Switches_Array : constant Array_Element_Id :=
Prj.Util.Value_Of
(Name => Name_Switches,
In_Arrays =>
Project_Tree.Shared.Packages.Table
(Binder_Package).Decl.Arrays,
Shared => Project_Tree.Shared);
begin
Switches :=
Prj.Util.Value_Of
(Index => Name_Id (Main_Id),
Src_Index => 0,
In_Array => Switches_Array,
Shared => Project_Tree.Shared,
Allow_Wildcards => True);
if Switches = Nil_Variable_Value then
Switches :=
Prj.Util.Value_Of
(Index =>
B_Data.Language_Name,
Src_Index => 0,
In_Array => Switches_Array,
Shared => Project_Tree.Shared,
Force_Lower_Case_Index => True);
end if;
if Switches = Nil_Variable_Value then
Switches :=
Prj.Util.Value_Of
(Index => All_Other_Names,
Src_Index => 0,
In_Array => Switches_Array,
Shared => Project_Tree.Shared,
Force_Lower_Case_Index => True);
end if;
if Switches = Nil_Variable_Value then
Switches :=
Prj.Util.Value_Of
(Index => B_Data.Language_Name,
Src_Index => 0,
In_Array => Defaults,
Shared => Project_Tree.Shared);
end if;
end;
end if;
-- If there are binder options, either minimum
-- binder options, or in the main project file or
-- on the command line, put them in the exchange
-- file.
Options_Instance :=
Binder_Options_HTable.Get (B_Data.Language_Name);
if Config.Binder_Required_Switches /= No_Name_List
or else Switches.Kind = Prj.List
or else All_Language_Binder_Options.Last > 0
or else Options_Instance /= No_Bind_Option_Table
or else Opt.CodePeer_Mode
then
Put_Line
(Exchange_File, Binding_Label (Gprexch.Binding_Options));
-- First, the required switches, if any
declare
List : Name_List_Index :=
Config.Binder_Required_Switches;
Elem : Name_Node;
begin
while List /= No_Name_List loop
Elem :=
Project_Tree.Shared.Name_Lists.Table (List);
Get_Name_String (Elem.Name);
if Name_Len > 0 then
Put_Line
(Exchange_File,
Name_Buffer (1 .. Name_Len));
end if;
List := Elem.Next;
end loop;
end;
-- Then, the eventual options in the main
-- project file.
if Switches.Kind = Prj.List then
declare
Option : String_Access;
begin
Switch_List := Switches.Values;
while Switch_List /= Nil_String loop
Element :=
Project_Tree.Shared.String_Elements.Table
(Switch_List);
Get_Name_String (Element.Value);
if Name_Len > 0 then
Option :=
new String'
(Name_Buffer (1 .. Name_Len));
Test_If_Relative_Path
(Option,
Main_Project_Dir.all,
No_Name);
Put_Line (Exchange_File, Option.all);
end if;
Switch_List := Element.Next;
end loop;
end;
end if;
-- Then -P if in CodePeer mode
if Opt.CodePeer_Mode then
Put_Line (Exchange_File, "-P");
end if;
-- Then those on the command line, for all
-- binder drivers, if any.
for J in 1 .. All_Language_Binder_Options.Last loop
Put_Line
(Exchange_File,
All_Language_Binder_Options.Table (J).all);
end loop;
-- Finally those on the command line for the
-- binder driver of the language
if Options_Instance /= No_Bind_Option_Table then
for Index in 1 .. Binder_Options.Last
(Options_Instance.all)
loop
Put_Line
(Exchange_File,
Options_Instance.Table (Index).all);
end loop;
end if;
end if;
end;
-- Finally, the list of the project paths with their
-- time stamps.
Put_Line (Exchange_File, Binding_Label (Project_Files));
-- The main project file is always the first one, so that
-- gprbind may know the main project dir.
Put_Line
(Exchange_File,
Get_Name_String (Main_Proj.Path.Display_Name));
Put_Line
(Exchange_File,
String (File_Stamp (Main_Proj.Path.Display_Name)));
Proj_List := Main_Proj.All_Imported_Projects;
while Proj_List /= null loop
if Main_Proj.Standalone_Library = Encapsulated
or else not Proj_List.From_Encapsulated_Lib
then
Put_Line
(Exchange_File,
Get_Name_String
(Proj_List.Project.Path.Display_Name));
Put_Line
(Exchange_File,
String
(File_Stamp
(Proj_List.Project.Path.Display_Name)));
end if;
Proj_List := Proj_List.Next;
end loop;
Close (Exchange_File);
if Main_Source.Unit = No_Unit_Index and then (not Dep_Files) then
if Opt.Verbose_Mode then
Write_Line (" -> nothing to bind");
end if;
else
if B_Data.Language.Config.Objects_Path /= No_Name then
declare
Env_Var : constant String :=
Get_Name_String
(B_Data.Language.Config.
Objects_Path);
Path_Name : String_Access :=
Main_Proj.Objects_Path;
begin
if Path_Name = null then
if Current_Verbosity = High then
Put_Line (Env_Var & " :");
end if;
Get_Directories
(Project_Tree => Project_Tree,
For_Project => Main_Proj,
Activity => Executable_Binding,
Languages => No_Names);
Path_Name := Create_Path_From_Dirs;
Main_Proj.Objects_Path := Path_Name;
end if;
Setenv (Env_Var, Path_Name.all);
if Opt.Verbose_Mode then
Write_Str (Env_Var);
Write_Str (" = ");
Write_Line (Path_Name.all);
end if;
end;
elsif B_Data.Language.Config.Objects_Path_File /= No_Name then
declare
Env_Var : constant String :=
Get_Name_String
(B_Data.Language.Config.
Objects_Path_File);
Path_Name : Path_Name_Type :=
Main_Proj.Objects_Path_File_Without_Libs;
begin
if Path_Name = No_Path then
if Current_Verbosity = High then
Put_Line (Env_Var & " :");
end if;
Get_Directories
(Project_Tree => Project_Tree,
For_Project => Main_Proj,
Activity => Executable_Binding,
Languages => No_Names);
declare
FD : File_Descriptor;
Len : Integer;
Status : Boolean;
begin
Prj.Env.Create_New_Path_File
(Shared => Project_Tree.Shared,
Path_FD => FD,
Path_Name =>
Main_Proj.
Objects_Path_File_Without_Libs);
if FD = Invalid_FD then
Fail_Program
(Project_Tree,
"could not create " &
"temporary path file");
end if;
Path_Name :=
Main_Proj.
Objects_Path_File_Without_Libs;
for Index in 1 .. Directories.Last loop
Get_Name_String
(Directories.Table (Index));
if Current_Verbosity = High then
Put_Line
(Name_Buffer (1 .. Name_Len));
end if;
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.LF;
Len :=
Write
(FD,
Name_Buffer (1)'Address,
Name_Len);
if Len /= Name_Len then
Fail_Program
(Project_Tree, "disk full");
end if;
end loop;
Close (FD, Status);
if not Status then
Fail_Program
(Project_Tree, "disk full");
end if;
end;
end if;
Setenv (Env_Var, Get_Name_String (Path_Name));
if Opt.Verbose_Mode then
Write_Str (Env_Var);
Write_Str (" = ");
Write_Line (Get_Name_String (Path_Name));
end if;
end;
end if;
if not Opt.Quiet_Output then
if Opt.Verbose_Mode then
Write_Str (B_Data.Binder_Driver_Path.all);
else
Name_Len := 0;
Add_Str_To_Name_Buffer
(Base_Name
(Get_Name_String
(B_Data.Binder_Driver_Name)));
if Executable_Suffix'Length /= 0
and then Name_Len > Executable_Suffix'Length
and then Name_Buffer
(Name_Len - Executable_Suffix'Length + 1
.. Name_Len) = Executable_Suffix.all
then
Name_Len := Name_Len - Executable_Suffix'Length;
end if;
Write_Str (Name_Buffer (1 .. Name_Len));
end if;
Write_Char (' ');
Write_Line (Bind_Exchange.all);
end if;
declare
Pid : Process_Id;
begin
Pid := Non_Blocking_Spawn
(B_Data.Binder_Driver_Path.all, (1 => Bind_Exchange));
if Pid = Invalid_Pid then
Record_Failure (Main_File);
else
Add_Process (Pid, (Binding, Pid, Main_File));
Display_Processes ("bind");
end if;
end;
end if;
end if;
end Bind_Language;
-----------------------------
-- Wait_For_Available_Slot --
-----------------------------
procedure Wait_For_Available_Slot is
Data : Process_Data;
OK : Boolean;
begin
while Outstanding_Processes >= Opt.Maximum_Processes loop
Await_Process (Data, OK);
if not OK then
Record_Failure (Data.Main);
end if;
Display_Processes ("bind");
end loop;
end Wait_For_Available_Slot;
-- Start of processing for Post_Compilation_Phase
begin
-- Build the libraries, if any
-- First, get the libraries in building order in table Library_Projs
if not Opt.CodePeer_Mode then
Process_Imported_Libraries
(Main_Project,
There_Are_SALs => There_Are_Stand_Alone_Libraries,
And_Project_Itself => True);
if Library_Projs.Last > 0 then
declare
Lib_Projs : array (1 .. Library_Projs.Last) of Library_Project;
Proj : Library_Project;
begin
-- Copy the list of library projects in local array Lib_Projs,
-- as procedure Build_Library uses table Library_Projs.
for J in 1 .. Library_Projs.Last loop
Lib_Projs (J) := Library_Projs.Table (J);
end loop;
for J in Lib_Projs'Range loop
Proj := Lib_Projs (J);
-- Try building a library only if no errors occured in
-- library project and projects it depends on.
if not Project_Compilation_Failed (Proj.Proj) then
if Proj.Proj.Extended_By = No_Project then
if not Proj.Proj.Externally_Built then
Build_Library
(Proj.Proj, Project_Tree,
No_Create => Proj.Is_Aggregated);
end if;
if Proj.Proj.Library_Kind /= Static then
Shared_Libs := True;
end if;
end if;
end if;
end loop;
end;
end if;
end if;
-- If no main is specified, there is nothing else to do
if Mains.Number_Of_Mains (Project_Tree) = 0 then
return;
end if;
-- Check if there is a need to call a binder driver
Find_Binding_Languages (Project_Tree, Main_Project);
-- Proceed to bind (or rebind if needed) for each main
Mains.Reset;
loop
declare
Main_File : Main_Info;
begin
Main_File := Mains.Next_Main;
exit when Main_File = No_Main_Info;
if Main_File.Tree /= Project_Tree
or else Project_Compilation_Failed (Main_File.Project)
then
-- Will be processed later, or do not need any processing in
-- the case of compilation errors in the project.
null;
elsif
not Builder_Data (Main_File.Tree).There_Are_Binder_Drivers
then
if Current_Verbosity = High then
Debug_Output ("Post-compilation, no binding required for",
Debug_Name (Main_File.Tree));
end if;
else
declare
Main : constant String :=
Get_Name_String (Main_File.File);
Main_Id : constant File_Name_Type :=
Create_Name (Base_Name (Main));
Main_Index : constant Int := Main_File.Index;
B_Data : Binding_Data;
Main_Base_Name_Index : File_Name_Type;
Main_Proj : Project_Id;
Index_Separator : Character;
begin
Main_Proj := Ultimate_Extending_Project_Of
(Main_File.Source.Project);
-- Get the main base name-index name
Index_Separator :=
Main_File.Source.Language
.Config.Multi_Unit_Object_Separator;
Main_Base_Name_Index :=
Base_Name_Index_For (Main, Main_Index, Index_Separator);
Change_To_Object_Directory (Main_Proj);
B_Data := Builder_Data (Main_File.Tree).Binding;
while B_Data /= null loop
Wait_For_Available_Slot;
exit when Stop_Spawning;
Bind_Language
(Main_Proj, Main, Main_Base_Name_Index,
Main_File, Main_Id, B_Data);
exit when Stop_Spawning;
B_Data := B_Data.Next;
end loop;
end;
end if;
end;
end loop;
end Post_Compilation_Phase;
end Gprbuild.Post_Compile;
gprbuild-gpl-2014-src/src/gprlib-build_shared_lib-nosymbols.adb 0000644 0000767 0000145 00000034030 12323721731 024145 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R L I B . B U I L D _ S H A R E D _ L I B --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006-2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- This is the version of the body of procedure Build_Shared_Lib for most
-- non VMS platforms where shared libraries are supported.
with MLib; use MLib;
with Output; use Output;
separate (Gprlib)
procedure Build_Shared_Lib is
Ofiles : constant Argument_List :=
Argument_List (Object_Files.Table (1 .. Object_Files.Last));
Options : constant Argument_List :=
Argument_List (Options_Table.Table (1 .. Options_Table.Last));
Lib_File : constant String :=
Shared_Lib_Prefix.all &
Library_Name.all & Shared_Lib_Suffix.all;
Lib_Path : constant String :=
Library_Directory.all & Lib_File;
Maj_Version : String_Access := new String'("");
Result : Integer;
pragma Unreferenced (Result);
procedure Build (Output_File : String);
-- Find the library builder executable and invoke it with the correct
-- options to build the shared library.
-----------
-- Build --
-----------
procedure Build (Output_File : String) is
Success : Boolean;
Out_Opt : constant String_Access := new String'("-o");
Out_V : constant String_Access := new String'(Output_File);
Driver : String_Access;
Lib_Index : Natural := 0;
Response_File_Name : Path_Name_Type := No_Path;
Response_2 : Path_Name_Type := No_Path;
procedure Display_Linking_Command;
-- Display the linking command, depending on verbosity and quiet output
-----------------------------
-- Display_Linking_Command --
-----------------------------
procedure Display_Linking_Command is
begin
if not Opt.Quiet_Output then
if Opt.Verbose_Mode then
Write_Str (Driver.all);
else
Write_Str (Base_Name (Driver.all));
end if;
for J in 1 .. Last_Arg loop
if Opt.Verbose_Mode or else
J <= Lib_Index or else
J = First_Object
then
Write_Char (' ');
Write_Str (Arguments (J).all);
elsif J > First_Object then
Write_Str (" ...");
exit;
elsif J = Lib_Index + 1 then
Write_Str (" ...");
end if;
end loop;
Write_Eol;
end if;
end Display_Linking_Command;
begin
-- Get the executable to use, either the specified Driver, or "gcc"
if Driver_Name = No_Name then
Driver := Locate_Exec_On_Path (Gcc_Name);
if Driver = null then
Osint.Fail (Gcc_Name & " not found in path");
end if;
else
Driver := Locate_Exec_On_Path (Get_Name_String (Driver_Name));
if Driver = null then
Osint.Fail (Get_Name_String (Driver_Name) & " not found in path");
end if;
end if;
Last_Arg := 0;
Argument_Length := Driver'Length;
-- The minimum arguments
for J in 1 .. Shared_Lib_Minimum_Options.Last loop
Add_Arg (Shared_Lib_Minimum_Options.Table (J));
end loop;
-- The leading library options, if any
for J in 1 .. Leading_Library_Options_Table.Last loop
Add_Arg (Leading_Library_Options_Table.Table (J));
end loop;
-- -o
Add_Arg (Out_Opt);
Add_Arg (Out_V);
Lib_Index := Last_Arg;
-- The options
for J in Options'Range loop
if Options (J) /= null and then Options (J).all /= "" then
Add_Arg (Options (J));
end if;
end loop;
-- Other options
for J in 1 .. Library_Version_Options.Last loop
if Library_Version_Options.Table (J).all /= "" then
Add_Arg (Library_Version_Options.Table (J));
end if;
end loop;
-- The object files
if Partial_Linker /= null then
Partial_Linker_Path := Locate_Exec_On_Path (Partial_Linker.all);
if Partial_Linker_Path = null then
Osint.Fail ("unable to locate linker " & Partial_Linker.all);
end if;
end if;
if Resp_File_Format = Prj.None
and then Partial_Linker_Path /= null
then
-- If partial linker is used, do a partial link first
Partial_Number := 0;
First_Object := Ofiles'First;
loop
declare
Partial : constant String_Access :=
new String'
(Partial_Name
(Library_Name.all,
Partial_Number,
Object_Suffix));
Size : Natural := 0;
Saved_Last_PL_Option : Natural;
begin
Saved_Last_PL_Option := Last_PL_Option;
Add (Partial, PL_Options, Last_PL_Option);
Size := Size + 1 + Partial'Length;
if Partial_Number > 0 then
Add
(Partial_Name
(Library_Name.all,
Partial_Number - 1,
Object_Suffix),
PL_Options,
Last_PL_Option);
end if;
for J in 1 .. Last_PL_Option loop
Size := Size + 1 + PL_Options (J)'Length;
end loop;
loop
Add
(Ofiles (First_Object),
PL_Options,
Last_PL_Option);
Size := Size + 1 + PL_Options (Last_PL_Option)'Length;
First_Object := First_Object + 1;
exit when
First_Object > Ofiles'Last or else
Size >= Maximum_Size;
end loop;
if not Quiet_Output then
if Verbose_Mode then
Put (Partial_Linker_Path.all);
else
Put (Base_Name (Partial_Linker_Path.all));
end if;
for J in 1 .. Last_PL_Option loop
if (not Verbose_Mode) and then J >= 5 then
Put (" ...");
exit;
end if;
Put (' ');
Put (PL_Options (J).all);
end loop;
New_Line;
end if;
Spawn
(Partial_Linker_Path.all,
PL_Options (1 .. Last_PL_Option),
Success);
if not Success then
Osint.Fail
("call to linker driver " &
Partial_Linker.all & " failed");
end if;
if First_Object > Ofiles'Last then
Add_Arg (Partial);
exit;
end if;
Last_PL_Option := Saved_Last_PL_Option;
Partial_Number := Partial_Number + 1;
end;
end loop;
else
First_Object := Last_Arg + 1;
for J in Ofiles'Range loop
Add_Arg (Ofiles (J));
end loop;
end if;
Last_Object := Last_Arg;
-- In Ofiles we can have at the end some libraries -lname, so ensure
-- that the object are only taken up to Last_Object_File_Index.
if Last_Object_File_Index > First_Object
and then Last_Object_File_Index < Last_Object
then
Last_Object := Last_Object_File_Index;
end if;
-- Finally the library switches and the library options
for J in 1 .. Library_Switches_Table.Last loop
Add_Arg (Library_Switches_Table.Table (J));
end loop;
for J in 1 .. Library_Options_Table.Last loop
Add_Arg (Library_Options_Table.Table (J));
end loop;
Display_Linking_Command;
-- Check if a response file is needed
if Max_Command_Line_Length > 0
and then Argument_Length > Max_Command_Line_Length
and then Resp_File_Format /= Prj.None
then
declare
-- Preserve the options, if any
Options : constant String_List :=
Arguments (Last_Object + 1 .. Last_Arg);
begin
Create_Response_File
(Format => Resp_File_Format,
Objects => Arguments (First_Object .. Last_Object),
Other_Arguments => Options,
Resp_File_Options => Response_File_Switches.all,
Name_1 => Response_File_Name,
Name_2 => Response_2);
Last_Arg := First_Object - 1;
if Resp_File_Format = GCC
or else Resp_File_Format = GCC_GNU
or else Resp_File_Format = GCC_Object_List
or else Resp_File_Format = GCC_Option_List
then
Add_Arg
(new String'("@" & Get_Name_String (Response_File_Name)));
else
if Response_File_Switches'Length /= 0 then
for J in Response_File_Switches'First ..
Response_File_Switches'Last - 1
loop
Add_Arg (Response_File_Switches (J));
end loop;
Add_Arg
(new String'
(Response_File_Switches
(Response_File_Switches'Last).all &
Get_Name_String (Response_File_Name)));
else
Add_Arg
(new String'(Get_Name_String (Response_File_Name)));
end if;
-- Put back the options
for J in Options'Range loop
Add_Arg (Options (J));
end loop;
end if;
end;
Display_Linking_Command;
end if;
-- Finally spawn the library builder driver
Spawn (Driver.all, Arguments (1 .. Last_Arg), Success);
-- Delete response file, if any, except when asked not to
if Response_File_Name /= No_Path and then Delete_Response_File then
declare
Dont_Care : Boolean;
pragma Warnings (Off, Dont_Care);
begin
Delete_File (Get_Name_String (Response_File_Name), Dont_Care);
if Response_2 /= No_Path then
Delete_File (Get_Name_String (Response_2), Dont_Care);
end if;
end;
end if;
if not Success then
if Driver_Name = No_Name then
Osint.Fail (Gcc_Name & " execution error");
else
Osint.Fail (Get_Name_String (Driver_Name) & " execution error");
end if;
end if;
end Build;
-- Start of processing for Build_Shared_Lib
begin
if Opt.Verbose_Mode then
Write_Str ("building relocatable shared library ");
Write_Line (Lib_File);
end if;
if Library_Version.all = "" or else not Symbolic_Link_Supported then
-- If no Library_Version specified, make sure the table is empty and
-- call Build.
Library_Version_Options.Set_Last (0);
Build (Lib_Path);
else
-- Put the necessary options corresponding to the Library_Version in the
-- table.
if Major_Minor_Id_Supported then
Maj_Version :=
new String'(Major_Id_Name (Lib_File, Library_Version.all));
end if;
if Library_Version_Options.Last > 0 then
if Maj_Version.all /= "" then
Library_Version_Options.Table (Library_Version_Options.Last) :=
new String'
(Library_Version_Options.Table
(Library_Version_Options.Last).all & Maj_Version.all);
else
Library_Version_Options.Table (Library_Version_Options.Last) :=
new String'
(Library_Version_Options.Table
(Library_Version_Options.Last).all &
Library_Version.all);
end if;
end if;
if Is_Absolute_Path (Library_Version.all) then
Library_Version_Path := Library_Version;
else
Library_Version_Path :=
new String'
(Library_Directory.all & Library_Version.all);
end if;
-- Now that the table has been filled, call Build
Build (Library_Version_Path.all);
-- Create symbolic link, if appropriate
if Library_Version.all /= Lib_Path then
Create_Sym_Links
(Lib_Path,
Library_Version.all,
Library_Directory.all,
Maj_Version.all);
end if;
end if;
end Build_Shared_Lib;
gprbuild-gpl-2014-src/src/gprexch.ads 0000644 0000767 0000145 00000010466 12323721731 017062 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R E X C H --
-- --
-- S p e c --
-- --
-- Copyright (C) 2006-2013, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- These package defines sections and the corresponding labels for exchange
-- files between gprmake and gprbind (binding exchange files) and gprlib
-- (library exchange files).
-- All labels start with '[' and end with ']'
package Gprexch is
-- Binding exchange file sections
type Binding_Section is
(No_Binding_Section,
Quiet,
Verbose,
Shared_Libs,
Main_Base_Name,
Mapping_File,
Compiler_Path,
Compiler_Leading_Switches,
Compiler_Trailing_Switches,
Main_Dependency_File,
Dependency_Files,
Binding_Options,
Generated_Object_File,
Bound_Object_Files,
Generated_Source_Files,
Resulting_Options,
Run_Path_Option,
Project_Files,
Toolchain_Version,
Delete_Temp_Files,
Object_File_Suffix,
There_Are_Stand_Alone_Libraries);
function Binding_Label (Section : Binding_Section) return String;
-- Return the label for a section in a binder exchange file
function Get_Binding_Section (Label : String) return Binding_Section;
-- Get the current section from a label in a binding exchange file
-- Library exchange file sections
type Library_Section is
(No_Library_Section,
No_Create,
No_Copy_ALI,
Quiet,
Verbose,
Relocatable,
Static,
Object_Files,
Options,
Object_Directory,
Library_Name,
Library_Directory,
Library_Dependency_Directory,
Library_Version,
Library_Options,
Library_Rpath_Options,
Library_Path,
Library_Version_Options,
Shared_Lib_Prefix,
Shared_Lib_Suffix,
Shared_Lib_Minimum_Options,
Symbolic_Link_Supported,
Major_Minor_Id_Supported,
PIC_Option,
Imported_Libraries,
Runtime_Library_Dir,
Driver_Name,
Compilers,
Compiler_Leading_Switches,
Compiler_Trailing_Switches,
Toolchain_Version,
Archive_Builder,
Archive_Builder_Append_Option,
Archive_Indexer,
Partial_Linker,
Archive_Suffix,
Run_Path_Option,
Separate_Run_Path_Options,
Install_Name,
Auto_Init,
Interface_Dep_Files,
Other_Interfaces,
Standalone_Mode,
Dependency_Files,
Binding_Options,
Leading_Library_Options,
Copy_Source_Dir,
Sources,
Generated_Object_Files,
Generated_Source_Files,
Max_Command_Line_Length,
Response_File_Format,
Response_File_Switches,
Keep_Response_File);
function Library_Label (Section : Library_Section) return String;
-- Return the label for a section in a library exchange file
function Get_Library_Section (Label : String) return Library_Section;
-- Get the current section from a label in a library exchange file
end Gprexch;
gprbuild-gpl-2014-src/src/gpr_util-knowledge.adb 0000644 0000767 0000145 00000005543 12323721731 021203 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R _ U T I L . K N O W L E D G E --
-- --
-- B o d y --
-- --
-- Copyright (C) 2010-2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with GprConfig.Knowledge; use GprConfig.Knowledge;
with GprConfig.Sdefault; use GprConfig.Sdefault;
separate (Gpr_Util)
package body Knowledge is
Base : Knowledge_Base;
-------------------------
-- Normalized_Hostname --
-------------------------
function Normalized_Hostname return String is
Id : Targets_Set_Id;
begin
Get_Targets_Set (Base, Hostname, Id);
return Normalized_Target (Base, Id);
end Normalized_Hostname;
--------------------------
-- Parse_Knowledge_Base --
--------------------------
procedure Parse_Knowledge_Base
(Project_Tree : Project_Tree_Ref;
Directory : String := "")
is
function Dir return String;
-- Returns Directory or if empty Default_Knowledge_Base_Directory
pragma Inline (Dir);
---------
-- Dir --
---------
function Dir return String is
begin
if Directory'Length = 0 then
return Default_Knowledge_Base_Directory;
else
return Directory;
end if;
end Dir;
begin
Parse_Knowledge_Base (Base, Dir, Parse_Compiler_Info => False);
exception
when Invalid_Knowledge_Base =>
Fail_Program
(Project_Tree, "could not parse the XML files in " & Dir);
end Parse_Knowledge_Base;
end Knowledge;
gprbuild-gpl-2014-src/src/gprbuild-post_compile.ads 0000644 0000767 0000145 00000003463 12323721731 021724 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . P O S T _ C O M P I L E --
-- --
-- S p e c --
-- --
-- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
package Gprbuild.Post_Compile is
procedure Run;
-- Build libraries, if needed, and perform binding, if needed.
-- This is either for a specific project tree, or for the root project and
-- all its aggregated projects.
end Gprbuild.Post_Compile;
gprbuild-gpl-2014-src/src/gprbuild-compilation.ads 0000644 0000767 0000145 00000006657 12323721731 021555 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . C O M P I L A T I O N --
-- --
-- S p e c --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- This is the root package for the compilation support. It handles the local
-- and distributed compilation modes.
with Ada.Characters.Latin_1;
private with Ada.Containers.Indefinite_Vectors;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded;
package Gprbuild.Compilation is
Default_Port : constant := 8484;
Opts_Sep : constant Character := Ada.Characters.Latin_1.HT;
-- Command options separator, that is the separator used for options to be
-- passed to the executed command.
-- A simple concurrent counter type
protected type Shared_Counter is
function Count return Natural;
-- Returns the current counter value
procedure Increment;
-- Increment by one
procedure Decrement;
-- Decrement by one
procedure Reset;
-- Reset counter to 0
entry Wait_Non_Zero;
-- Returns when the counter is above zero
private
Counter : Natural := 0;
end Shared_Counter;
procedure Set_Env
(Env : String;
Fail : Boolean;
Force : Boolean := False);
-- Set environemnt given an Env variable containing a set of name=value
-- separated with Opts_Sep.
--
-- name=value[name=value]
--
-- If Fail is true the program will exit if the a format error is detected.
-- If Force is set to True the environement will always be set otherwise it
-- will be set only if not already set.
-- The set of files for a given project (associated with a synchronization
-- job).
type File_Data is record
Path_Name : Ada.Strings.Unbounded.Unbounded_String;
Timestamp : Time_Stamp_Type; -- YYYYMMDDhhmmss
Prev : Time_Stamp_Type;
end record;
package File_Data_Set is new Ada.Containers.Vectors (Positive, File_Data);
private
package Str_Vect is
new Ada.Containers.Indefinite_Vectors (Positive, String);
end Gprbuild.Compilation;
gprbuild-gpl-2014-src/src/gprinstall-install.ads 0000644 0000767 0000145 00000003454 12323721731 021244 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R I N S T A L L . M A I N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Prj;
package Gprinstall.Install is
use Prj;
procedure Process
(Tree : Project_Tree_Ref;
Project : Project_Id);
-- Install Project and possibly all imported projects depending on the
-- options.
end Gprinstall.Install;
gprbuild-gpl-2014-src/src/gprbind.adb 0000644 0000767 0000145 00000137225 12323721731 017031 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B I N D --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- gprbind is the executable called by gprmake to bind Ada sources. It is
-- the driver for gnatbind. It gets its input from gprmake through the
-- binding exchange file and gives back its results through the same file.
with Ada.Directories;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Command_Line; use Ada.Command_Line;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with ALI; use ALI;
with Gprexch; use Gprexch;
with Gpr_Util; use Gpr_Util;
with Hostparm;
with Makeutl; use Makeutl;
with Namet; use Namet;
with Osint;
with Switch;
with Tempdir;
with Table;
with Types;
procedure Gprbind is
Shared_Libgcc_Default : Character;
for Shared_Libgcc_Default'Size use Character'Size;
pragma Import
(C, Shared_Libgcc_Default, "__gnat_shared_libgcc_default");
Preserve : Attribute := Time_Stamps;
-- Used in calls to Copy_File. Changed to None for OpenVMS, because
-- Copy_Attributes always fails on VMS.
Executable_Suffix : constant String_Access := Get_Executable_Suffix;
-- The suffix of executables on this platforms
GNATBIND : String_Access := new String'("gnatbind");
-- The file name of the gnatbind executable. May be modified by an option
-- in the Minimum_Binder_Options.
Gnatbind_Prefix_Equal : constant String := "gnatbind_prefix=";
-- Start of the option to specify a prefix for the gnatbind executable
Gnatbind_Path_Equal : constant String := "--gnatbind_path=";
-- Start of the option to specify the absolute path of gnatbind
Ada_Binder_Equal : constant String := "ada_binder=";
-- Start of the option to specify the full name of the Ada binder
-- executable. Introduced for GNAAMP, where it is gnaambind.
Quiet_Output : Boolean := False;
Verbose_Mode : Boolean := False;
Dash_O_Specified : Boolean := False;
Dash_O_File_Specified : Boolean := False;
There_Are_Stand_Alone_Libraries : Boolean := False;
-- Set to True if the corresponding label is in the exchange file
No_Main_Option : constant String := "-n";
Dash_o : constant String := "-o";
Dash_shared : constant String := "-shared";
Dash_x : constant String := "-x";
Dash_Fequal : constant String := "-F=";
Dash_OO : constant String := "-O";
-- Minimum switches to be used to compile the binder generated file
Dash_c : constant String := "-c";
Dash_gnatA : constant String := "-gnatA";
Dash_gnatWb : constant String := "-gnatWb";
Dash_gnatiw : constant String := "-gnatiw";
Dash_gnatws : constant String := "-gnatws";
GCC_Version : Character := '0';
Gcc_Version_String : constant String := "gcc version ";
Shared_Libgcc : constant String := "-shared-libgcc";
Static_Libgcc : constant String := "-static-libgcc";
IO_File : File_Type;
-- The file to get the inputs and to put the results of the binding
Line : String (1 .. 1_000);
Last : Natural;
Exchange_File_Name : String_Access;
Ada_Compiler_Path : String_Access;
FULL_GNATBIND : String_Access;
Gnatbind_Path : String_Access;
Gnatbind_Path_Specified : Boolean := False;
Compiler_Options : String_List_Access := new String_List (1 .. 100);
Last_Compiler_Option : Natural := 0;
Compiler_Trailing_Options : String_List_Access := new String_List (1 .. 10);
Last_Compiler_Trailing_Option : Natural := 0;
Gnatbind_Options : String_List_Access := new String_List (1 .. 100);
Last_Gnatbind_Option : Natural := 0;
Main_ALI : String_Access := null;
Main_Base_Name : String_Access := null;
Binder_Generated_File : String_Access := null;
BG_File : File_Type;
Mapping_File : String_Access := null;
Success : Boolean := False;
Return_Code : Integer;
Adalib_Dir : String_Access;
Prefix_Path : String_Access;
Lib_Path : String_Access;
Static_Libs : Boolean := True;
Current_Section : Binding_Section := No_Binding_Section;
All_Binding_Options : Boolean;
Get_Option : Boolean;
Xlinker_Seen : Boolean;
Stack_Equal_Seen : Boolean;
GNAT_Version : String_Access := new String'("000");
-- The version of GNAT, coming from the Toolchain_Version for Ada
GNAT_Version_Set : Boolean := False;
-- True when the toolchain version is in the input exchange file
Delete_Temp_Files : Boolean := True;
FD_Objects : File_Descriptor;
Objects_Path : Path_Name_Type;
Objects_File : File_Type;
Ada_Object_Suffix : String_Access := Get_Object_Suffix;
Display_Line : String_Access := new String (1 .. 1_000);
Display_Last : Natural := 0;
-- A String buffer to store temporarily the displayed gnatbind command
-- invoked by gprbind.
procedure Add_To_Display_Line (S : String);
-- Add an argument to the Display_Line
package Binding_Options_Table is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Gprbind.Binding_Options_Table");
Binding_Option_Dash_V_Specified : Boolean := False;
-- Set to True if -v is specified in the binding options
GNAT_6_Or_Higher : Boolean := False;
-- Set to True when GNAT version is neither 3.xx nor 5.xx
GNAT_6_4_Or_Higher : Boolean := False;
-- Set to True when GNAT_6_Or_Higher is True and if GNAT version is 6.xy
-- with x >= 4.
package ALI_Files_Table is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Gprbind.ALI_File_Table");
type Path_And_Stamp is record
Path : String_Access;
Stamp : String_Access;
end record;
package Project_Paths is new Table.Table
(Table_Component_Type => Path_And_Stamp,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Gprbind.Project_Paths");
type Bound_File;
type Bound_File_Access is access Bound_File;
type Bound_File is record
Name : String_Access;
Next : Bound_File_Access;
end record;
Bound_Files : Bound_File_Access;
-------------------------
-- Add_To_Display_Line --
-------------------------
procedure Add_To_Display_Line (S : String) is
begin
while Display_Last + 1 + S'Length > Display_Line'Last loop
declare
New_Buffer : constant String_Access :=
new String (1 .. 2 * Display_Line'Length);
begin
New_Buffer (1 .. Display_Last) :=
Display_Line (1 .. Display_Last);
Free (Display_Line);
Display_Line := New_Buffer;
end;
end loop;
if Display_Last > 0 then
Display_Last := Display_Last + 1;
Display_Line (Display_Last) := ' ';
end if;
Display_Line (Display_Last + 1 .. Display_Last + S'Length) := S;
Display_Last := Display_Last + S'Length;
end Add_To_Display_Line;
begin
if Argument_Count /= 1 then
Osint.Fail ("incorrect invocation");
end if;
Namet.Initialize;
-- Copy_Attributes always fails on VMS
if Hostparm.OpenVMS then
Preserve := None;
end if;
Exchange_File_Name := new String'(Argument (1));
-- DEBUG: save a copy of the exchange file
declare
Gprbind_Debug : constant String := Getenv ("GPRBIND_DEBUG").all;
begin
if Gprbind_Debug = "TRUE" then
Copy_File
(Exchange_File_Name.all,
Exchange_File_Name.all & "__saved",
Success,
Mode => Overwrite,
Preserve => Preserve);
end if;
end;
-- Open the binding exchange file
begin
Open (IO_File, In_File, Exchange_File_Name.all);
exception
when others =>
Osint.Fail ("could not read " & Exchange_File_Name.all);
end;
-- Get the information from the binding exchange file
while not End_Of_File (IO_File) loop
Get_Line (IO_File, Line, Last);
if Last > 0 then
if Line (1) = '[' then
Current_Section := Get_Binding_Section (Line (1 .. Last));
case Current_Section is
when No_Binding_Section =>
Osint.Fail ("unknown section: " & Line (1 .. Last));
when Quiet =>
Quiet_Output := True;
Verbose_Mode := False;
when Verbose =>
Quiet_Output := False;
Verbose_Mode := True;
when Shared_Libs =>
Static_Libs := False;
when Gprexch.There_Are_Stand_Alone_Libraries =>
There_Are_Stand_Alone_Libraries := True;
when others =>
null;
end case;
else
case Current_Section is
when No_Binding_Section =>
Osint.Fail ("no section specified: " & Line (1 .. Last));
when Quiet =>
Osint.Fail ("quiet section should be empty");
when Verbose =>
Osint.Fail ("verbose section should be empty");
when Shared_Libs =>
Osint.Fail ("shared libs section should be empty");
when Gprexch.There_Are_Stand_Alone_Libraries =>
Osint.Fail ("stand-alone libraries section should be empty");
when Gprexch.Main_Base_Name =>
if Main_Base_Name /= null then
Osint.Fail
("main base name specified multiple times");
end if;
Main_Base_Name := new String'(Line (1 .. Last));
when Gprexch.Mapping_File =>
Mapping_File := new String'(Line (1 .. Last));
when Compiler_Path =>
if Ada_Compiler_Path /= null then
Osint.Fail
("compiler path specified multiple times");
end if;
Ada_Compiler_Path := new String'(Line (1 .. Last));
when Compiler_Leading_Switches =>
Add
(Line (1 .. Last),
Compiler_Options, Last_Compiler_Option);
when Compiler_Trailing_Switches =>
Add
(Line (1 .. Last),
Compiler_Trailing_Options, Last_Compiler_Trailing_Option);
when Main_Dependency_File =>
if Main_ALI /= null then
Osint.Fail ("main ALI file specified multiple times");
end if;
Main_ALI := new String'(Line (1 .. Last));
when Dependency_Files =>
ALI_Files_Table.Append (new String'(Line (1 .. Last)));
when Binding_Options =>
-- Check if a gnatbind absolute is specified
if Last > Gnatbind_Path_Equal'Length
and then Line (1 .. Gnatbind_Path_Equal'Length) =
Gnatbind_Path_Equal
then
Gnatbind_Path := new String'
(Line (Gnatbind_Path_Equal'Length + 1 .. Last));
Gnatbind_Path_Specified := True;
-- Check if a gnatbind prefix is specified
elsif Last >= Gnatbind_Prefix_Equal'Length
and then Line (1 .. Gnatbind_Prefix_Equal'Length) =
Gnatbind_Prefix_Equal
then
-- Ignore an empty prefix
if Last > Gnatbind_Prefix_Equal'Length then
-- There is always a '-' between and
-- "gnatbind". Add one if not already in .
if Line (Last) /= '-' then
Last := Last + 1;
Line (Last) := '-';
end if;
GNATBIND := new String'
(Line (Gnatbind_Prefix_Equal'Length + 1 .. Last) &
"gnatbind");
end if;
elsif Last > Ada_Binder_Equal'Length
and then Line (1 .. Ada_Binder_Equal'Length) =
Ada_Binder_Equal
then
GNATBIND := new String'
(Line (Ada_Binder_Equal'Length + 1 .. Last));
-- When -O is used, instead of -O=file, -v is ignored to
-- avoid polluting the output. Record occurence of -v and
-- check the GNAT version later.
elsif Line (1 .. Last) = "-v" then
Binding_Option_Dash_V_Specified := True;
-- Ignore -C, as the generated sources are always in Ada
elsif Line (1 .. Last) /= "-C" then
Binding_Options_Table.Append
(new String'(Line (1 .. Last)));
end if;
when Project_Files =>
if End_Of_File (IO_File) then
Osint.Fail ("no time stamp for " & Line (1 .. Last));
else
declare
PS : Path_And_Stamp;
begin
PS.Path := new String'(Line (1 .. Last));
Get_Line (IO_File, Line, Last);
PS.Stamp := new String'(Line (1 .. Last));
Project_Paths.Append (PS);
end;
end if;
when Gprexch.Toolchain_Version =>
if End_Of_File (IO_File) then
Osint.Fail
("no toolchain version for language " &
Line (1 .. Last));
elsif Line (1 .. Last) = "ada" then
Get_Line (IO_File, Line, Last);
if Last > 5 and then Line (1 .. 5) = "GNAT " then
GNAT_Version := new String'(Line (6 .. Last));
GNAT_Version_Set := True;
end if;
else
Skip_Line (IO_File);
end if;
when Gprexch.Delete_Temp_Files =>
begin
Delete_Temp_Files := Boolean'Value (Line (1 .. Last));
exception
when Constraint_Error =>
null;
end;
when Gprexch.Object_File_Suffix =>
if End_Of_File (IO_File) then
Osint.Fail
("no object file suffix for language " &
Line (1 .. Last));
elsif Line (1 .. Last) = "ada" then
Get_Line (IO_File, Line, Last);
Ada_Object_Suffix := new String'(Line (1 .. Last));
else
Skip_Line (IO_File);
end if;
when Generated_Object_File |
Generated_Source_Files |
Bound_Object_Files |
Resulting_Options |
Run_Path_Option =>
null;
end case;
end if;
end if;
end loop;
if Main_Base_Name = null then
Osint.Fail ("no main base name specified");
else
Binder_Generated_File :=
new String'("b__" & Main_Base_Name.all & ".adb");
end if;
Close (IO_File);
-- Modify binding option -A= if is not an absolute path
if Project_Paths.Last >= 1 then
declare
Project_Dir : constant String :=
Ada.Directories.Containing_Directory
(Project_Paths.Table (1).Path.all);
begin
for J in 1 .. Binding_Options_Table.Last loop
if Binding_Options_Table.Table (J)'Length >= 4 and then
Binding_Options_Table.Table (J) (1 .. 3) = "-A="
then
declare
File : constant String :=
Binding_Options_Table.Table (J)
(4 .. Binding_Options_Table.Table (J)'Length);
begin
if not Is_Absolute_Path (File) then
declare
New_File : constant String :=
Normalize_Pathname (File, Project_Dir);
begin
Binding_Options_Table.Table (J) :=
new String'("-A=" & New_File);
end;
end if;
end;
end if;
end loop;
end;
end if;
-- Check if GNAT version is 6.4 or higher
if GNAT_Version_Set
and then
GNAT_Version'Length > 2
and then
GNAT_Version.all /= "000"
and then
GNAT_Version (GNAT_Version'First .. GNAT_Version'First + 1) /= "3."
and then
GNAT_Version (GNAT_Version'First .. GNAT_Version'First + 1) /= "5."
then
GNAT_6_Or_Higher := True;
if GNAT_Version (GNAT_Version'First .. GNAT_Version'First + 1) /= "6."
or else
GNAT_Version.all >= "6.4"
then
GNAT_6_4_Or_Higher := True;
end if;
end if;
-- Check if binding option -v was specified and issue it only if the GNAT
-- version is 6.4 or higher, otherwise the output of gnatbind -O will be
-- polluted.
if Binding_Option_Dash_V_Specified and then GNAT_6_4_Or_Higher then
Binding_Options_Table.Append (new String'("-v"));
end if;
if not Static_Libs then
Add (Dash_shared, Gnatbind_Options, Last_Gnatbind_Option);
end if;
-- Specify the name of the generated file to gnatbind
Add (Dash_o, Gnatbind_Options, Last_Gnatbind_Option);
Add
(Binder_Generated_File.all,
Gnatbind_Options,
Last_Gnatbind_Option);
if not Is_Regular_File (Ada_Compiler_Path.all) then
Osint.Fail ("could not find the Ada compiler");
end if;
if Main_ALI /= null then
Add (Main_ALI.all, Gnatbind_Options, Last_Gnatbind_Option);
end if;
-- If there are Stand-Alone Libraries, invoke gnatbind with -F (generate
-- checks of elaboration flags) to avoid multiple elaborations.
if There_Are_Stand_Alone_Libraries
and then GNAT_Version_Set
and then GNAT_Version'Length > 2
and then GNAT_Version (GNAT_Version'First .. GNAT_Version'First + 1) /=
"3."
then
Add ("-F", Gnatbind_Options, Last_Gnatbind_Option);
end if;
for J in 1 .. ALI_Files_Table.Last loop
Add (ALI_Files_Table.Table (J), Gnatbind_Options, Last_Gnatbind_Option);
end loop;
for J in 1 .. Binding_Options_Table.Last loop
Add
(Binding_Options_Table.Table (J),
Gnatbind_Options,
Last_Gnatbind_Option);
if Binding_Options_Table.Table (J).all = Dash_OO then
Dash_O_Specified := True;
elsif Binding_Options_Table.Table (J)'Length >= 4 and then
Binding_Options_Table.Table (J) (1 .. 3) = Dash_OO & '='
then
Dash_O_Specified := True;
Dash_O_File_Specified := True;
Name_Len := 0;
Add_Str_To_Name_Buffer
(Binding_Options_Table.Table (J)
(4 .. Binding_Options_Table.Table (J)'Last));
Objects_Path := Name_Find;
end if;
end loop;
-- Add -x at the end, so that if -s is specified in the binding options,
-- gnatbind does not try to look for sources, as the binder mapping file
-- specified by -F- is not for sources, but for ALI files.
Add (Dash_x, Gnatbind_Options, Last_Gnatbind_Option);
if Ada_Compiler_Path = null or else
Is_Absolute_Path (GNATBIND.all)
then
FULL_GNATBIND := GNATBIND;
else
FULL_GNATBIND :=
new String'
(Dir_Name (Ada_Compiler_Path.all) &
Directory_Separator &
GNATBIND.all);
end if;
if Gnatbind_Path_Specified then
FULL_GNATBIND := Gnatbind_Path;
end if;
Gnatbind_Path := Locate_Exec_On_Path (FULL_GNATBIND.all);
-- If gnatbind is not found and its full path was not specified, check for
-- gnatbind on the path.
if Gnatbind_Path = null and then not Gnatbind_Path_Specified then
Gnatbind_Path := Locate_Exec_On_Path (GNATBIND.all);
end if;
if Gnatbind_Path = null then
-- Make sure Namelen has a non negative value
Name_Len := 0;
if Gnatbind_Path_Specified then
Osint.Fail ("could not locate " & FULL_GNATBIND.all);
else
Osint.Fail ("could not locate " & GNATBIND.all);
end if;
else
-- Normalize the path, so that gnaampbind does not complain about not
-- being in a "bin" directory. But don't resolve symbolic links,
-- because in GNAT 5.01a1 and previous releases, gnatbind was a symbolic
-- link for .gnat_wrapper.
Gnatbind_Path :=
new String'
(Normalize_Pathname (Gnatbind_Path.all, Resolve_Links => False));
end if;
if Main_ALI = null then
Add (No_Main_Option, Gnatbind_Options, Last_Gnatbind_Option);
end if;
-- Add the switch -F= if the mapping file was specified
-- and the version of GNAT is recent enough.
if Mapping_File /= null
and then GNAT_Version_Set
and then GNAT_Version'Length > 2
and then GNAT_Version (GNAT_Version'First .. GNAT_Version'First + 1) /=
"3."
then
Add (Dash_Fequal & Mapping_File.all,
Gnatbind_Options,
Last_Gnatbind_Option);
end if;
-- Create temporary file to get the list of objects
if not Dash_O_File_Specified then
Tempdir.Create_Temp_File (FD_Objects, Objects_Path);
end if;
if GNAT_6_4_Or_Higher then
if not Dash_O_File_Specified then
Add
(Dash_OO & "=" & Get_Name_String (Objects_Path),
Gnatbind_Options,
Last_Gnatbind_Option);
Close (FD_Objects);
end if;
elsif not Dash_O_Specified then
Add (Dash_OO, Gnatbind_Options, Last_Gnatbind_Option);
end if;
if not Quiet_Output then
Display_Last := 0;
if Verbose_Mode then
Add_To_Display_Line (Gnatbind_Path.all);
else
Add_To_Display_Line (Base_Name (GNATBIND.all));
end if;
if Verbose_Mode then
for Option in 1 .. Last_Gnatbind_Option loop
Add_To_Display_Line (Gnatbind_Options (Option).all);
end loop;
else
if Main_ALI /= null then
Add_To_Display_Line (Base_Name (Main_ALI.all));
if ALI_Files_Table.Last > 0 then
Add_To_Display_Line ("...");
end if;
elsif ALI_Files_Table.Last > 0 then
Add_To_Display_Line (Base_Name (ALI_Files_Table.Table (1).all));
if ALI_Files_Table.Last > 1 then
Add_To_Display_Line ("...");
end if;
Add_To_Display_Line (No_Main_Option);
end if;
end if;
Put_Line (Display_Line (1 .. Display_Last));
end if;
declare
Size : Natural := 0;
begin
for J in 1 .. Last_Gnatbind_Option loop
Size := Size + Gnatbind_Options (J)'Length + 1;
end loop;
-- Invoke gnatbind with the arguments if the size is not too large or
-- if the version of GNAT is not recent enough.
if not GNAT_6_Or_Higher or else Size <= Maximum_Size then
if not GNAT_6_4_Or_Higher then
Spawn
(Gnatbind_Path.all,
Gnatbind_Options (1 .. Last_Gnatbind_Option),
FD_Objects,
Return_Code,
Err_To_Out => False);
Success := Return_Code = 0;
else
Return_Code :=
Spawn
(Gnatbind_Path.all,
Gnatbind_Options (1 .. Last_Gnatbind_Option));
end if;
else
-- Otherwise create a temporary response file
declare
FD : File_Descriptor;
Path : Path_Name_Type;
Args : Argument_List (1 .. 1);
EOL : constant String (1 .. 1) := (1 => ASCII.LF);
Status : Integer;
Quotes_Needed : Boolean;
Last_Char : Natural;
Ch : Character;
begin
Tempdir.Create_Temp_File (FD, Path);
Args (1) := new String'("@" & Get_Name_String (Path));
for J in 1 .. Last_Gnatbind_Option loop
-- Check if the argument should be quoted
Quotes_Needed := False;
Last_Char := Gnatbind_Options (J)'Length;
for K in Gnatbind_Options (J)'Range loop
Ch := Gnatbind_Options (J) (K);
if Ch = ' ' or else Ch = ASCII.HT or else Ch = '"' then
Quotes_Needed := True;
exit;
end if;
end loop;
if Quotes_Needed then
-- Quote the argument, doubling '"'
declare
Arg : String (1 .. Gnatbind_Options (J)'Length * 2 + 2);
begin
Arg (1) := '"';
Last_Char := 1;
for K in Gnatbind_Options (J)'Range loop
Ch := Gnatbind_Options (J) (K);
Last_Char := Last_Char + 1;
Arg (Last_Char) := Ch;
if Ch = '"' then
Last_Char := Last_Char + 1;
Arg (Last_Char) := '"';
end if;
end loop;
Last_Char := Last_Char + 1;
Arg (Last_Char) := '"';
Status := Write (FD, Arg'Address, Last_Char);
end;
else
Status := Write
(FD,
Gnatbind_Options (J) (Gnatbind_Options (J)'First)'Address,
Last_Char);
end if;
if Status /= Last_Char then
Osint.Fail ("disk full");
end if;
Status := Write (FD, EOL (1)'Address, 1);
if Status /= 1 then
Osint.Fail ("disk full");
end if;
end loop;
Close (FD);
-- And invoke gnatbind with this this response file
if not GNAT_6_4_Or_Higher then
Spawn
(Gnatbind_Path.all,
Args,
FD_Objects,
Return_Code,
Err_To_Out => False);
else
Return_Code := Spawn (Gnatbind_Path.all, Args);
end if;
if Delete_Temp_Files then
declare
Succ : Boolean;
pragma Warnings (Off, Succ);
begin
Delete_File (Get_Name_String (Path), Succ);
end;
end if;
end;
end if;
end;
if not GNAT_6_4_Or_Higher and then not Dash_O_File_Specified then
Close (FD_Objects);
end if;
if Return_Code /= 0 then
if Delete_Temp_Files and not Dash_O_File_Specified then
Delete_File (Get_Name_String (Objects_Path), Success);
end if;
Osint.Fail ("invocation of gnatbind failed");
end if;
Add (Dash_c, Compiler_Options, Last_Compiler_Option);
Add (Dash_gnatA, Compiler_Options, Last_Compiler_Option);
Add (Dash_gnatWb, Compiler_Options, Last_Compiler_Option);
Add (Dash_gnatiw, Compiler_Options, Last_Compiler_Option);
Add (Dash_gnatws, Compiler_Options, Last_Compiler_Option);
-- Read the ALI file of the first ALI file. Fetch the back end switches
-- from this ALI file and use these switches to compile the binder
-- generated file.
if Main_ALI /= null or else ALI_Files_Table.Last >= 1 then
Initialize_ALI;
Name_Len := 0;
if Main_ALI /= null then
Add_Str_To_Name_Buffer (Main_ALI.all);
else
Add_Str_To_Name_Buffer (ALI_Files_Table.Table (1).all);
end if;
declare
use Types;
F : constant File_Name_Type := Name_Find;
T : Text_Buffer_Ptr;
A : ALI_Id;
begin
-- Load the ALI file
T := Osint.Read_Library_Info (F, True);
-- Read it. Note that we ignore errors, since we only want very
-- limited information from the ali file, and likely a slightly
-- wrong version will be just fine, though in normal operation
-- we don't expect this to happen.
A := Scan_ALI
(F,
T,
Ignore_ED => False,
Err => False,
Ignore_Errors => True,
Read_Lines => "A");
if A /= No_ALI_Id then
for
Index in Units.Table (ALIs.Table (A).First_Unit).First_Arg ..
Units.Table (ALIs.Table (A).First_Unit).Last_Arg
loop
-- Do not compile with the front end switches. However, --RTS
-- is to be dealt with specially because the binder-generated
-- file need to compiled with the same switch.
declare
Arg : String_Ptr renames Args.Table (Index);
begin
if (not Switch.Is_Front_End_Switch (Arg.all))
or else
(Arg'Length > 5
and then
Arg (Arg'First + 2 .. Arg'First + 5) = "RTS=")
then
Add
(String_Access (Arg),
Compiler_Options,
Last_Compiler_Option);
end if;
end;
end loop;
end if;
end;
end if;
Add (Binder_Generated_File, Compiler_Options, Last_Compiler_Option);
declare
Object : constant String :=
"b__" & Main_Base_Name.all & Ada_Object_Suffix.all;
begin
Add
(Dash_o,
Compiler_Options,
Last_Compiler_Option);
Add
(Object,
Compiler_Options,
Last_Compiler_Option);
if not Quiet_Output then
Name_Len := 0;
if Verbose_Mode then
Add_Str_To_Name_Buffer (Ada_Compiler_Path.all);
else
Add_Str_To_Name_Buffer (Base_Name (Ada_Compiler_Path.all));
end if;
-- Remove the executable suffix, if present
if Executable_Suffix'Length > 0
and then
Name_Len > Executable_Suffix'Length
and then
Name_Buffer
(Name_Len - Executable_Suffix'Length + 1 .. Name_Len) =
Executable_Suffix.all
then
Name_Len := Name_Len - Executable_Suffix'Length;
end if;
Display_Last := 0;
Add_To_Display_Line (Name_Buffer (1 .. Name_Len));
if Verbose_Mode then
for Option in 1 .. Last_Compiler_Option loop
Add_To_Display_Line (Compiler_Options (Option).all);
end loop;
else
Add_To_Display_Line (Compiler_Options (1).all);
if Compiler_Options (1) /= Binder_Generated_File then
Add_To_Display_Line (Binder_Generated_File.all);
end if;
end if;
Put_Line (Display_Line (1 .. Display_Last));
end if;
-- Add the trailing options, if any
for J in 1 .. Last_Compiler_Trailing_Option loop
Add
(Compiler_Trailing_Options (J),
Compiler_Options,
Last_Compiler_Option);
end loop;
Spawn
(Ada_Compiler_Path.all,
Compiler_Options (1 .. Last_Compiler_Option),
Success);
if not Success then
Osint.Fail ("compilation of binder generated file failed");
end if;
-- Find the GCC version
Spawn
(Program_Name => Ada_Compiler_Path.all,
Args => (1 => new String'("-v")),
Output_File => Exchange_File_Name.all,
Success => Success,
Return_Code => Return_Code,
Err_To_Out => True);
if Success then
Open (IO_File, In_File, Exchange_File_Name.all);
while not End_Of_File (IO_File) loop
Get_Line (IO_File, Line, Last);
if Last > Gcc_Version_String'Length and then
Line (1 .. Gcc_Version_String'Length) = Gcc_Version_String
then
GCC_Version := Line (Gcc_Version_String'Length + 1);
exit;
end if;
end loop;
Close (IO_File);
end if;
Create (IO_File, Out_File, Exchange_File_Name.all);
-- First, the generated object file
Put_Line (IO_File, Binding_Label (Generated_Object_File));
Put_Line (IO_File, Object);
-- Repeat the project paths with their time stamps
Put_Line (IO_File, Binding_Label (Project_Files));
for J in 1 .. Project_Paths.Last loop
Put_Line (IO_File, Project_Paths.Table (J).Path.all);
Put_Line (IO_File, Project_Paths.Table (J).Stamp.all);
end loop;
-- Get the bound object files from the Object file
Open (Objects_File, In_File, Get_Name_String (Objects_Path));
Put_Line (IO_File, Binding_Label (Bound_Object_Files));
while not End_Of_File (Objects_File) loop
Get_Line (Objects_File, Line, Last);
-- Only put in the exchange file the path of the object files.
-- Output anything else on standard output.
if Is_Regular_File (Line (1 .. Last)) then
Put_Line (IO_File, Line (1 .. Last));
Bound_Files := new Bound_File'
(Name => new String'(Line (1 .. Last)), Next => Bound_Files);
if Dash_O_Specified and then not Dash_O_File_Specified then
Put_Line (Line (1 .. Last));
end if;
elsif not Dash_O_File_Specified then
Put_Line (Line (1 .. Last));
end if;
end loop;
Close (Objects_File);
if Delete_Temp_Files and then not Dash_O_File_Specified then
Delete_File (Get_Name_String (Objects_Path), Success);
end if;
-- For the benefit of gprclean, the generated files other than the
-- generated object file.
Put_Line (IO_File, Binding_Label (Generated_Source_Files));
Put_Line (IO_File, "b__" & Main_Base_Name.all & ".ads");
Put_Line (IO_File, Binder_Generated_File.all);
Put_Line (IO_File, "b__" & Main_Base_Name.all & ".ali");
-- Get the options from the binder generated file
Open (BG_File, In_File, Binder_Generated_File.all);
while not End_Of_File (BG_File) loop
Get_Line (BG_File, Line, Last);
exit when Line (1 .. Last) = Begin_Info;
end loop;
if not End_Of_File (BG_File) then
Put_Line (IO_File, Binding_Label (Resulting_Options));
All_Binding_Options := False;
Xlinker_Seen := False;
Stack_Equal_Seen := False;
loop
Get_Line (BG_File, Line, Last);
exit when Line (1 .. Last) = End_Info;
Line (1 .. Last - 8) := Line (9 .. Last);
Last := Last - 8;
if Line (1) = '-' then
-- After the first switch, we take all options, because some
-- of the options specified in pragma Linker_Options may not
-- start with '-'.
All_Binding_Options := True;
end if;
Get_Option :=
All_Binding_Options
or else
(Base_Name (Line (1 .. Last)) = "g-trasym.o")
or else
(Base_Name (Line (1 .. Last)) = "g-trasym.obj");
-- g-trasym is a special case as it is not included in libgnat
-- Avoid duplication of object file
if Get_Option then
declare
BF : Bound_File_Access := Bound_Files;
begin
while BF /= null loop
if BF.Name.all = Line (1 .. Last) then
Get_Option := False;
exit;
else
BF := BF.Next;
end if;
end loop;
end;
end if;
if Get_Option then
if Line (1 .. Last) = "-Xlinker" then
Xlinker_Seen := True;
elsif Xlinker_Seen then
Xlinker_Seen := False;
-- Make sure that only the first switch --stack= is put in
-- the exchange file.
if Last > 8 and then Line (1 .. 8) = "--stack=" then
if not Stack_Equal_Seen then
Stack_Equal_Seen := True;
Put_Line (IO_File, "-Xlinker");
Put_Line (IO_File, Line (1 .. Last));
end if;
else
Put_Line (IO_File, "-Xlinker");
Put_Line (IO_File, Line (1 .. Last));
end if;
elsif Last > 12 and then Line (1 .. 12) = "-Wl,--stack=" then
if not Stack_Equal_Seen then
Stack_Equal_Seen := True;
Put_Line (IO_File, Line (1 .. Last));
end if;
elsif Last >= 3 and then Line (1 .. 2) = "-L" then
-- Set Adalib_Dir only if libgnat is found inside.
if Is_Regular_File
(Line (3 .. Last) & Directory_Separator & "libgnat.a")
then
Adalib_Dir := new String'(Line (3 .. Last));
if Verbose_Mode then
Put_Line ("Adalib_Dir = """ & Adalib_Dir.all & '"');
end if;
-- Build the Prefix_Path, where to look for some
-- archives: libaddr2line.a, libbfd.a, libgnatmon.a,
-- libgnalasup.a and libiberty.a. It contains three
-- directories: $(adalib)/.., $(adalib)/../.. and the
-- subdirectory "lib" ancestor of $(adalib).
declare
Dir_Last : Positive;
Prev_Dir_Last : Positive;
First : Positive;
Prev_Dir_First : Positive;
Nmb : Natural;
begin
Name_Len := 0;
Add_Str_To_Name_Buffer (Line (3 .. Last));
while Name_Buffer (Name_Len) = Directory_Separator
or else Name_Buffer (Name_Len) = '/'
loop
Name_Len := Name_Len - 1;
end loop;
while Name_Buffer (Name_Len) /= Directory_Separator
and then Name_Buffer (Name_Len) /= '/'
loop
Name_Len := Name_Len - 1;
end loop;
while Name_Buffer (Name_Len) = Directory_Separator
or else Name_Buffer (Name_Len) = '/'
loop
Name_Len := Name_Len - 1;
end loop;
Dir_Last := Name_Len;
Nmb := 0;
Dir_Loop : loop
Prev_Dir_Last := Dir_Last;
First := Dir_Last - 1;
while First > 3
and then
Name_Buffer (First) /= Directory_Separator
and then
Name_Buffer (First) /= '/'
loop
First := First - 1;
end loop;
Prev_Dir_First := First + 1;
exit Dir_Loop when First <= 3;
Dir_Last := First - 1;
while Name_Buffer (Dir_Last) = Directory_Separator
or else Name_Buffer (Dir_Last) = '/'
loop
Dir_Last := Dir_Last - 1;
end loop;
Nmb := Nmb + 1;
if Nmb <= 1 then
Add_Char_To_Name_Buffer (Path_Separator);
Add_Str_To_Name_Buffer
(Name_Buffer (1 .. Dir_Last));
elsif Name_Buffer (Prev_Dir_First .. Prev_Dir_Last)
= "lib"
then
Add_Char_To_Name_Buffer (Path_Separator);
Add_Str_To_Name_Buffer
(Name_Buffer (1 .. Prev_Dir_Last));
exit Dir_Loop;
end if;
end loop Dir_Loop;
Prefix_Path :=
new String'(Name_Buffer (1 .. Name_Len));
if Verbose_Mode then
Put_Line
("Prefix_Path = """ & Prefix_Path.all & '"');
end if;
end;
end if;
Put_Line (IO_File, Line (1 .. Last));
elsif Line (1 .. Last) = "-static" then
Static_Libs := True;
Put_Line (IO_File, Line (1 .. Last));
if Shared_Libgcc_Default = 'T'
and then GCC_Version >= '3'
then
Put_Line (IO_File, Static_Libgcc);
end if;
elsif Line (1 .. Last) = "-shared" then
Static_Libs := False;
Put_Line (IO_File, Line (1 .. Last));
if GCC_Version >= '3' then
Put_Line (IO_File, Shared_Libgcc);
end if;
-- For a number of archives, we need to indicate the full
-- path of the archive, if we find it, to be sure that the
-- correct archive is used by the linker.
elsif Line (1 .. Last) = "-lgnat" then
if Adalib_Dir = null then
if Verbose_Mode then
Put_Line ("No Adalib_Dir");
end if;
Put_Line (IO_File, "-lgnat");
elsif Static_Libs then
Put_Line (IO_File, Adalib_Dir.all & "libgnat.a");
else
Put_Line (IO_File, "-lgnat");
end if;
elsif Line (1 .. Last) = "-lgnarl" and then
Static_Libs and then
Adalib_Dir /= null
then
Put_Line (IO_File, Adalib_Dir.all & "libgnarl.a");
elsif Line (1 .. Last) = "-laddr2line"
and then Prefix_Path /= null
then
Lib_Path := Locate_Regular_File
("libaddr2line.a", Prefix_Path.all);
if Lib_Path /= null then
Put_Line (IO_File, Lib_Path.all);
Free (Lib_Path);
else
Put_Line (IO_File, Line (1 .. Last));
end if;
elsif Line (1 .. Last) = "-lbfd"
and then Prefix_Path /= null
then
Lib_Path := Locate_Regular_File
("libbfd.a", Prefix_Path.all);
if Lib_Path /= null then
Put_Line (IO_File, Lib_Path.all);
Free (Lib_Path);
else
Put_Line (IO_File, Line (1 .. Last));
end if;
elsif Line (1 .. Last) = "-lgnalasup"
and then Prefix_Path /= null
then
Lib_Path := Locate_Regular_File
("libgnalasup.a", Prefix_Path.all);
if Lib_Path /= null then
Put_Line (IO_File, Lib_Path.all);
Free (Lib_Path);
else
Put_Line (IO_File, Line (1 .. Last));
end if;
elsif Line (1 .. Last) = "-lgnatmon"
and then Prefix_Path /= null
then
Lib_Path := Locate_Regular_File
("libgnatmon.a", Prefix_Path.all);
if Lib_Path /= null then
Put_Line (IO_File, Lib_Path.all);
Free (Lib_Path);
else
Put_Line (IO_File, Line (1 .. Last));
end if;
elsif Line (1 .. Last) = "-liberty"
and then Prefix_Path /= null
then
Lib_Path := Locate_Regular_File
("libiberty.a", Prefix_Path.all);
if Lib_Path /= null then
Put_Line (IO_File, Lib_Path.all);
Free (Lib_Path);
else
Put_Line (IO_File, Line (1 .. Last));
end if;
else
Put_Line (IO_File, Line (1 .. Last));
end if;
end if;
end loop;
end if;
Close (BG_File);
if not Static_Libs
and then Adalib_Dir /= null
then
Put_Line (IO_File, Binding_Label (Run_Path_Option));
Put_Line (IO_File, Adalib_Dir.all);
Name_Len := Adalib_Dir'Length;
Name_Buffer (1 .. Name_Len) := Adalib_Dir.all;
for J in reverse 2 .. Name_Len - 4 loop
if Name_Buffer (J) = Directory_Separator and then
Name_Buffer (J + 4) = Directory_Separator and then
Name_Buffer (J + 1 .. J + 3) = "lib"
then
Name_Len := J + 3;
Put_Line (IO_File, Name_Buffer (1 .. Name_Len));
exit;
end if;
end loop;
end if;
Close (IO_File);
end;
end Gprbind;
gprbuild-gpl-2014-src/src/gprconfig-knowledge.ads 0000644 0000767 0000145 00000053561 12323721731 021360 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R C O N F I G --
-- --
-- S p e c --
-- --
-- Copyright (C) 2006-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- This unit is responsible for parsing the gprconfig knowledge base
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded;
with GNAT.Regpat;
with Namet;
package GprConfig.Knowledge is
Generate_Error : exception;
-- To be raised when an error occurs during generation of config files
--------------------
-- Knowledge base --
--------------------
-- The following types and subprograms manipulate the knowldge base. This
-- base is a set of XML files that describe how to find compilers that are
-- installed on the system and that match specific criterias.
type Knowledge_Base is private;
function Default_Knowledge_Base_Directory return String;
-- Return the default location of the knowledge database. This is based on
-- the installation directory of the executable.
procedure Parse_Knowledge_Base
(Base : in out Knowledge_Base;
Directory : String;
Parse_Compiler_Info : Boolean := True;
Validate : Boolean := False);
-- Parse info from the knowledge base, and store it in memory.
-- Only information relevant to the current host is parsed.
-- If Parse_Compiler_Info is False, then only the information about
-- target sets is parsed.
-- This procedure will raise Invalid_Knowledge_Base if the base contains
-- incorrect data.
-- If Validate is True, the contents of the knowledge base is first
-- validated with an XSD schema.
Invalid_Knowledge_Base : exception;
-- To be raised when an error occurred while parsing the knowledge base
Knowledge_Base_Validation_Error : exception;
-- Some files in the knowledge base are invalid.
-----------------
-- Target sets --
-----------------
-- One of the information pieces contain in the database is a way to
-- normalize target names, since various names are used in different
-- contexts thus making it harder to write project files depending on the
-- target.
type Targets_Set_Id is private;
-- Identify a target aliases set
All_Target_Sets : constant Targets_Set_Id;
-- Matches all target sets
Unknown_Targets_Set : constant Targets_Set_Id;
-- Special target set when a target is not known
function Query_Targets_Set
(Base : Knowledge_Base;
Target : String) return Targets_Set_Id;
-- Get the target alias set id for a target, or Unknown_Targets_Set if
-- no such target is in the base.
procedure Get_Targets_Set
(Base : in out Knowledge_Base;
Target : String;
Id : out Targets_Set_Id);
-- Get the target alias set id for a target. If not already in the base,
-- add it.
function Normalized_Target
(Base : Knowledge_Base;
Set : Targets_Set_Id) return String;
-- Return the normalized name for a target set
---------------
-- Compilers --
---------------
-- Most of the information in the database relates to compilers. However,
-- you do not have direct access to the generic description that explains
-- how to find compilers on the PATH and how to compute their attributes
-- (version, runtimes,...) Instead, this package gives you access to the
-- list of compilers that were found. The package ensures that all
-- information is only computed at most once, to save on system calls and
-- provide better performance.
type Compiler is private;
type Compiler_Access is access all Compiler;
function Runtime_Dir_Of (Comp : Compiler_Access) return Namet.Name_Id;
-- Return the name of the runtime directory for the compiler. Returns
-- No_Name if Comp is null.
package Compiler_Lists
is new Ada.Containers.Indefinite_Doubly_Linked_Lists (Compiler_Access);
-- A list of compilers
function Is_Selected (Comp : Compiler) return Boolean;
function Target (Comp : Compiler) return Namet.Name_Id;
procedure Set_Selection
(Compilers : in out Compiler_Lists.List;
Cursor : Compiler_Lists.Cursor;
Selected : Boolean);
procedure Set_Selection
(Comp : in out Compiler;
Selected : Boolean);
-- Toggle the selection status of a compiler in the list.
-- This does not check that the selection is consistent though (use
-- Is_Supported_Config to do this test)
function To_String
(Base : Knowledge_Base;
Comp : Compiler;
As_Config_Arg : Boolean;
Show_Target : Boolean := False;
Rank_In_List : Integer := -1;
Parser_Friendly : Boolean := False) return String;
-- Return a string representing the compiler. It is either the --config
-- argument (if As_Config_Arg is true) or the string to use in the
-- interactive menu otherwise.
-- If Rank_In_List is specified, it is written at the beginning of the
-- line.
-- If Parser_Friendly is set, then the list is displayed in a way that can
-- be easily parsed automatically
function To_String
(Base : Knowledge_Base;
Compilers : Compiler_Lists.List;
Selected_Only : Boolean;
Show_Target : Boolean := False;
Parser_Friendly : Boolean := False) return String;
-- Return the list of compilers.
-- Unselectable compilers are hidden. If Selected_Only is true, then only
-- compilers that are currently selected are displayed.
-- If Parser_Friendly is set, then the list is displayed in a way that can
-- be easily parsed automatically
function Display_Before (Comp1, Comp2 : Compiler_Access) return Boolean;
-- Whether Comp1 should be displayed before Comp2 when displaying lists of
-- compilers. This ensures that similar languages are grouped, among othe
-- things.
procedure Filter_Compilers_List
(Base : Knowledge_Base;
Compilers : in out Compiler_Lists.List;
For_Target_Set : Targets_Set_Id);
-- Based on the currently selected compilers, check which other compilers
-- can or cannot be selected by the user.
-- This is not the case if the resulting selection in Compilers is not a
-- supported config (multiple compilers for the same language, set of
-- compilers explicitly marked as unsupported in the knowledge base,...).
------------------
-- Command line --
------------------
-- This package provides support for manipulating the --config command line
-- parameters. The intent is that they have the same form in all the tools
-- that support it. The information provides to --config might be partial
-- only, and this package provides support for completing it automatically
-- based on the knowledge base.
procedure Parse_Config_Parameter
(Base : Knowledge_Base;
Config : String;
Compiler : out Compiler_Access;
Requires_Compiler : out Boolean);
-- Parse the --config parameter, and store the (partial) information
-- found in Compiler.
-- When a switch matches a language that requires no compiler,
-- Requires_Compiler is set to False.
-- Raises Invalid_Config if Config is invalid
Invalid_Config : exception;
-- Raised when the user has specified an invalid --config switch
procedure Complete_Command_Line_Compilers
(Base : in out Knowledge_Base;
On_Target : Targets_Set_Id;
Filters : Compiler_Lists.List;
Compilers : in out Compiler_Lists.List);
-- In batch mode, the --config parameters indicate what compilers should be
-- selected. Each of these switch selects the first matching compiler
-- available, and all --config switch must match a compiler.
-- The information provided by the user does not have to be complete, and
-- this procedure completes all missing information like version, runtime,
-- and so on.
-- In gprconfig, it should only be called in batch mode, since otherwise
-- --config only acts as a filter for the compilers that are found through
-- the knowledge base.
-- Filters is the list specified by the user as --config, and contains
-- potentially partial information for each compiler. On output, Compilers
-- is completed with the full information for all compilers in Filters. If
-- at least one of the compilers in Filters cannot be found, Invalid_Config
-- is raised.
function Extra_Dirs_From_Filters
(Filters : Compiler_Lists.List) return String;
-- Compute the list of directories that should be prepended to the PATH
-- when searching for compilers. These are all the directories that the
-- user has explicitly specified in his filters (aka --config)
-----------------------------
-- knowledge base contents --
-----------------------------
function Hash_Case_Insensitive
(Name : Namet.Name_Id) return Ada.Containers.Hash_Type;
package Variables_Maps is new Ada.Containers.Hashed_Maps
(Key_Type => Namet.Name_Id,
Element_Type => Namet.Name_Id,
Hash => Hash_Case_Insensitive,
Equivalent_Keys => Namet."=",
"=" => Namet."=");
No_Compiler : constant Compiler;
-- Describes one of the compilers found on the PATH.
-- Path is the directory that contains the compiler executable.
-- Path_Order is used for sorting in the interactive menu: it indicates the
-- index in $PATH of the directory, so that we can show first the compilers
-- that are first in path.
-- Any of these compilers can be selected by the user as part of a config.
-- However, to prevent incompatibilities, a compiler can be marked as not
-- selectable. This will be re-evaluated based on the current selection.
-- Complete is set to True if all the information about the compiler was
-- computed. It is set to False if the compiler was specified through a
-- command line argument --config, and part of the info needs to be
-- computed.
-- Index_In_List is used for the interactive menu, and is initialized
-- automatically.
type Compiler_Iterator is abstract tagged null record;
-- An iterator that searches for all known compilers in a list of
-- directories. Whenever a new compiler is found, the Callback primitive
-- operation is called.
procedure Callback
(Iterator : in out Compiler_Iterator;
Base : in out Knowledge_Base;
Comp : Compiler;
From_Extra_Dir : Boolean;
Continue : out Boolean) is abstract;
-- Called whenever a new compiler is discovered.
-- It might be discovered either in a path added through a --config
-- parameter (in which case From_Extra_Dir is True), or in a path specified
-- in the environment variable $PATH (in which case it is False). If the
-- directory is both in Extra_Dirs and in $PATH, From_Extra_Dir is set to
-- False.
-- On exit, Continue should be set to False if there is no need to discover
-- further compilers (however there will be no possibility to restart the
-- search at the same point later on).
procedure Foreach_Compiler_In_Path
(Iterator : in out Compiler_Iterator;
Base : in out Knowledge_Base;
On_Target : Targets_Set_Id;
Extra_Dirs : String := "");
-- Find all compilers in "Extra_Dirs & $PATH".
-- Extra_Dirs should typically be the list of directories found in
-- --config command line arguments.
-- The only filtering done is the target, for optimization purposes (no
-- need to computed all info about the compiler if we know it will not be
-- uses anyway).
procedure Known_Compiler_Names
(Base : Knowledge_Base;
List : out Ada.Strings.Unbounded.Unbounded_String);
-- Set List to the comma-separated list of known compilers
procedure Generate_Configuration
(Base : Knowledge_Base;
Compilers : Compiler_Lists.List;
Output_File : String;
Target : String);
-- Generate the configuration file for the list of selected compilers
package String_Lists is
new Ada.Containers.Indefinite_Doubly_Linked_Lists (String);
procedure Put_Verbose (Str : String; Indent_Delta : Integer := 0);
-- Print Str if verbose mode is activated.
-- Indent_Delta will increase the current indentation level for all further
-- traces, which is used to highlight nested calls. Only the sign of
-- Indent_Delta is taken into account.
-- Nothing is printed if Str is the empty string, only the indentation is
-- changed
function Filter_Match
(Base : Knowledge_Base;
Comp : Compiler;
Filter : Compiler) return Boolean;
-- Returns True if Comp match Filter (the latter corresponds to a --config
-- command line argument).
private
type Targets_Set_Id is range -1 .. Natural'Last;
All_Target_Sets : constant Targets_Set_Id := -1;
Unknown_Targets_Set : constant Targets_Set_Id := 0;
type Compiler is record
Name : Namet.Name_Id := Namet.No_Name;
-- The name of the compiler, as specified in the node of the
-- knowledge base. If Compiler represents a filter as defined on through
-- --config switch, then name can also be the base name of the
-- executable we are looking for. In such a case, it never includes the
-- exec suffix (.exe on Windows)
Executable : Namet.Name_Id := Namet.No_Name;
Target : Namet.Name_Id := Namet.No_Name;
Targets_Set : Targets_Set_Id;
Path : Namet.Name_Id := Namet.No_Name;
Base_Name : Namet.Name_Id := Namet.No_Name;
-- Base name of the executable. This does not include the exec suffix
Version : Namet.Name_Id := Namet.No_Name;
Variables : Variables_Maps.Map;
Prefix : Namet.Name_Id := Namet.No_Name;
Runtime : Namet.Name_Id := Namet.No_Name;
Alt_Runtime : Namet.Name_Id := Namet.No_Name;
Runtime_Dir : Namet.Name_Id := Namet.No_Name;
Path_Order : Integer;
Language_Case : Namet.Name_Id := Namet.No_Name;
-- The supported language, with the casing read from the compiler. This
-- is for display purposes only
Language_LC : Namet.Name_Id := Namet.No_Name;
-- The supported language, always lower case
Selectable : Boolean := True;
Selected : Boolean := False;
Complete : Boolean := True;
end record;
No_Compiler : constant Compiler :=
(Name => Namet.No_Name,
Target => Namet.No_Name,
Targets_Set => Unknown_Targets_Set,
Executable => Namet.No_Name,
Base_Name => Namet.No_Name,
Path => Namet.No_Name,
Variables => Variables_Maps.Empty_Map,
Version => Namet.No_Name,
Prefix => Namet.No_Name,
Runtime => Namet.No_Name,
Alt_Runtime => Namet.No_Name,
Runtime_Dir => Namet.No_Name,
Language_Case => Namet.No_Name,
Language_LC => Namet.No_Name,
Selectable => False,
Selected => False,
Complete => True,
Path_Order => 0);
type Pattern_Matcher_Access is access all GNAT.Regpat.Pattern_Matcher;
type External_Value_Type is (Value_Constant,
Value_Shell,
Value_Directory,
Value_Grep,
Value_Nogrep,
Value_Filter,
Value_Must_Match,
Value_Variable,
Value_Done);
type External_Value_Node
(Typ : External_Value_Type := Value_Constant) is
record
case Typ is
when Value_Constant =>
Value : Namet.Name_Id;
when Value_Shell =>
Command : Namet.Name_Id;
when Value_Directory =>
Directory : Namet.Name_Id;
Directory_Group : Integer;
Dir_If_Match : Namet.Name_Id;
Contents : Pattern_Matcher_Access;
when Value_Grep =>
Regexp_Re : Pattern_Matcher_Access;
Group : Natural;
when Value_Nogrep =>
Regexp_No : Pattern_Matcher_Access;
when Value_Filter =>
Filter : Namet.Name_Id;
when Value_Must_Match =>
Must_Match : Namet.Name_Id;
when Value_Variable =>
Var_Name : Namet.Name_Id;
when Value_Done =>
null;
end case;
end record;
package External_Value_Nodes is
new Ada.Containers.Doubly_Linked_Lists (External_Value_Node);
subtype External_Value is External_Value_Nodes.List;
Null_External_Value : constant External_Value :=
External_Value_Nodes.Empty_List;
type Compiler_Description is record
Name : Namet.Name_Id := Namet.No_Name;
Executable : Namet.Name_Id := Namet.No_Name;
Executable_Re : Pattern_Matcher_Access;
Prefix_Index : Integer := -1;
Target : External_Value;
Version : External_Value;
Variables : External_Value;
Languages : External_Value;
Runtimes : External_Value;
Default_Runtimes : String_Lists.List;
end record;
-- Executable_Re is only set if the name of the must be
-- taken as a regular expression.
package Compiler_Description_Maps is new
Ada.Containers.Indefinite_Hashed_Maps
(Namet.Name_Id, Compiler_Description,
Hash_Case_Insensitive, Namet."=");
type Compiler_Filter is record
Name : Namet.Name_Id;
Version : Namet.Name_Id;
Version_Re : Pattern_Matcher_Access;
Runtime : Namet.Name_Id;
Runtime_Re : Pattern_Matcher_Access;
Language_LC : Namet.Name_Id;
end record;
-- Representation for a node (in )
package Compiler_Filter_Lists is new Ada.Containers.Doubly_Linked_Lists
(Compiler_Filter);
type Compilers_Filter is record
Compiler : Compiler_Filter_Lists.List;
Negate : Boolean := False;
end record;
No_Compilers_Filter : constant Compilers_Filter :=
(Compiler => Compiler_Filter_Lists.Empty_List,
Negate => False);
-- a filter, that matches if any of its child
-- matches.
package Compilers_Filter_Lists is new Ada.Containers.Doubly_Linked_Lists
(Compilers_Filter);
type Configuration is record
Compilers_Filters : Compilers_Filter_Lists.List;
Targets_Filters : String_Lists.List; -- these are regexps
Negate_Targets : Boolean := False;
Config : Namet.Name_Id;
Supported : Boolean;
-- Whether the combination of compilers is supported
end record;
package Configuration_Lists is new Ada.Containers.Doubly_Linked_Lists
(Configuration);
package Target_Lists is new Ada.Containers.Doubly_Linked_Lists
(Pattern_Matcher_Access);
type Target_Set_Description is record
Name : Namet.Name_Id;
Patterns : Target_Lists.List;
end record;
subtype Known_Targets_Set_Id
is Targets_Set_Id range 1 .. Targets_Set_Id'Last;
-- Known targets set. They are in the base
package Targets_Set_Vectors is new Ada.Containers.Vectors
(Known_Targets_Set_Id, Target_Set_Description, "=");
type Knowledge_Base is record
Compilers : Compiler_Description_Maps.Map;
No_Compilers : String_Lists.List;
Check_Executable_Regexp : Boolean := False;
Configurations : Configuration_Lists.List;
Targets_Sets : Targets_Set_Vectors.Vector;
end record;
-- Check_Executable_Regexp is set to True if at least some of the
-- executable names are specified as regular expressions. In such a case,
-- a slightly slower algorithm is used to search for compilers.
-- No_Compilers is the list of languages that require no compiler, and thus
-- should not be searched on the PATH.
end GprConfig.Knowledge;
gprbuild-gpl-2014-src/src/gprlib-build_shared_lib-vms.adb 0000644 0000767 0000145 00000005507 12323721731 022734 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R L I B . B U I L D _ S H A R E D _ L I B --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006-2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with MLib.Tgt; use MLib.Tgt;
with MLib.Utl; use MLib.Utl;
separate (Gprlib)
procedure Build_Shared_Lib is
Ofiles : Argument_List (1 .. Object_Files.Last);
Options : Argument_List (1 .. Options_Table.Last);
begin
-- If runtime library directory is indicated, call Specify_Adalib_Dir so
-- that function MLib.Libgnat returns it. If we don't know what is the
-- runtime library directory, set it to the current directory so that
-- MLib.Libgnat does not fail.
if Runtime_Library_Dir /= null then
Specify_Adalib_Dir (Runtime_Library_Dir.all);
else
Specify_Adalib_Dir (".");
end if;
-- On VMS, use Build_Dynamic_Library to build the library as there is
-- specific handling of symbols.
for J in Ofiles'Range loop
Ofiles (J) := Object_Files.Table (J);
end loop;
for J in Options'Range loop
Options (J) := Options_Table.Table (J);
end loop;
Build_Dynamic_Library
(Ofiles => Ofiles,
Options => Options,
Interfaces => MLib.No_Argument_List,
Lib_Filename => Library_Name.all,
Lib_Dir => Library_Directory.all,
Symbol_Data => Prj.No_Symbols,
Lib_Version => Library_Version.all,
Driver_Name => Driver_Name,
Auto_Init => Auto_Init);
end Build_Shared_Lib;
gprbuild-gpl-2014-src/src/gpr_version.ads 0000644 0000767 0000145 00000003751 12323721731 017756 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R _ V E R S I O N --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- This package spec holds version information for the GPR tools.
-- It is updated whenever the release number is changed.
package GPR_Version is
Gpr_Version : constant String := "2014";
-- Static string identifying this version
function Gpr_Version_String return String;
-- Version output when GPRBUILD or its related tools, including
-- GPRCLEAN, are run (with appropriate verbose option switch set).
end GPR_Version;
gprbuild-gpl-2014-src/src/gprslave.ads 0000644 0000767 0000145 00000003101 12323721731 017231 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . C O M P I L E --
-- --
-- B o d y --
-- --
-- Copyright (C) 2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
procedure Gprslave;
gprbuild-gpl-2014-src/src/gprbuild.adb 0000644 0000767 0000145 00000050356 12323721731 017213 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D --
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Output; use Output;
with Gpr_Util; use Gpr_Util;
package body Gprbuild is
package Processed_Projects is new GNAT.HTable.Simple_HTable
(Header_Num => Prj.Header_Num,
Element => Boolean,
No_Element => False,
Key => Name_Id,
Hash => Hash,
Equal => "=");
-- Projects that have already been processed
----------------
-- Add_Option --
----------------
procedure Add_Option
(Value : String;
To : in out Options_Data;
Display : Boolean;
Simple_Name : Boolean := False)
is
begin
Name_Len := Value'Length;
Name_Buffer (1 .. Name_Len) := Value;
Add_Option_Internal (Get_Option (Name_Find), To, Display, Simple_Name);
end Add_Option;
procedure Add_Option
(Value : Name_Id;
To : in out Options_Data;
Display : Boolean;
Simple_Name : Boolean := False)
is
begin
Add_Option_Internal (Get_Option (Value), To, Display, Simple_Name);
end Add_Option;
-------------------------
-- Add_Option_Internal --
-------------------------
procedure Add_Option_Internal
(Value : String_Access;
To : in out Options_Data;
Display : Boolean;
Simple_Name : Boolean := False)
is
begin
-- For compatibility with gnatmake, do not consider empty options
if Value'Length = 0 then
return;
end if;
To.Last := To.Last + 1;
if To.Last > To.Options'Last then
declare
New_Options : constant String_List_Access :=
new String_List (1 .. 2 * To.Options'Last);
New_Visible : constant Booleans :=
new Boolean_Array (1 .. 2 * To.Visible'Last);
New_Simple_Name : constant Booleans :=
new Boolean_Array (1 .. 2 * To.Visible'Last);
begin
New_Options (To.Options'Range) := To.Options.all;
To.Options.all := (others => null);
Free (To.Options);
To.Options := New_Options;
New_Visible (To.Visible'Range) := To.Visible.all;
Free (To.Visible);
To.Visible := New_Visible;
New_Simple_Name (To.Simple_Name'Range) := To.Simple_Name.all;
Free (To.Simple_Name);
To.Simple_Name := New_Simple_Name;
end;
end if;
To.Options (To.Last) := Value;
To.Visible (To.Last) := Display;
To.Simple_Name (To.Last) := Simple_Name;
end Add_Option_Internal;
----------------------------------
-- Add_Option_Internal_Codepeer --
----------------------------------
procedure Add_Option_Internal_Codepeer
(Value : String_Access;
To : in out Options_Data;
Display : Boolean;
Simple_Name : Boolean := False)
is
begin
if Value'Length <= 2
or else Value (Value'First .. Value'First + 1) /= "-m"
then
Add_Option_Internal (Value, To, Display, Simple_Name);
end if;
end Add_Option_Internal_Codepeer;
-----------------
-- Add_Options --
-----------------
procedure Add_Options
(Value : String_List_Id;
To : in out Options_Data;
Display_All : Boolean;
Display_First : Boolean;
Simple_Name : Boolean := False)
is
List : String_List_Id := Value;
Element : String_Element;
Option : String_Access;
First_Display : Boolean := Display_First;
begin
while List /= Nil_String loop
Element := Project_Tree.Shared.String_Elements.Table (List);
-- Ignore empty options
if Element.Value /= Empty_String then
Option := Get_Option (Element.Value);
Add_Option_Internal
(Value => Option,
To => To,
Display => Display_All or First_Display,
Simple_Name => Simple_Name);
First_Display := False;
end if;
List := Element.Next;
end loop;
end Add_Options;
-----------------
-- Add_Process --
-----------------
procedure Add_Process (Process : Process_Id; Data : Process_Data) is
begin
Process_Htable.Set (Process, Data);
Outstanding_Processes := Outstanding_Processes + 1;
end Add_Process;
--------------------
-- Archive_Suffix --
--------------------
function Archive_Suffix (For_Project : Project_Id) return String is
begin
if For_Project.Config.Archive_Suffix = No_File then
return ".a";
else
return Get_Name_String (For_Project.Config.Archive_Suffix);
end if;
end Archive_Suffix;
-------------------
-- Await_Process --
-------------------
procedure Await_Process (Data : out Process_Data; OK : out Boolean) is
Pid : Process_Id;
begin
loop
Data := No_Process_Data;
Wait_Process (Pid, OK);
if Pid = Invalid_Pid then
return;
end if;
Data := Process_Htable.Get (Pid);
if Data /= No_Process_Data then
Process_Htable.Set (Pid, No_Process_Data);
Outstanding_Processes := Outstanding_Processes - 1;
return;
end if;
end loop;
end Await_Process;
--------------------------------
-- Change_To_Object_Directory --
--------------------------------
procedure Change_To_Object_Directory (Project : Project_Id) is
begin
-- Nothing to do if the current working directory is already the correct
-- object directory.
if Project_Of_Current_Object_Directory /= Project then
Project_Of_Current_Object_Directory := Project;
-- Set the working directory to the object directory of the actual
-- project.
Change_Dir (Get_Name_String (Project.Object_Directory.Display_Name));
if Opt.Verbose_Mode and then Opt.Verbosity_Level > Opt.Low then
Write_Str ("Changing to object directory of """);
Write_Name (Project.Display_Name);
Write_Str (""": """);
Write_Name (Project.Object_Directory.Display_Name);
Write_Line ("""");
end if;
end if;
exception
-- Fail if unable to change to the object directory
when Directory_Error =>
Fail_Program
(Project_Tree,
"unable to change to object directory """ &
Get_Name_String (Project.Object_Directory.Display_Name) &
""" of project " &
Get_Name_String (Project.Display_Name));
end Change_To_Object_Directory;
---------------------------
-- Check_Archive_Builder --
---------------------------
procedure Check_Archive_Builder is
List : Name_List_Index;
begin
-- First, make sure that the archive builder (ar) is on the path
if Archive_Builder_Path = null then
List := Main_Project.Config.Archive_Builder;
if List = No_Name_List then
Fail_Program
(Project_Tree, "no archive builder in configuration");
else
Archive_Builder_Name :=
new String'(Get_Name_String
(Project_Tree.Shared.Name_Lists.Table
(List).Name));
Archive_Builder_Path :=
Locate_Exec_On_Path (Archive_Builder_Name.all);
if Archive_Builder_Path = null then
Fail_Program
(Project_Tree,
"unable to locate archive builder """ &
Archive_Builder_Name.all & '"');
end if;
loop
List := Project_Tree.Shared.Name_Lists.Table (List).Next;
exit when List = No_Name_List;
Add_Option
(Value => Project_Tree.Shared.Name_Lists.Table (List).Name,
To => Archive_Builder_Opts,
Display => True);
end loop;
List := Main_Project.Config.Archive_Builder_Append_Option;
while List /= No_Name_List loop
Add_Option
(Value => Project_Tree.Shared.Name_Lists.Table (List).Name,
To => Archive_Builder_Append_Opts,
Display => True);
List := Project_Tree.Shared.Name_Lists.Table (List).Next;
end loop;
-- If there is an archive indexer (ranlib), try to locate it on
-- the path. Don't fail if it is not found.
List := Main_Project.Config.Archive_Indexer;
if List /= No_Name_List then
Archive_Indexer_Name :=
new String'(Get_Name_String
(Project_Tree.Shared.Name_Lists.Table (List).Name));
Archive_Indexer_Path :=
Locate_Exec_On_Path (Archive_Indexer_Name.all);
if Archive_Builder_Path /= null then
loop
List := Project_Tree.Shared.Name_Lists.Table (List).Next;
exit when List = No_Name_List;
Add_Option
(Value =>
Project_Tree.Shared.Name_Lists.Table (List).Name,
To => Archive_Indexer_Opts,
Display => True);
end loop;
end if;
end if;
end if;
end if;
end Check_Archive_Builder;
---------------------------
-- Create_Path_From_Dirs --
---------------------------
function Create_Path_From_Dirs return String_Access is
Result : String_Access;
Tmp : String_Access;
Path_Last : Natural := 0;
begin
for Index in 1 .. Directories.Last loop
Get_Name_String (Directories.Table (Index));
while Name_Len > 1
and then (Name_Buffer (Name_Len) = Directory_Separator
or else Name_Buffer (Name_Len) = '/')
loop
Name_Len := Name_Len - 1;
end loop;
if Result = null then
Result := new String (1 .. Name_Len);
else
while Path_Last + Name_Len + 1 > Result'Last loop
Tmp := new String (1 .. 2 * Result'Length);
Tmp (1 .. Path_Last) := Result (1 .. Path_Last);
Free (Result);
Result := Tmp;
end loop;
Path_Last := Path_Last + 1;
Result (Path_Last) := Path_Separator;
end if;
Result (Path_Last + 1 .. Path_Last + Name_Len) :=
Name_Buffer (1 .. Name_Len);
Path_Last := Path_Last + Name_Len;
end loop;
if Current_Verbosity = High and then Result /= null then
Put_Line ("Path=" & Result (1 .. Path_Last));
end if;
Tmp := new String'(Result (1 .. Path_Last));
Free (Result);
return Tmp;
end Create_Path_From_Dirs;
-----------------------
-- Display_Processes --
-----------------------
procedure Display_Processes (Name : String) is
begin
if Opt.Maximum_Processes > 1
and then Opt.Verbose_Mode
and then Current_Verbosity = High
then
Write_Str (" ");
Write_Str (Outstanding_Processes'Img);
Write_Char (' ');
Write_Str (Name);
if Outstanding_Processes <= 1 then
Write_Line (" process");
else
Write_Line (" processes");
end if;
end if;
end Display_Processes;
----------------
-- Get_Option --
----------------
function Get_Option (Option : Name_Id) return String_Access is
Option_Name : constant String := Get_Name_String (Option);
begin
-- Look in All_Options if this option is already cached
for Index in 1 .. All_Options.Last loop
if All_Options.Options (Index).all = Option_Name then
return All_Options.Options (Index);
end if;
end loop;
-- Add the option to the All_Options cache, so that it will be found
-- next time.
Add_Option_Internal
(new String'(Option_Name),
To => All_Options,
Display => False);
return All_Options.Options (All_Options.Last);
end Get_Option;
----------
-- Hash --
----------
function Hash (Pid : Process_Id) return Header_Num is
Modulo : constant Integer := Integer (Header_Num'Last) + 1;
begin
return Header_Num (Pid_To_Integer (Pid) mod Modulo);
end Hash;
--------------------------------
-- Process_Imported_Libraries --
--------------------------------
procedure Process_Imported_Libraries
(For_Project : Project_Id;
There_Are_SALs : out Boolean;
And_Project_Itself : Boolean := False)
is
procedure Process_Project (Project : Project_Id; Is_Aggregate : Boolean);
-- Process Project and its imported projects recursively.
-- Add any library projects to table Library_Projs.
---------------------
-- Process_Project --
---------------------
procedure Process_Project
(Project : Project_Id; Is_Aggregate : Boolean)
is
Imported : Project_List := Project.Imported_Projects;
begin
-- Nothing to do if project has already been processed
if not Processed_Projects.Get (Project.Name) then
Processed_Projects.Set (Project.Name, True);
-- We first process the imported projects to guarantee that
-- We have a proper reverse order for the libraries. Do not add
-- library for encapsulated libraries dependencies except when
-- building the encapsulated library itself.
if For_Project.Standalone_Library = Encapsulated
or else Project.Standalone_Library /= Encapsulated
then
while Imported /= null loop
if Imported.Project /= No_Project then
Process_Project
(Imported.Project,
Is_Aggregate =>
(Project.Qualifier = Aggregate_Library)
or else Is_Aggregate);
end if;
Imported := Imported.Next;
end loop;
end if;
-- For an extending project, process the project being extended
if Project.Extends /= No_Project then
Process_Project (Project.Extends, Is_Aggregate => False);
end if;
-- If it is a library project, add it to Library_Projs
if (And_Project_Itself or else Project /= For_Project)
and then Project.Extended_By = No_Project
and then Project.Library
then
if Project.Standalone_Library /= No then
There_Are_SALs := True;
end if;
Library_Projs.Append
(Library_Project'
(Project,
Is_Aggregate and then not Project.Externally_Built));
end if;
end if;
end Process_Project;
-- Start of processing for Process_Imported_Libraries
begin
Processed_Projects.Reset;
Library_Projs.Init;
There_Are_SALs := False;
Process_Project (For_Project, Is_Aggregate => False);
end Process_Imported_Libraries;
------------------------------------
-- Process_Imported_Non_Libraries --
------------------------------------
procedure Process_Imported_Non_Libraries (For_Project : Project_Id) is
procedure Process_Project (Project : Project_Id);
-- Process Project and its imported projects recursively.
-- Add any non library project to table Non_Library_Projs.
---------------------
-- Process_Project --
---------------------
procedure Process_Project (Project : Project_Id) is
Imported : Project_List := Project.Imported_Projects;
begin
-- Nothing to do if project has already been processed
if not Processed_Projects.Get (Project.Name) then
Processed_Projects.Set (Project.Name, True);
-- Call Process_Project recursively for any imported project.
-- We first process the imported projects to guarantee that
-- we have a proper reverse order for the libraries.
while Imported /= null loop
if Imported.Project /= No_Project then
Process_Project (Imported.Project);
end if;
Imported := Imported.Next;
end loop;
-- For an extending project, process the project being extended
if Project.Extends /= No_Project then
Process_Project (Project.Extends);
end if;
-- If it is not a library project, add it to Non_Library_Projs
if Project /= For_Project
and then Project.Extended_By = No_Project
and then not Project.Library
then
Non_Library_Projs.Append (Project);
end if;
end if;
end Process_Project;
-- Start of processing for Process_Imported_Non_Libraries
begin
Processed_Projects.Reset;
Non_Library_Projs.Init;
Process_Project (For_Project);
end Process_Imported_Non_Libraries;
--------------------
-- Record_Failure --
--------------------
procedure Record_Failure (Main : Main_Info) is
begin
Bad_Processes.Append (Main);
if not Opt.Keep_Going then
Stop_Spawning := True;
end if;
end Record_Failure;
---------------------------
-- Test_If_Relative_Path --
---------------------------
procedure Test_If_Relative_Path
(Switch : in out String_Access;
Parent : String;
Including_Switch : Name_Id)
is
Original : constant String (1 .. Switch'Length) := Switch.all;
begin
if Original (1) = '-' and then Including_Switch /= No_Name then
declare
Inc_Switch : constant String := Get_Name_String (Including_Switch);
begin
if Original'Last > Inc_Switch'Last
and then Original (1 .. Inc_Switch'Last) = Inc_Switch
and then not Is_Absolute_Path
(Original (Inc_Switch'Last + 1 .. Original'Last))
then
Switch := new String'
(Inc_Switch & Parent & Directory_Separator &
Original (Inc_Switch'Last + 1 .. Original'Last));
end if;
end;
end if;
if Original (1) /= '-' and then not Is_Absolute_Path (Original) then
Switch := new String'(Parent & Directory_Separator & Original);
end if;
end Test_If_Relative_Path;
end Gprbuild;
gprbuild-gpl-2014-src/src/gprbuild-link.adb 0000644 0000767 0000145 00000311232 12323721731 020137 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . L I N K --
-- --
-- B o d y --
-- --
-- Copyright (C) 2011-2013, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation; use Ada;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Debug; use Debug;
with Gpr_Util; use Gpr_Util;
with Gprexch; use Gprexch;
with Makeutl; use Makeutl;
with Osint; use Osint;
with Output; use Output;
with Prj.Util; use Prj.Util;
with Snames; use Snames;
package body Gprbuild.Link is
type Archive_Data is record
Checked : Boolean := False;
Has_Been_Built : Boolean := False;
Exists : Boolean := False;
end record;
type Source_Index_Rec is record
Project : Project_Id;
Id : Source_Id;
Found : Boolean := False;
end record;
-- 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;
procedure Free is new Unchecked_Deallocation
(Source_Index_Array, Source_Indexes_Ref);
Initial_Source_Index_Count : constant Positive := 20;
Source_Indexes : Source_Indexes_Ref :=
new Source_Index_Array (1 .. Initial_Source_Index_Count);
-- A list of the Source_Ids, with an indication that they have been found
-- in the archive dependency file.
procedure Build_Global_Archive
(For_Project : Project_Id;
Project_Tree : Project_Tree_Ref;
Has_Been_Built : out Boolean;
Exists : out Boolean;
OK : out Boolean);
-- Build, if necessary, the global archive for a main project.
-- Out parameter Has_Been_Built is True iff the global archive has been
-- built/rebuilt. Exists is False if there is no need for a global archive.
-- OK is False when there is a problem building the global archive.
procedure Link_Main (Main_File : Main_Info);
-- Link a specific main unit
procedure Get_Linker_Options (For_Project : Project_Id);
-- Get the Linker_Options from a project
procedure Add_Rpath (Path : String);
-- Add a path name to Rpath
procedure Rpaths_Relative_To
(Exec_Dir : Path_Name_Type; Origin : Name_Id);
-- Change all paths in table Rpaths to paths relative to Exec_Dir, if they
-- have at least one non root directory in common.
function Is_In_Library_Project (Object_Path : String) return Boolean;
-- Return True if Object_Path is the path of an object file in a library
-- project.
procedure Display_Command
(Name : String;
Path : String_Access;
Ellipse : Boolean := False);
-- Display the command for a spawned process, if in Verbose_Mode or not in
-- Quiet_Output. In non verbose mode, when Ellipse is True, display "..."
-- in place of the first argument that has Display set to False.
procedure Add_Argument
(Arg : String_Access;
Display : Boolean;
Simple_Name : Boolean := False);
procedure Add_Argument
(Arg : String;
Display : Boolean;
Simple_Name : Boolean := False);
-- Add an argument to Arguments. Reallocate if necessary
procedure Add_Arguments
(Args : Argument_List;
Display : Boolean;
Simple_Name : Boolean := False);
-- Add a list of arguments to Arguments. Reallocate if necessary
No_Archive_Data : constant Archive_Data :=
(Checked => False,
Has_Been_Built => False,
Exists => False);
package Global_Archives_Built is new GNAT.HTable.Simple_HTable
(Header_Num => Prj.Header_Num,
Element => Archive_Data,
No_Element => No_Archive_Data,
Key => Name_Id,
Hash => Prj.Hash,
Equal => "=");
-- A hash table to record what global archives have been already built
package Cache_Args is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 200,
Table_Increment => 100,
Table_Name => "Buildgpr.Cache_Args");
-- A table to cache arguments, to avoid multiple allocation of the same
-- strings. It is not possible to use a hash table, because String is
-- an unconstrained type.
package Rpaths is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 200,
Table_Increment => 50,
Table_Name => "Makegpr.Rpaths");
-- Directories to be put in the run path option
package Library_Dirs is new GNAT.HTable.Simple_HTable
(Header_Num => Prj.Header_Num,
Element => Boolean,
No_Element => False,
Key => Path_Name_Type,
Hash => Hash,
Equal => "=");
-- A hash table to store the library dirs, to avoid repeating uselessly
-- the same switch when linking executables.
Last_Source : Natural := 0;
-- The index of the last valid component of Source_Indexes
Initial_Argument_Count : constant Positive := 20;
Arguments : Argument_List_Access :=
new Argument_List (1 .. Initial_Argument_Count);
-- Used to store lists of arguments to be used when spawning a process
Arguments_Displayed : Booleans :=
new Boolean_Array (1 .. Initial_Argument_Count);
-- For each argument in Arguments, indicate if the argument should be
-- displayed when procedure Display_Command is called.
Arguments_Simple_Name : Booleans :=
new Boolean_Array (1 .. Initial_Argument_Count);
-- For each argument that should be displayed, indicate that the argument
-- is a path name and that only the simple name should be displayed.
Last_Argument : Natural := 0;
-- Index of the last valid argument in Arguments
------------------
-- Add_Argument --
------------------
procedure Add_Argument
(Arg : String_Access;
Display : Boolean;
Simple_Name : Boolean := False)
is
begin
-- Nothing to do if no argument is specified or if argument is empty
if Arg /= null and then Arg'Length /= 0 then
-- Reallocate arrays if necessary
if Last_Argument = Arguments'Last then
declare
New_Arguments : constant Argument_List_Access :=
new Argument_List
(1 .. Last_Argument +
Initial_Argument_Count);
New_Arguments_Displayed : constant Booleans :=
new Boolean_Array
(1 .. Last_Argument +
Initial_Argument_Count);
New_Arguments_Simple_Name : constant Booleans :=
new Boolean_Array
(1 .. Last_Argument +
Initial_Argument_Count);
begin
New_Arguments (Arguments'Range) := Arguments.all;
-- To avoid deallocating the strings, nullify all components
-- of Arguments before calling Free.
Arguments.all := (others => null);
Free (Arguments);
Arguments := New_Arguments;
New_Arguments_Displayed (Arguments_Displayed'Range) :=
Arguments_Displayed.all;
Free (Arguments_Displayed);
Arguments_Displayed := New_Arguments_Displayed;
New_Arguments_Simple_Name (Arguments_Simple_Name'Range) :=
Arguments_Simple_Name.all;
Free (Arguments_Simple_Name);
Arguments_Simple_Name := New_Arguments_Simple_Name;
end;
end if;
-- Add the argument and its display indication
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := Arg;
Arguments_Displayed (Last_Argument) := Display;
Arguments_Simple_Name (Last_Argument) := Simple_Name;
end if;
end Add_Argument;
procedure Add_Argument
(Arg : String;
Display : Boolean;
Simple_Name : Boolean := False)
is
Argument : String_Access := null;
begin
-- Nothing to do if argument is empty
if Arg'Length > 0 then
-- Check if the argument is already in the Cache_Args table. If it is
-- already there, reuse the allocated value.
for Index in 1 .. Cache_Args.Last loop
if Cache_Args.Table (Index).all = Arg then
Argument := Cache_Args.Table (Index);
exit;
end if;
end loop;
-- If the argument is not in the cache, create a new entry in the
-- cache.
if Argument = null then
Argument := new String'(Arg);
Cache_Args.Increment_Last;
Cache_Args.Table (Cache_Args.Last) := Argument;
end if;
-- And add the argument
Add_Argument (Argument, Display, Simple_Name);
end if;
end Add_Argument;
-------------------
-- Add_Arguments --
-------------------
procedure Add_Arguments
(Args : Argument_List;
Display : Boolean;
Simple_Name : Boolean := False)
is
begin
-- Reallocate the arrays, if necessary
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_Arguments_Displayed : constant Booleans :=
new Boolean_Array
(1 .. Last_Argument +
Args'Length +
Initial_Argument_Count);
begin
New_Arguments (1 .. Last_Argument) :=
Arguments (1 .. Last_Argument);
-- To avoid deallocating the strings, nullify all components
-- of Arguments before calling Free.
Arguments.all := (others => null);
Free (Arguments);
Arguments := New_Arguments;
New_Arguments_Displayed (1 .. Last_Argument) :=
Arguments_Displayed (1 .. Last_Argument);
Free (Arguments_Displayed);
Arguments_Displayed := New_Arguments_Displayed;
end;
end if;
-- Add the new arguments and the display indications
Arguments (Last_Argument + 1 .. Last_Argument + Args'Length) := Args;
Arguments_Displayed (Last_Argument + 1 .. Last_Argument + Args'Length) :=
(others => Display);
Arguments_Simple_Name (Last_Argument + 1 .. Last_Argument + Args'Length)
:= (others => Simple_Name);
Last_Argument := Last_Argument + Args'Length;
end Add_Arguments;
---------------
-- Add_Rpath --
---------------
procedure Add_Rpath (Path : String) is
begin
-- Nothing to do if Path is empty
if Path'Length > 0 then
-- Nothing to do if the directory is already in the Rpaths table
for J in 1 .. Rpaths.Last loop
if Rpaths.Table (J).all = Path then
return;
end if;
end loop;
Rpaths.Append (new String'(Path));
end if;
end Add_Rpath;
--------------------------
-- Build_Global_Archive --
--------------------------
procedure Build_Global_Archive
(For_Project : Project_Id;
Project_Tree : Project_Tree_Ref;
Has_Been_Built : out Boolean;
Exists : out Boolean;
OK : out Boolean)
is
Archive_Name : constant String :=
"lib"
& Get_Name_String (For_Project.Name)
& Archive_Suffix (For_Project);
-- The name of the archive file for this project
Archive_Dep_Name : constant String :=
"lib"
& Get_Name_String (For_Project.Name) & ".deps";
-- The name of the archive dependency file for this project
File : Prj.Util.Text_File;
Object_Path : Path_Name_Type;
Time_Stamp : Time_Stamp_Type;
First_Object : Natural;
Discard : Boolean;
Proj_List : Project_List;
Src_Id : Source_Id;
S_Id : Source_Id;
Success : Boolean;
Real_Last_Argument : Positive;
Current_Object_Pos : Positive;
Size : Natural;
Global_Archive_Data : Archive_Data;
Need_To_Build : Boolean;
procedure Add_Sources (Proj : Project_Id);
-- Add all the sources of project Proj to Sources_Index
procedure Add_Objects (Proj : Project_Id);
-- Add all the object paths of project Proj to Arguments
-----------------
-- Add_Sources --
-----------------
procedure Add_Sources (Proj : Project_Id) is
Project : Project_Id := Proj;
Id : Source_Id;
Iter : Source_Iterator;
procedure Add_Source_Id (Project : Project_Id; Id : Source_Id);
-- Add a source id to Source_Indexes, with Found set to False
-------------------
-- Add_Source_Id --
-------------------
procedure Add_Source_Id (Project : Project_Id; Id : Source_Id) is
begin
-- Reallocate the array, if necessary
if Last_Source = Source_Indexes'Last then
declare
New_Indexes : constant Source_Indexes_Ref :=
new Source_Index_Array
(1 .. Source_Indexes'Last +
Initial_Source_Index_Count);
begin
New_Indexes (Source_Indexes'Range) := Source_Indexes.all;
Free (Source_Indexes);
Source_Indexes := New_Indexes;
end;
end if;
Last_Source := Last_Source + 1;
Source_Indexes (Last_Source) := (Project, Id, False);
end Add_Source_Id;
begin
while Project /= No_Project loop
Iter := For_Each_Source (Project_Tree, Project);
loop
Id := Prj.Element (Iter);
exit when Id = No_Source;
if Is_Compilable (Id)
and then Id.Kind = Impl
and then Id.Unit = No_Unit_Index
then
Add_Source_Id (Proj, Id);
end if;
Next (Iter);
end loop;
Project := Project.Extends;
end loop;
end Add_Sources;
-----------------
-- Add_Objects --
-----------------
procedure Add_Objects (Proj : Project_Id) is
Project : Project_Id := Proj;
Id : Source_Id;
Iter : Source_Iterator;
begin
loop
if Project.Object_Directory /= No_Path_Information then
if Project.Externally_Built then
-- If project is externally built, include all object files
-- in the object directory in the global archive.
declare
Obj_Dir : constant String :=
Get_Name_String
(Project.Object_Directory.Display_Name);
Dir_Obj : Dir_Type;
begin
if Is_Regular_File (Obj_Dir) then
Open (Dir_Obj, Obj_Dir);
loop
Read (Dir_Obj, Name_Buffer, Name_Len);
exit when Name_Len = 0;
Canonical_Case_File_Name
(Name_Buffer (1 .. Name_Len));
if Name_Len > Object_Suffix'Length
and then
Name_Buffer
(Name_Len - Object_Suffix'Length + 1
.. Name_Len) = Object_Suffix
then
Add_Argument
(Obj_Dir & Directory_Separator &
Name_Buffer (1 .. Name_Len),
Opt.Verbose_Mode,
Simple_Name => not Opt.Verbose_Mode);
end if;
end loop;
Close (Dir_Obj);
end if;
end;
else
Iter := For_Each_Source (Project_Tree, Project);
loop
Id := Prj.Element (Iter);
exit when Id = No_Source;
if Object_To_Global_Archive (Id) then
-- The source record may not be initialized if
-- gprbuild was called with the switch -l.
Initialize_Source_Record (Id);
Add_Argument
(Get_Name_String (Id.Object_Path),
Opt.Verbose_Mode,
Simple_Name => not Opt.Verbose_Mode);
end if;
Next (Iter);
end loop;
end if;
end if;
Project := Project.Extends;
exit when Project = No_Project;
end loop;
end Add_Objects;
begin
Exists := False;
Has_Been_Built := False;
OK := True;
-- No need to build the global archive, if it has already been done
if For_Project.Object_Directory /= No_Path_Information then
Global_Archive_Data :=
Global_Archives_Built.Get (Name_Id (For_Project.Path.Name));
if Global_Archive_Data.Checked then
Exists := Global_Archive_Data.Exists;
Has_Been_Built := Global_Archive_Data.Has_Been_Built;
else
Change_To_Object_Directory (For_Project);
-- Put all non Ada sources in the project tree in Source_Indexes
Last_Source := 0;
Add_Sources (For_Project);
Proj_List := For_Project.All_Imported_Projects;
while Proj_List /= null loop
if not Proj_List.Project.Library then
Add_Sources (Proj_List.Project);
end if;
Proj_List := Proj_List.Next;
end loop;
Need_To_Build := Opt.Force_Compilations;
if not Need_To_Build then
if Opt.Verbose_Mode then
Write_Str (" Checking ");
Write_Str (Archive_Name);
Write_Line (" ...");
end if;
-- If the archive does not exist, of course it needs to be
-- built.
if not Is_Regular_File (Archive_Name) then
Need_To_Build := True;
if Opt.Verbose_Mode then
Write_Line (" -> archive does not exist");
end if;
else
-- Archive does exist
-- 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_Build := True;
if Opt.Verbose_Mode then
Write_Str (" -> archive dependency file ");
Write_Str (Archive_Dep_Name);
Write_Line (" does not exist");
end if;
else
-- 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;
Src_Id := No_Source;
-- Check if this object file is for a source of this
-- project.
for S in 1 .. Last_Source loop
S_Id := Source_Indexes (S).Id;
if not Source_Indexes (S).Found
and then S_Id.Object_Path = Object_Path
then
-- We have found the object file: get the
-- source data, and mark it as found.
Src_Id := S_Id;
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 Src_Id = No_Source then
Need_To_Build := True;
if Opt.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_Build := True;
if Opt.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_Build := True;
if Opt.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. The
-- comparaison is done with String type values,
-- because two values of type Time_Stamp_Type are
-- equal if they differ by 2 seconds or less; here the
-- check is for an exact match.
if String (Time_Stamp) /=
String (Src_Id.Object_TS)
then
Need_To_Build := True;
if Opt.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");
Write_Str (" recorded time stamp: ");
Write_Line (String (Time_Stamp));
Write_Str (" actual time stamp: ");
Write_Line (String (Src_Id.Object_TS));
end if;
exit;
elsif Debug_Flag_T then
Write_Str (" -> time stamp of ");
Write_Str (Get_Name_String (Object_Path));
Write_Str (" is correct in the archive");
Write_Line (" dependency file");
Write_Str (" recorded time stamp: ");
Write_Line (String (Time_Stamp));
Write_Str (" actual time stamp: ");
Write_Line (String (Src_Id.Object_TS));
end if;
end loop;
Close (File);
end if;
end if;
end if;
if not Need_To_Build then
for S in 1 .. Last_Source loop
if not Source_Indexes (S).Found
and then Object_To_Global_Archive (Source_Indexes (S).Id)
then
Need_To_Build := True;
if Opt.Verbose_Mode then
Write_Str (" -> object file ");
Write_Str (Get_Name_String
(Source_Indexes (S).Id.Object_Path));
Write_Line (" is not in the dependency file");
end if;
exit;
end if;
end loop;
end if;
if not Need_To_Build then
if Opt.Verbose_Mode then
Write_Line (" -> up to date");
end if;
Exists := True;
Has_Been_Built := False;
-- Archive needs to be rebuilt
else
Check_Archive_Builder;
-- If archive already exists, first delete it, but if this is
-- not possible, continue: if archive cannot be built, we will
-- fail later on.
if Is_Regular_File (Archive_Name) then
Delete_File (Archive_Name, Discard);
end if;
Last_Argument := 0;
-- Start with the minimal options
Add_Arguments
(Archive_Builder_Opts.Options
(1 .. Archive_Builder_Opts.Last),
True);
-- Followed by the archive name
Add_Argument
(Archive_Name, True, Simple_Name => not Opt.Verbose_Mode);
First_Object := Last_Argument + 1;
-- Followed by all the object files of the non library projects
Add_Objects (For_Project);
Proj_List := For_Project.All_Imported_Projects;
while Proj_List /= null loop
if not Proj_List.Project.Library then
Add_Objects (Proj_List.Project);
end if;
Proj_List := Proj_List.Next;
end loop;
-- No global archive, if there is no object file to put into
if Last_Argument < First_Object then
Has_Been_Built := False;
Exists := False;
if Opt.Verbose_Mode then
Write_Line (" -> there is no global archive");
end if;
else
Real_Last_Argument := Last_Argument;
-- If there is an Archive_Builder_Append_Option, we may have
-- to build the archive in chuck.
if Archive_Builder_Append_Opts.Last = 0 then
Current_Object_Pos := Real_Last_Argument + 1;
else
Size := 0;
for J in 1 .. First_Object - 1 loop
Size := Size + Arguments (J)'Length + 1;
end loop;
Current_Object_Pos := First_Object;
while Current_Object_Pos <= Real_Last_Argument loop
Size :=
Size + Arguments (Current_Object_Pos)'Length + 1;
exit when Size > Maximum_Size;
Current_Object_Pos := Current_Object_Pos + 1;
end loop;
Last_Argument := Current_Object_Pos - 1;
end if;
Display_Command
(Archive_Builder_Name.all,
Archive_Builder_Path,
Ellipse => True);
Spawn
(Archive_Builder_Path.all,
Arguments (1 .. Last_Argument),
Success);
-- If the archive has not been built completely, add the
-- remaining chunks.
if Success
and then Current_Object_Pos <= Real_Last_Argument
then
Last_Argument := 0;
Add_Arguments
(Archive_Builder_Append_Opts.Options
(1 .. Archive_Builder_Append_Opts.Last),
True);
Add_Argument
(Archive_Name, True,
Simple_Name => not Opt.Verbose_Mode);
First_Object := Last_Argument + 1;
while Current_Object_Pos <= Real_Last_Argument loop
Size := 0;
for J in 1 .. First_Object - 1 loop
Size := Size + Arguments (J)'Length + 1;
end loop;
Last_Argument := First_Object - 1;
while Current_Object_Pos <= Real_Last_Argument loop
Size :=
Size + Arguments (Current_Object_Pos)'Length + 1;
exit when Size > Maximum_Size;
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) :=
Arguments (Current_Object_Pos);
Current_Object_Pos := Current_Object_Pos + 1;
end loop;
Display_Command
(Archive_Builder_Name.all,
Archive_Builder_Path,
Ellipse => True);
Spawn
(Archive_Builder_Path.all,
Arguments (1 .. Last_Argument),
Success);
exit when not Success;
end loop;
end if;
-- 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_Arguments
(Archive_Indexer_Opts.Options
(1 .. Archive_Indexer_Opts.Last),
True);
Add_Argument
(Archive_Name,
True,
Simple_Name => not Opt.Verbose_Mode);
Display_Command
(Archive_Indexer_Name.all, Archive_Indexer_Path);
Spawn
(Archive_Indexer_Path.all,
Arguments (1 .. Last_Argument),
Success);
if not Success then
-- Running the archive indexer failed, delete the
-- dependency file, if it exists.
if Is_Regular_File (Archive_Dep_Name) then
Delete_File (Archive_Dep_Name, Success);
end if;
end if;
end if;
end if;
if Success then
-- The archive was correctly built, create its dependency
-- file.
declare
Dep_File : Text_IO.File_Type;
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, Archive_Dep_Name);
for S in 1 .. Last_Source loop
Src_Id := Source_Indexes (S).Id;
if Object_To_Global_Archive (Src_Id) then
Put_Line
(Dep_File,
Get_Name_String (Src_Id.Object_Path));
Put_Line (Dep_File, String (Src_Id.Object_TS));
end if;
end loop;
Close (Dep_File);
exception
when others =>
if Is_Open (Dep_File) then
Close (Dep_File);
end if;
end;
Has_Been_Built := True;
Exists := True;
else
-- Building the archive failed, delete dependency file if
-- one exists.
if Is_Regular_File (Archive_Dep_Name) then
Delete_File (Archive_Dep_Name, Success);
end if;
Write_Str ("global archive for project ");
Write_Str
(Get_Name_String (For_Project.Display_Name));
Write_Line (" could not be built");
OK := False;
return;
end if;
end if;
end if;
Global_Archives_Built.Set
(Name_Id (For_Project.Path.Name),
(Checked => True,
Has_Been_Built => Has_Been_Built,
Exists => Exists));
end if;
end if;
end Build_Global_Archive;
---------------------
-- Display_Command --
---------------------
procedure Display_Command
(Name : String;
Path : String_Access;
Ellipse : Boolean := False)
is
Display_Ellipse : Boolean := Ellipse;
begin
-- Only display the command in Verbose Mode (-v) or when
-- not in Quiet Output (no -q).
if not Opt.Quiet_Output then
-- In Verbose Mode output the full path of the spawned process
if Opt.Verbose_Mode then
Write_Str (Path.all);
elsif Executable_Suffix'Length > 0
and then Name'Length > Executable_Suffix'Length
then
Name_Len := Name'Length;
Name_Buffer (1 .. Name_Len) := Name;
if Name_Buffer
(Name_Len - Executable_Suffix'Length + 1 .. Name_Len) =
Executable_Suffix.all
then
Name_Len := Name_Len - Executable_Suffix'Length;
end if;
Put (Base_Name (Name_Buffer (1 .. Name_Len)));
else
Write_Str (Base_Name (Name));
end if;
-- Display only the arguments for which the display flag is set
-- (in Verbose Mode, the display flag is set for all arguments)
for Arg in 1 .. Last_Argument loop
if Arguments_Displayed (Arg) then
Write_Char (' ');
if Arguments_Simple_Name (Arg) then
Write_Str (Base_Name (Arguments (Arg).all));
else
Write_Str (Arguments (Arg).all);
end if;
elsif Display_Ellipse then
Write_Str (" ...");
Display_Ellipse := False;
end if;
end loop;
Write_Eol;
end if;
end Display_Command;
------------------------
-- Get_Linker_Options --
------------------------
procedure Get_Linker_Options (For_Project : Project_Id) is
Linker_Lib_Dir_Option : String_Access;
Linker_Lib_Name_Option : String_Access;
procedure Recursive_Add
(Proj : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Boolean);
-- The recursive routine used to add linker options
-------------------
-- Recursive_Add --
-------------------
procedure Recursive_Add
(Proj : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Boolean)
is
pragma Unreferenced (Dummy);
Linker_Package : Package_Id;
Options : Variable_Value;
begin
if Proj /= For_Project then
Linker_Package :=
Prj.Util.Value_Of
(Name => Name_Linker,
In_Packages => Proj.Decl.Packages,
Shared => Tree.Shared);
Options :=
Prj.Util.Value_Of
(Name => Name_Ada,
Index => 0,
Attribute_Or_Array_Name => Name_Linker_Options,
In_Package => Linker_Package,
Shared => Tree.Shared);
-- If attribute is present, add the project with
-- the attribute to table Linker_Opts.
if Options /= Nil_Variable_Value then
Linker_Opts.Increment_Last;
Linker_Opts.Table (Linker_Opts.Last) :=
(Project => Proj, Options => Options.Values);
end if;
end if;
end Recursive_Add;
procedure For_All_Projects is
new For_Every_Project_Imported (Boolean, Recursive_Add);
Dummy : Boolean := False;
-- Start of processing for Get_Linker_Options
begin
if For_Project.Config.Linker_Lib_Dir_Option = No_Name then
Linker_Lib_Dir_Option := new String'("-L");
else
Linker_Lib_Dir_Option :=
new String'
(Get_Name_String (For_Project.Config.Linker_Lib_Dir_Option));
end if;
if For_Project.Config.Linker_Lib_Name_Option = No_Name then
Linker_Lib_Name_Option := new String'("-l");
else
Linker_Lib_Name_Option :=
new String'
(Get_Name_String (For_Project.Config.Linker_Lib_Name_Option));
end if;
Linker_Opts.Init;
For_All_Projects
(For_Project, Project_Tree, Dummy, Imported_First => True);
for Index in reverse 1 .. Linker_Opts.Last loop
declare
Options : String_List_Id := Linker_Opts.Table (Index).Options;
Proj : constant Project_Id :=
Linker_Opts.Table (Index).Project;
Option : Name_Id;
Dir_Path : constant String :=
Get_Name_String (Proj.Directory.Display_Name);
begin
while Options /= Nil_String loop
Option :=
Project_Tree.Shared.String_Elements.Table (Options).Value;
Get_Name_String (Option);
-- Do not consider empty linker options
if Name_Len /= 0 then
-- Object files and -L switches specified with relative
-- paths must be converted to absolute paths.
if Name_Len > Linker_Lib_Dir_Option'Length
and then
Name_Buffer (1 .. Linker_Lib_Dir_Option'Length) =
Linker_Lib_Dir_Option.all
then
if Is_Absolute_Path
(Name_Buffer
(Linker_Lib_Dir_Option'Length + 1 .. Name_Len))
then
Add_Argument (Name_Buffer (1 .. Name_Len), True);
else
Add_Argument
(Linker_Lib_Dir_Option.all &
Dir_Path &
Directory_Separator &
Name_Buffer
(Linker_Lib_Dir_Option'Length + 1 .. Name_Len),
True);
end if;
elsif (Name_Len > Linker_Lib_Name_Option'Length
and then
Name_Buffer (1 .. Linker_Lib_Name_Option'Length) =
Linker_Lib_Name_Option.all)
or else
Name_Buffer (1) = '-'
or else
Is_Absolute_Path (Name_Buffer (1 .. Name_Len))
then
Add_Argument (Name_Buffer (1 .. Name_Len), True);
else
Add_Argument
(Dir_Path &
Directory_Separator &
Name_Buffer (1 .. Name_Len),
True,
Simple_Name => True);
end if;
end if;
Options :=
Project_Tree.Shared.String_Elements.Table (Options).Next;
end loop;
end;
end loop;
end Get_Linker_Options;
---------------------------
-- Is_In_Library_Project --
---------------------------
function Is_In_Library_Project (Object_Path : String) return Boolean is
Path_Id : constant Path_Name_Type := Create_Name (Object_Path);
Src : Source_Id;
Iter : Source_Iterator;
begin
Iter := For_Each_Source (Project_Tree);
loop
Src := Prj.Element (Iter);
exit when Src = No_Source;
if Src.Object_Path = Path_Id then
return Src.Project.Library;
end if;
Next (Iter);
end loop;
return False;
end Is_In_Library_Project;
------------------------
-- Rpaths_Relative_To --
------------------------
procedure Rpaths_Relative_To
(Exec_Dir : Path_Name_Type;
Origin : Name_Id)
is
Exec : String :=
Normalize_Pathname
(Get_Name_String (Exec_Dir),
Case_Sensitive => False);
Last_Exec : Positive;
Curr_Exec : Positive;
Last_Path : Positive;
Curr_Path : Positive;
Nmb : Natural;
Origin_Name : constant String := Get_Name_String (Origin);
begin
-- Replace all directory separators with '/' to ease search
if Directory_Separator /= '/' then
for J in Exec'Range loop
if Exec (J) = Directory_Separator then
Exec (J) := '/';
end if;
end loop;
end if;
for Npath in 1 .. Rpaths.Last loop
declare
Insensitive_Path : String :=
Normalize_Pathname
(Rpaths.Table (Npath).all,
Case_Sensitive => False);
Path : constant String :=
Normalize_Pathname (Rpaths.Table (Npath).all);
begin
-- Replace all directory separators with '/' to ease search
if Directory_Separator /= '/' then
for J in Insensitive_Path'Range loop
if Insensitive_Path (J) = Directory_Separator then
Insensitive_Path (J) := '/';
end if;
end loop;
end if;
-- Find the number of common directories between the path and the
-- exec directory.
Nmb := 0;
Curr_Path := Insensitive_Path'First;
Curr_Exec := Exec'First;
loop
exit when
Curr_Path > Insensitive_Path'Last
or else Curr_Exec > Exec'Last
or else Insensitive_Path (Curr_Path) /= Exec (Curr_Exec);
if Insensitive_Path (Curr_Path) = '/' then
Nmb := Nmb + 1;
Last_Path := Curr_Path;
Last_Exec := Curr_Exec;
elsif Curr_Exec = Exec'Last
and then Curr_Path > Insensitive_Path'Last
then
Nmb := Nmb + 1;
Last_Path := Curr_Path + 1;
Last_Exec := Curr_Exec + 1;
exit;
end if;
Curr_Path := Curr_Path + 1;
Curr_Exec := Curr_Exec + 1;
end loop;
-- If there is more than one common directories (the root
-- directory does not count), then change the absolute path to a
-- relative path.
if Nmb > 1 then
Nmb := 0;
for J in Last_Exec .. Exec'Last - 1 loop
if Exec (J) = '/' then
Nmb := Nmb + 1;
end if;
end loop;
if Nmb = 0 then
if Last_Path >= Path'Last then
-- Case of the path being the exec dir
Rpaths.Table (Npath) :=
new String'(Origin_Name & Directory_Separator & ".");
else
-- Case of the path being a subdir of the exec dir
Rpaths.Table (Npath) :=
new String'
(Origin_Name & Directory_Separator &
Path (Last_Path + 1 .. Path'Last));
end if;
else
if Last_Path >= Path'Last then
-- Case of the exec dir being a subdir of the path
Rpaths.Table (Npath) :=
new String'
(Origin_Name & Directory_Separator &
(Nmb - 1) * (".." & Directory_Separator) & "..");
else
-- General case of path and exec dir having a common root
Rpaths.Table (Npath) :=
new String'
(Origin_Name & Directory_Separator &
Nmb * (".." & Directory_Separator) &
Path (Last_Path + 1 .. Path'Last));
end if;
end if;
end if;
end;
end loop;
end Rpaths_Relative_To;
---------------
-- Link_Main --
---------------
procedure Link_Main (Main_File : Main_Info) is
function Global_Archive_Name (For_Project : Project_Id) return String;
-- Returns the name of the global archive for a project
Linker_Name : String_Access := null;
Linker_Path : String_Access;
Min_Linker_Opts : Name_List_Index;
Exchange_File : Text_IO.File_Type;
Line : String (1 .. 1_000);
Last : Natural;
-- Success : Boolean := False;
Section : Binding_Section := No_Binding_Section;
Linker_Needs_To_Be_Called : Boolean;
Executable_TS : Time_Stamp_Type;
Main_Object_TS : Time_Stamp_Type;
Binder_Exchange_TS : Time_Stamp_Type;
Binder_Object_TS : Time_Stamp_Type := Dummy_Time_Stamp;
Global_Archive_TS : Time_Stamp_Type;
Global_Archive_Has_Been_Built : Boolean;
Global_Archive_Exists : Boolean;
OK : Boolean;
Disregard : Boolean;
B_Data : Binding_Data;
-- Main already has the right canonical casing
Main : constant String := Get_Name_String (Main_File.File);
Main_Source : constant Source_Id := Main_File.Source;
Main_Id : File_Name_Type;
Exec_Name : File_Name_Type;
Exec_Path_Name : Path_Name_Type;
Main_Proj : Project_Id;
Main_Base_Name_Index : File_Name_Type;
First_Object_Index : Natural := 0;
Last_Object_Index : Natural := 0;
Index_Separator : Character;
Response_File_Name : Path_Name_Type := No_Path;
Response_2 : Path_Name_Type := No_Path;
-------------------------
-- Global_Archive_Name --
-------------------------
function Global_Archive_Name (For_Project : Project_Id) return String is
begin
return
"lib" &
Get_Name_String (For_Project.Name) &
Archive_Suffix (For_Project);
end Global_Archive_Name;
begin
-- Make sure that the table Rpaths is emptied after each main, so
-- that the same rpaths are not duplicated.
Rpaths.Set_Last (0);
Linker_Needs_To_Be_Called := Opt.Force_Compilations;
Main_Id := Create_Name (Base_Name (Main));
Main_Proj := Ultimate_Extending_Project_Of (Main_Source.Project);
Change_To_Object_Directory (Main_Proj);
-- Build the global archive for this project, if needed
Build_Global_Archive
(Main_Proj,
Main_File.Tree,
Global_Archive_Has_Been_Built,
Global_Archive_Exists,
OK);
if not OK then
Stop_Spawning := True;
Bad_Processes.Append (Main_File);
return;
end if;
-- Get the main base name
Index_Separator :=
Main_Source.Language.Config.Multi_Unit_Object_Separator;
Main_Base_Name_Index :=
Base_Name_Index_For (Main, Main_File.Index, Index_Separator);
if not Linker_Needs_To_Be_Called and then Opt.Verbose_Mode then
Write_Str (" Checking executable for ");
Write_Str (Get_Name_String (Main_Source.File));
Write_Line (" ...");
end if;
if Output_File_Name /= null then
Name_Len := 0;
Add_Str_To_Name_Buffer (Output_File_Name.all);
Exec_Name := Name_Find;
else
Exec_Name := Executable_Of
(Project => Main_Proj,
Shared => Main_File.Tree.Shared,
Main => Main_Id,
Index => Main_Source.Index,
Ada_Main => False,
Language => Get_Name_String (Main_Source.Language.Name));
end if;
if Main_Proj.Exec_Directory = Main_Proj.Object_Directory then
Exec_Path_Name := Path_Name_Type (Exec_Name);
else
Get_Name_String (Main_Proj.Exec_Directory.Display_Name);
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Directory_Separator;
Add_Str_To_Name_Buffer (Get_Name_String (Exec_Name));
Exec_Path_Name := Name_Find;
end if;
Executable_TS := File_Stamp (Exec_Path_Name);
if not Linker_Needs_To_Be_Called
and then Executable_TS = Empty_Time_Stamp
then
Linker_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Line (" -> executable does not exist");
end if;
end if;
-- Get the path of the linker driver
if Main_Proj.Config.Linker /= No_Path then
Linker_Name := new String'(Get_Name_String (Main_Proj.Config.Linker));
Linker_Path := Locate_Exec_On_Path (Linker_Name.all);
if Linker_Path = null then
Fail_Program
(Main_File.Tree,
"unable to find linker " & Linker_Name.all);
end if;
else
Fail_Program
(Main_File.Tree,
"no linker specified and " &
"no default linker in the configuration");
end if;
Last_Argument := 0;
Initialize_Source_Record (Main_Source);
Main_Object_TS := File_Stamp (File_Name_Type (Main_Source.Object_Path));
if not Linker_Needs_To_Be_Called then
if Main_Object_TS = Empty_Time_Stamp then
if Opt.Verbose_Mode then
Write_Line (" -> main object does not exist");
end if;
Linker_Needs_To_Be_Called := True;
elsif String (Main_Object_TS) > String (Executable_TS) then
if Opt.Verbose_Mode then
Write_Line
(" -> main object more recent than executable");
end if;
Linker_Needs_To_Be_Called := True;
end if;
end if;
if Main_Object_TS = Empty_Time_Stamp then
Write_Str ("main object for ");
Write_Str (Get_Name_String (Main_Source.File));
Write_Line (" does not exist");
Record_Failure (Main_File);
return;
end if;
if Main_Proj = Main_Source.Object_Project then
Add_Argument (Get_Name_String (Main_Source.Object), True);
else
Add_Argument (Get_Name_String (Main_Source.Object_Path), True);
end if;
-- Add the Leading_Switches if there are any in package Linker
declare
The_Packages : constant Package_Id :=
Main_Proj.Decl.Packages;
Linker_Package : constant Prj.Package_Id :=
Prj.Util.Value_Of
(Name => Name_Linker,
In_Packages => The_Packages,
Shared => Main_File.Tree.Shared);
Switches : Variable_Value;
Switch_List : String_List_Id;
Element : String_Element;
begin
if Linker_Package /= No_Package then
declare
Switches_Array : constant Array_Element_Id :=
Prj.Util.Value_Of
(Name => Name_Leading_Switches,
In_Arrays =>
Main_File.Tree.Shared.Packages.Table
(Linker_Package).Decl.Arrays,
Shared => Main_File.Tree.Shared);
Option : String_Access;
begin
Switches :=
Prj.Util.Value_Of
(Index => Name_Id (Main_Id),
Src_Index => 0,
In_Array => Switches_Array,
Shared => Main_File.Tree.Shared);
if Switches = Nil_Variable_Value then
Switches :=
Prj.Util.Value_Of
(Index =>
Main_Source.Language.Name,
Src_Index => 0,
In_Array => Switches_Array,
Shared => Main_File.Tree.Shared,
Force_Lower_Case_Index => True);
end if;
if Switches = Nil_Variable_Value then
Switches :=
Prj.Util.Value_Of
(Index => All_Other_Names,
Src_Index => 0,
In_Array => Switches_Array,
Shared => Main_File.Tree.Shared,
Force_Lower_Case_Index => True);
end if;
case Switches.Kind is
when Undefined | Single =>
null;
when Prj.List =>
Switch_List := Switches.Values;
while Switch_List /= Nil_String loop
Element :=
Main_File.Tree.Shared.String_Elements.Table
(Switch_List);
Get_Name_String (Element.Value);
if Name_Len > 0 then
Option :=
new String'(Name_Buffer (1 .. Name_Len));
Add_Argument (Option.all, True);
end if;
Switch_List := Element.Next;
end loop;
end case;
end;
end if;
end;
Find_Binding_Languages (Main_File.Tree, Main_File.Project);
if Builder_Data (Main_File.Tree).There_Are_Binder_Drivers then
First_Object_Index := Last_Argument + 1;
Binding_Options.Init;
B_Data := Builder_Data (Main_File.Tree).Binding;
while B_Data /= null loop
declare
Exchange_File_Name : constant String :=
Binder_Exchange_File_Name
(Main_Base_Name_Index,
B_Data.Binder_Prefix).all;
begin
if Is_Regular_File (Exchange_File_Name) then
Binder_Exchange_TS :=
File_Stamp
(Path_Name_Type'(Create_Name
(Exchange_File_Name)));
if not Linker_Needs_To_Be_Called
and then
String (Binder_Exchange_TS) > String (Executable_TS)
then
Linker_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Str (" -> binder exchange file """);
Write_Str (Exchange_File_Name);
Write_Line (""" is more recent than executable");
end if;
end if;
Open (Exchange_File, In_File, Exchange_File_Name);
while not End_Of_File (Exchange_File) loop
Get_Line (Exchange_File, Line, Last);
if Last > 0 then
if Line (1) = '[' then
Section :=
Get_Binding_Section (Line (1 .. Last));
else
case Section is
when Generated_Object_File =>
Binder_Object_TS :=
File_Stamp
(Path_Name_Type'
(Create_Name
(Line (1 .. Last))));
Add_Argument
(Line (1 .. Last), Opt.Verbose_Mode);
when Bound_Object_Files =>
if Normalize_Pathname
(Line (1 .. Last),
Case_Sensitive => False) /=
Normalize_Pathname
(Get_Name_String
(Main_Source.Object_Path),
Case_Sensitive => False)
and then
not Is_In_Library_Project
(Line (1 .. Last))
then
Add_Argument
(Line (1 .. Last), Opt.Verbose_Mode);
end if;
when Resulting_Options =>
if Line (1 .. Last) /= "-static"
and then Line (1 .. Last) /= "-shared"
then
Binding_Options.Append
(new String'(Line (1 .. Last)));
end if;
when Gprexch.Run_Path_Option =>
if Opt.Run_Path_Option
and then
Main_Proj.Config.Run_Path_Option /=
No_Name_List
then
Add_Rpath (Line (1 .. Last));
Add_Rpath
(Shared_Libgcc_Dir
(Line (1 .. Last)));
end if;
when others =>
null;
end case;
end if;
end if;
end loop;
Close (Exchange_File);
if Binder_Object_TS = Empty_Time_Stamp then
if not Linker_Needs_To_Be_Called
and then Opt.Verbose_Mode
then
Write_Line
(" -> no binder generated object file");
end if;
Write_Str ("no binder generated object file for ");
Write_Line (Get_Name_String (Main_File.File));
Record_Failure (Main_File);
return;
elsif not Linker_Needs_To_Be_Called
and then
String (Binder_Object_TS) > String (Executable_TS)
then
Linker_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Line
(" -> binder generated object is more " &
"recent than executable");
end if;
end if;
else
Write_Str ("binder exchange file ");
Write_Str (Exchange_File_Name);
Write_Line (" does not exist");
Record_Failure (Main_File);
return;
end if;
end;
B_Data := B_Data.Next;
end loop;
Last_Object_Index := Last_Argument;
end if;
-- Add the global archive, if there is one
if Global_Archive_Exists then
Global_Archive_TS :=
File_Stamp
(Path_Name_Type'
(Create_Name (Global_Archive_Name (Main_Proj))));
if Global_Archive_TS = Empty_Time_Stamp then
if not Linker_Needs_To_Be_Called
and then Opt.Verbose_Mode
then
Write_Line (" -> global archive does not exist");
end if;
Write_Str ("global archive for project file ");
Write_Str (Get_Name_String (Main_Proj.Name));
Write_Line (" does not exist");
end if;
end if;
if not Linker_Needs_To_Be_Called
and then Global_Archive_Has_Been_Built
then
Linker_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Line (" -> global archive has just been built");
end if;
end if;
if not Linker_Needs_To_Be_Called
and then Global_Archive_Exists
and then String (Global_Archive_TS) > String (Executable_TS)
then
Linker_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Line (" -> global archive is more recent than " &
"executable");
end if;
end if;
-- Check if there are library files that are more recent than
-- executable.
declare
List : Project_List := Main_Proj.All_Imported_Projects;
Proj : Project_Id;
Current_Dir : constant String := Get_Current_Dir;
begin
while List /= null loop
Proj := List.Project;
List := List.Next;
if Proj.Extended_By = No_Project
and then Proj.Library
and then Proj.Object_Directory /= No_Path_Information
and then (Proj.Library_Kind = Static
or else Proj.Standalone_Library = No)
then
-- Put the full path name of the library file in Name_Buffer
Get_Name_String (Proj.Library_Dir.Display_Name);
if Proj.Library_Kind = Static then
Add_Str_To_Name_Buffer ("lib");
Add_Str_To_Name_Buffer (Get_Name_String (Proj.Library_Name));
if Proj.Config.Archive_Suffix = No_File then
Add_Str_To_Name_Buffer (".a");
else
Add_Str_To_Name_Buffer
(Get_Name_String (Proj.Config.Archive_Suffix));
end if;
else
-- Shared libraries
if Proj.Config.Shared_Lib_Prefix = No_File then
Add_Str_To_Name_Buffer ("lib");
else
Add_Str_To_Name_Buffer
(Get_Name_String (Proj.Config.Shared_Lib_Prefix));
end if;
Add_Str_To_Name_Buffer (Get_Name_String (Proj.Library_Name));
if Proj.Config.Shared_Lib_Suffix = No_File then
Add_Str_To_Name_Buffer (".so");
else
Add_Str_To_Name_Buffer
(Get_Name_String (Proj.Config.Shared_Lib_Suffix));
end if;
end if;
-- Check that library file exists and that it is not more
-- recent than the executable.
declare
Lib_TS : constant Time_Stamp_Type :=
File_Stamp (File_Name_Type'(Name_Find));
begin
if Lib_TS = Empty_Time_Stamp then
Linker_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Str (" -> library file """);
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Line (""" not found");
end if;
exit;
elsif String (Lib_TS) > String (Executable_TS) then
Linker_Needs_To_Be_Called := True;
if Opt.Verbose_Mode then
Write_Str (" -> library file """);
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Line
(""" is more recent than executable");
end if;
exit;
end if;
end;
end if;
end loop;
Change_Dir (Current_Dir);
end;
if not Linker_Needs_To_Be_Called then
if Opt.Verbose_Mode then
Write_Line (" -> up to date");
elsif not Opt.Quiet_Output then
Inform (Exec_Name, "up to date");
end if;
else
if Global_Archive_Exists then
Add_Argument (Global_Archive_Name (Main_Proj), Opt.Verbose_Mode);
end if;
-- Add the library switches, if there are libraries
Process_Imported_Libraries (Main_Proj, There_Are_SALs => Disregard);
Library_Dirs.Reset;
for J in reverse 1 .. Library_Projs.Last loop
if not Library_Projs.Table (J).Is_Aggregated then
if Library_Projs.Table (J).Proj.Library_Kind = Static then
Add_Argument
(Get_Name_String
(Library_Projs.Table (J).Proj.Library_Dir.Display_Name)
& "lib"
& Get_Name_String
(Library_Projs.Table (J).Proj.Library_Name)
& Archive_Suffix (Library_Projs.Table (J).Proj),
Opt.Verbose_Mode);
else
-- Do not issue several time the same -L switch if
-- several library projects share the same library
-- directory.
if not Library_Dirs.Get
(Library_Projs.Table (J).Proj.Library_Dir.Name)
then
Library_Dirs.Set
(Library_Projs.Table (J).Proj.Library_Dir.Name, True);
if Main_Proj.Config.Linker_Lib_Dir_Option = No_Name then
Add_Argument
("-L" &
Get_Name_String
(Library_Projs.Table (J).
Proj.Library_Dir.Display_Name),
Opt.Verbose_Mode);
else
Add_Argument
(Get_Name_String
(Main_Proj.Config.Linker_Lib_Dir_Option) &
Get_Name_String
(Library_Projs.Table (J).
Proj.Library_Dir.Display_Name),
Opt.Verbose_Mode);
end if;
if Opt.Run_Path_Option
and then
Main_Proj.Config.Run_Path_Option /= No_Name_List
and then
Library_Projs.Table (J).Proj.Library_Kind /= Static
then
Add_Rpath
(Get_Name_String
(Library_Projs.Table
(J).Proj.Library_Dir.Display_Name));
end if;
end if;
if Main_Proj.Config.Linker_Lib_Name_Option = No_Name then
Add_Argument
("-l" &
Get_Name_String
(Library_Projs.Table (J).Proj.Library_Name),
Opt.Verbose_Mode);
else
Add_Argument
(Get_Name_String
(Main_Proj.Config.Linker_Lib_Name_Option) &
Get_Name_String
(Library_Projs.Table (J).Proj.Library_Name),
Opt.Verbose_Mode);
end if;
end if;
end if;
end loop;
-- Put the options in the project file, if any
declare
The_Packages : constant Package_Id :=
Main_Proj.Decl.Packages;
Linker_Package : constant Prj.Package_Id :=
Prj.Util.Value_Of
(Name => Name_Linker,
In_Packages => The_Packages,
Shared => Main_File.Tree.Shared);
Switches : Variable_Value;
Switch_List : String_List_Id;
Element : String_Element;
begin
if Linker_Package /= No_Package then
declare
Defaults : constant Array_Element_Id :=
Prj.Util.Value_Of
(Name => Name_Default_Switches,
In_Arrays =>
Main_File.Tree.Shared.Packages.Table
(Linker_Package).Decl.Arrays,
Shared => Main_File.Tree.Shared);
Switches_Array : constant Array_Element_Id :=
Prj.Util.Value_Of
(Name => Name_Switches,
In_Arrays =>
Main_File.Tree.Shared.Packages.Table
(Linker_Package).Decl.Arrays,
Shared => Main_File.Tree.Shared);
Option : String_Access;
begin
Switches :=
Prj.Util.Value_Of
(Index => Name_Id (Main_Id),
Src_Index => 0,
In_Array => Switches_Array,
Shared => Main_File.Tree.Shared,
Allow_Wildcards => True);
if Switches = Nil_Variable_Value then
Switches :=
Prj.Util.Value_Of
(Index =>
Main_Source.Language.Name,
Src_Index => 0,
In_Array => Switches_Array,
Shared => Main_File.Tree.Shared,
Force_Lower_Case_Index => True);
end if;
if Switches = Nil_Variable_Value then
Switches :=
Prj.Util.Value_Of
(Index => All_Other_Names,
Src_Index => 0,
In_Array => Switches_Array,
Shared => Main_File.Tree.Shared,
Force_Lower_Case_Index => True);
end if;
if Switches = Nil_Variable_Value then
Switches :=
Prj.Util.Value_Of
(Index =>
Main_Source.Language.Name,
Src_Index => 0,
In_Array => Defaults,
Shared => Main_File.Tree.Shared);
end if;
case Switches.Kind is
when Undefined | Single =>
null;
when Prj.List =>
Switch_List := Switches.Values;
while Switch_List /= Nil_String loop
Element :=
Main_File.Tree.Shared.String_Elements.Table
(Switch_List);
Get_Name_String (Element.Value);
if Name_Len > 0 then
Option :=
new String'(Name_Buffer (1 .. Name_Len));
Test_If_Relative_Path
(Option,
Main_Project_Dir.all,
Dash_L);
Add_Argument (Option.all, True);
end if;
Switch_List := Element.Next;
end loop;
end case;
end;
end if;
end;
-- Get the Linker_Options, if any
Get_Linker_Options (For_Project => Main_Proj);
-- Add the linker switches specified on the command line
for J in 1 .. Command_Line_Linker_Options.Last loop
Add_Argument
(Command_Line_Linker_Options.Table (J), Opt.Verbose_Mode);
end loop;
-- Then the binding options
for J in 1 .. Binding_Options.Last loop
Add_Argument (Binding_Options.Table (J), Opt.Verbose_Mode);
end loop;
-- Then the required switches, if any. These are put here because,
-- if they include -L switches for example, the link may fail because
-- the wrong objects or libraries are linked in.
Min_Linker_Opts :=
Main_Proj.Config.Trailing_Linker_Required_Switches;
while Min_Linker_Opts /= No_Name_List loop
Add_Argument
(Get_Name_String
(Main_File.Tree.Shared.Name_Lists.Table
(Min_Linker_Opts).Name),
Opt.Verbose_Mode);
Min_Linker_Opts := Main_File.Tree.Shared.Name_Lists.Table
(Min_Linker_Opts).Next;
end loop;
-- Finally the Trailing_Switches if there are any in package Linker.
-- They are put here so that it is possible to override the required
-- switches from the configuration project file.
declare
The_Packages : constant Package_Id :=
Main_Proj.Decl.Packages;
Linker_Package : constant Prj.Package_Id :=
Prj.Util.Value_Of
(Name => Name_Linker,
In_Packages => The_Packages,
Shared => Main_File.Tree.Shared);
Switches : Variable_Value;
Switch_List : String_List_Id;
Element : String_Element;
begin
if Linker_Package /= No_Package then
declare
Switches_Array : constant Array_Element_Id :=
Prj.Util.Value_Of
(Name => Name_Trailing_Switches,
In_Arrays =>
Main_File.Tree.Shared.Packages.Table
(Linker_Package).Decl.Arrays,
Shared => Main_File.Tree.Shared);
Option : String_Access;
begin
Switches :=
Prj.Util.Value_Of
(Index => Name_Id (Main_Id),
Src_Index => 0,
In_Array => Switches_Array,
Shared => Main_File.Tree.Shared);
if Switches = Nil_Variable_Value then
Switches :=
Prj.Util.Value_Of
(Index =>
Main_Source.Language.Name,
Src_Index => 0,
In_Array => Switches_Array,
Shared => Main_File.Tree.Shared,
Force_Lower_Case_Index => True);
end if;
if Switches = Nil_Variable_Value then
Switches :=
Prj.Util.Value_Of
(Index => All_Other_Names,
Src_Index => 0,
In_Array => Switches_Array,
Shared => Main_File.Tree.Shared,
Force_Lower_Case_Index => True);
end if;
case Switches.Kind is
when Undefined | Single =>
null;
when Prj.List =>
Switch_List := Switches.Values;
while Switch_List /= Nil_String loop
Element :=
Main_File.Tree.Shared.String_Elements.Table
(Switch_List);
Get_Name_String (Element.Value);
if Name_Len > 0 then
Option :=
new String'(Name_Buffer (1 .. Name_Len));
Add_Argument (Option.all, True);
end if;
Switch_List := Element.Next;
end loop;
end case;
end;
end if;
end;
-- Remove duplicate stack size setting coming from pragmas
-- Linker_Options or Link_With and linker switches ("-Xlinker
-- --stack=R,C" or "-Wl,--stack=R"). Only the first stack size
-- setting option should be taken into account, because the one in
-- the project file or on the command line will always be the first
-- one. And any subsequent stack setting option will overwrite the
-- previous one.
Clean_Link_Option_Set : declare
J : Natural := Last_Object_Index + 1;
Stack_Op : Boolean := False;
begin
while J <= Last_Argument loop
-- Check for two switches "-Xlinker" followed by "--stack=..."
if Arguments (J).all = "-Xlinker"
and then J < Last_Argument
and then Arguments (J + 1)'Length > 8
and then Arguments (J + 1) (1 .. 8) = "--stack="
then
if Stack_Op then
Arguments (J .. Last_Argument - 2) :=
Arguments (J + 2 .. Last_Argument);
Last_Argument := Last_Argument - 2;
else
Stack_Op := True;
end if;
end if;
-- Check for single switch
if (Arguments (J)'Length > 17
and then Arguments (J) (1 .. 17) = "-Xlinker --stack=")
or else
(Arguments (J)'Length > 12
and then Arguments (J) (1 .. 12) = "-Wl,--stack=")
then
if Stack_Op then
Arguments (J .. Last_Argument - 1) :=
Arguments (J + 1 .. Last_Argument);
Last_Argument := Last_Argument - 1;
else
Stack_Op := True;
end if;
end if;
J := J + 1;
end loop;
end Clean_Link_Option_Set;
-- Look for the last switch -shared-libgcc or -static-libgcc and
-- remove all the others.
declare
Dash_Shared_Libgcc : Boolean := False;
Dash_Static_Libgcc : Boolean := False;
Arg : Natural;
procedure Remove_Argument;
-- Remove Arguments (Arg)
procedure Remove_Argument is
begin
Arguments (Arg .. Last_Argument - 1) :=
Arguments (Arg + 1 .. Last_Argument);
Last_Argument := Last_Argument - 1;
end Remove_Argument;
begin
Arg := Last_Argument;
loop
if Arguments (Arg).all = "-shared-libgcc" then
if Dash_Shared_Libgcc or Dash_Static_Libgcc then
Remove_Argument;
else
Dash_Shared_Libgcc := True;
end if;
elsif Arguments (Arg).all = "-static-libgcc" then
if Dash_Shared_Libgcc or Dash_Static_Libgcc then
Remove_Argument;
else
Dash_Static_Libgcc := True;
end if;
end if;
Arg := Arg - 1;
exit when Arg = 0;
end loop;
-- If -shared-libgcc was the last switch, then put in the
-- run path option the shared libgcc dir.
if Dash_Shared_Libgcc
and then Opt.Run_Path_Option
and then Main_Proj.Config.Run_Path_Option /= No_Name_List
then
-- Look for the adalib directory in -L switches.
-- If it is found, then add the shared libgcc
-- directory to the run path option.
for J in 1 .. Last_Argument loop
declare
Option : String (1 .. Arguments (J)'Length);
Last : Natural := Option'Last;
begin
Option := Arguments (J).all;
if Last > 2 and then Option (1 .. 2) = "-L" then
if Option (Last) = '/'
or else Option (Last) = Directory_Separator
then
Last := Last - 1;
end if;
if Last > 10
and then Option (Last - 5 .. Last) = "adalib"
then
Add_Rpath
(Shared_Libgcc_Dir (Option (3 .. Last)));
exit;
end if;
end if;
end;
end loop;
end if;
end;
-- Add the run path option, if necessary
if Opt.Run_Path_Option
and then Main_Proj.Config.Run_Path_Option /= No_Name_List
and then Rpaths.Last > 0
then
declare
Nam_Nod : Name_Node :=
Main_File.Tree.Shared.Name_Lists.Table
(Main_Proj.Config.Run_Path_Option);
Length : Natural := 0;
Arg : String_Access := null;
begin
if Main_Proj.Config.Run_Path_Origin /= No_Name
and then
Get_Name_String (Main_Proj.Config.Run_Path_Origin) /= ""
then
Rpaths_Relative_To
(Main_Proj.Exec_Directory.Display_Name,
Main_Proj.Config.Run_Path_Origin);
end if;
if Main_Proj.Config.Separate_Run_Path_Options then
for J in 1 .. Rpaths.Last loop
Nam_Nod := Main_File.Tree.Shared.Name_Lists.Table
(Main_Proj.Config.Run_Path_Option);
while Nam_Nod.Next /= No_Name_List loop
Add_Argument
(Get_Name_String (Nam_Nod.Name), True);
Nam_Nod := Main_File.Tree.Shared.Name_Lists.Table
(Nam_Nod.Next);
end loop;
Get_Name_String (Nam_Nod.Name);
Add_Str_To_Name_Buffer (Rpaths.Table (J).all);
Add_Argument
(Name_Buffer (1 .. Name_Len), Opt.Verbose_Mode);
end loop;
else
while Nam_Nod.Next /= No_Name_List loop
Add_Argument (Get_Name_String (Nam_Nod.Name), True);
Nam_Nod := Main_File.Tree.Shared.Name_Lists.Table
(Nam_Nod.Next);
end loop;
-- Compute the length of the argument
Get_Name_String (Nam_Nod.Name);
Length := Name_Len;
for J in 1 .. Rpaths.Last loop
Length := Length + Rpaths.Table (J)'Length + 1;
end loop;
Length := Length - 1;
-- Create the argument
Arg := new String (1 .. Length);
Length := Name_Len;
Arg (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
for J in 1 .. Rpaths.Last loop
if J /= 1 then
Length := Length + 1;
Arg (Length) := Path_Separator;
end if;
Arg (Length + 1 .. Length + Rpaths.Table (J)'Length)
:= Rpaths.Table (J).all;
Length := Length + Rpaths.Table (J)'Length;
end loop;
Add_Argument (Arg, Opt.Verbose_Mode);
end if;
end;
end if;
-- Add the map file option, if supported and requested
if Map_File /= null
and then Main_Proj.Config.Map_File_Option /= No_Name
then
Get_Name_String (Main_Proj.Config.Map_File_Option);
if Map_File'Length > 0 then
Add_Str_To_Name_Buffer (Map_File.all);
else
Add_Str_To_Name_Buffer
(Get_Name_String (Main_Base_Name_Index));
Add_Str_To_Name_Buffer (".map");
end if;
Add_Argument (Name_Buffer (1 .. Name_Len), Opt.Verbose_Mode);
end if;
-- Add the switch(es) to specify the name of the executable
declare
List : Name_List_Index :=
Main_Proj.Config.Linker_Executable_Option;
Nam : Name_Node;
procedure Add_Executable_Name;
-- Add the name of the executable to to current name buffer,
-- then the content of the name buffer as the next argument.
-------------------------
-- Add_Executable_Name --
-------------------------
procedure Add_Executable_Name is
begin
Add_Str_To_Name_Buffer (Get_Name_String (Exec_Path_Name));
Add_Argument
(Name_Buffer (1 .. Name_Len),
True,
Simple_Name => not Opt.Verbose_Mode);
end Add_Executable_Name;
begin
if List /= No_Name_List then
loop
Nam := Main_File.Tree.Shared.Name_Lists.Table (List);
Get_Name_String (Nam.Name);
if Nam.Next = No_Name_List then
Add_Executable_Name;
exit;
else
Add_Argument (Name_Buffer (1 .. Name_Len), True);
end if;
List := Nam.Next;
end loop;
else
Add_Argument ("-o", True);
Name_Len := 0;
Add_Executable_Name;
end if;
end;
-- If response file are supported, check the length of the
-- command line and the number of object files, then create
-- a response file if needed.
if Main_Proj.Config.Max_Command_Line_Length > 0
and then Main_Proj.Config.Resp_File_Format /= Prj.None
and then First_Object_Index > 0
then
declare
Arg_Length : Natural := 0;
Min_Number_Of_Objects : Natural := 0;
begin
for J in 1 .. Last_Argument loop
Arg_Length := Arg_Length + Arguments (J)'Length + 1;
end loop;
if Arg_Length > Main_Proj.Config.Max_Command_Line_Length then
if Main_Proj.Config.Resp_File_Options = No_Name_List then
Min_Number_Of_Objects := 0;
else
Min_Number_Of_Objects := 1;
end if;
-- Don't create a project file if there would not be
-- a smaller number of arguments.
if Last_Object_Index - First_Object_Index + 1 >
Min_Number_Of_Objects
then
declare
Resp_File_Options : String_List_Access :=
new String_List (1 .. 0);
List : Name_List_Index :=
Main_Proj.Config.
Resp_File_Options;
Nam_Nod : Name_Node;
begin
while List /= No_Name_List loop
Nam_Nod :=
Main_File.Tree.Shared.Name_Lists.Table (List);
Resp_File_Options :=
new String_List'
(Resp_File_Options.all
& new String'
(Get_Name_String (Nam_Nod.Name)));
List := Nam_Nod.Next;
end loop;
Create_Response_File
(Format =>
Main_Proj.Config.Resp_File_Format,
Objects => Arguments
(First_Object_Index .. Last_Object_Index),
Other_Arguments =>
Arguments (Last_Object_Index + 1 ..
Last_Argument),
Resp_File_Options => Resp_File_Options.all,
Name_1 => Response_File_Name,
Name_2 => Response_2);
if Main_Proj.Config.Resp_File_Format = GCC
or else
Main_Proj.Config.Resp_File_Format = GCC_GNU
or else
Main_Proj.Config.Resp_File_Format = GCC_Object_List
or else
Main_Proj.Config.Resp_File_Format = GCC_Option_List
then
Arguments (First_Object_Index) :=
new String'("@" &
Get_Name_String
(Response_File_Name));
Last_Argument := First_Object_Index;
else
-- Replace the first object file arguments
-- with the argument(s) specifying the
-- response file. No need to update
-- Arguments_Displayed, as the values are
-- already correct (= Verbose_Mode).
if Resp_File_Options'Length = 0 then
Arguments (First_Object_Index) :=
new String'(Get_Name_String
(Response_File_Name));
First_Object_Index := First_Object_Index + 1;
else
for J in Resp_File_Options'First ..
Resp_File_Options'Last - 1
loop
Arguments (First_Object_Index) :=
Resp_File_Options (J);
First_Object_Index :=
First_Object_Index + 1;
end loop;
Arguments (First_Object_Index) :=
new String'(Resp_File_Options
(Resp_File_Options'Last).all
&
Get_Name_String
(Response_File_Name));
First_Object_Index :=
First_Object_Index + 1;
end if;
-- And put the arguments following the object
-- files immediately after the response file
-- argument(s). Update Arguments_Displayed
-- too.
Arguments (First_Object_Index ..
Last_Argument -
Last_Object_Index +
First_Object_Index -
1) :=
Arguments (Last_Object_Index + 1 ..
Last_Argument);
Arguments_Displayed
(First_Object_Index ..
Last_Argument -
Last_Object_Index +
First_Object_Index -
1) :=
Arguments_Displayed
(Last_Object_Index + 1 ..
Last_Argument);
Last_Argument :=
Last_Argument - Last_Object_Index +
First_Object_Index - 1;
end if;
end;
end if;
end if;
end;
end if;
-- Delete an eventual executable, in case it is a symbolic
-- link as we don't want to modify the target of the link.
declare
Dummy : Boolean;
pragma Unreferenced (Dummy);
begin
Delete_File (Get_Name_String (Exec_Path_Name), Dummy);
end;
Display_Command (Linker_Name.all, Linker_Path);
declare
Pid : Process_Id;
begin
Pid := Non_Blocking_Spawn
(Linker_Path.all, Arguments (1 .. Last_Argument));
if Pid = Invalid_Pid then
Record_Failure (Main_File);
else
Add_Process
(Pid,
(Linking,
Pid,
Main_File,
Response_File_Name,
Response_2));
Display_Processes ("link");
end if;
end;
end if;
end Link_Main;
---------
-- Run --
---------
procedure Run is
Main : Main_Info;
procedure Do_Link (Project : Project_Id; Tree : Project_Tree_Ref);
procedure Await_Link;
procedure Wait_For_Available_Slot;
----------------
-- Await_Link --
----------------
procedure Await_Link is
Data : Process_Data;
OK : Boolean;
begin
loop
Await_Process (Data, OK);
if Data /= No_Process_Data then
if not OK then
Record_Failure (Data.Main);
elsif Data.Response_1 /= No_Path
and then not Debug.Debug_Flag_N
then
declare
Dont_Care : Boolean;
pragma Warnings (Off, Dont_Care);
begin
Delete_File
(Get_Name_String (Data.Response_1), Dont_Care);
if Data.Response_2 /= No_Path then
Delete_File
(Get_Name_String (Data.Response_2), Dont_Care);
end if;
end;
end if;
Display_Processes ("link");
return;
end if;
end loop;
end Await_Link;
-------------
-- Do_Link --
-------------
procedure Do_Link (Project : Project_Id; Tree : Project_Tree_Ref) is
pragma Unreferenced (Project);
Main_File : Main_Info;
begin
if Builder_Data (Tree).Need_Linking and then not Stop_Spawning then
Mains.Reset;
loop
Main_File := Mains.Next_Main;
exit when Main_File = No_Main_Info;
if Main_File.Tree = Tree
and then not Project_Compilation_Failed (Main_File.Project)
then
Wait_For_Available_Slot;
exit when Stop_Spawning;
Link_Main (Main_File);
exit when Stop_Spawning;
end if;
end loop;
end if;
end Do_Link;
procedure Link_All is new For_Project_And_Aggregated (Do_Link);
-----------------------------
-- Wait_For_Available_Slot --
-----------------------------
procedure Wait_For_Available_Slot is
begin
while Outstanding_Processes >= Opt.Maximum_Processes loop
Await_Link;
end loop;
end Wait_For_Available_Slot;
begin
Outstanding_Processes := 0;
Stop_Spawning := False;
Link_All (Main_Project, Project_Tree);
while Outstanding_Processes > 0 loop
Await_Link;
end loop;
if Bad_Processes.Last = 1 then
Main := Bad_Processes.Table (1);
Fail_Program
(Main.Tree,
"link of " & Get_Name_String (Main.File) & " failed");
elsif Bad_Processes.Last > 1 then
for J in 1 .. Bad_Processes.Last loop
Main := Bad_Processes.Table (J);
Write_Str (" link of ");
Write_Str (Get_Name_String (Main.File));
Write_Line (" failed");
end loop;
Fail_Program (Main.Tree, "*** link phase failed");
end if;
end Run;
end Gprbuild.Link;
gprbuild-gpl-2014-src/src/gprinstall-main.adb 0000644 0000767 0000145 00000064626 12323721731 020511 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R I N S T A L L . M A I N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Directories;
with Ada.Exceptions; use Ada.Exceptions;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.Command_Line; use GNAT.Command_Line;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Atree; use Atree;
with Csets;
with Gpr_Util; use Gpr_Util;
with GPR_Version; use GPR_Version;
with Hostparm;
with Makeutl; use Makeutl;
with Namet; use Namet;
with Osint; use Osint;
with Output; use Output;
with Prj.Conf; use Prj.Conf;
with Prj.Env;
with Prj.Err;
with Prj.Tree; use Prj.Tree;
with Snames; use Snames;
with Stringt;
with Switch; use Switch;
with Opt; use Opt;
with Types; use Types;
with Gprinstall.DB;
with Gprinstall.Install;
with Gprinstall.Uninstall;
procedure Gprinstall.Main is
use Gpr_Util.Knowledge;
-- Options specific to gprinstall
Build_Var_Option : constant String := "--build-var";
Build_Name_Option : constant String := "--build-name";
Install_Name_Option : constant String := "--install-name";
Uninstall_Option : constant String := "--uninstall";
Mode_Option : constant String := "--mode=";
Lib_Subdir_Option : constant String := "--lib-subdir";
Link_Lib_Subdir_Option : constant String := "--link-lib-subdir";
Exec_Subdir_Option : constant String := "--exec-subdir";
Sources_Subdir_Option : constant String := "--sources-subdir";
Project_Subdir_Option : constant String := "--project-subdir";
No_Lib_Link_Option : constant String := "--no-lib-link";
List_Option : constant String := "--list";
Stat_Option : constant String := "--stat";
procedure Initialize;
-- Do the necessary package intialization and process the command line
-- arguments.
procedure Usage;
-- Display the usage
procedure Scan_Arg
(Arg : String;
Command_Line : Boolean;
Success : out Boolean);
-- Process one gprinstall argument Arg. Command_Line is True if the
-- argument is specified on the command line. Optional parameter Additional
-- gives additional information about the origin of the argument if it is
-- found illegal.
procedure Copyright;
-- Output the Copyright notice
type Sigint_Handler is access procedure;
pragma Convention (C, Sigint_Handler);
procedure Install_Int_Handler (Handler : Sigint_Handler);
pragma Import (C, Install_Int_Handler, "__gnat_install_int_handler");
-- Called by Gnatmake to install the SIGINT handler below
procedure Sigint_Intercepted;
pragma Convention (C, Sigint_Intercepted);
-- Called when the program is interrupted by Ctrl-C to delete the
-- temporary mapping files and configuration pragmas files.
---------------
-- Copyright --
---------------
procedure Copyright is
begin
-- Only output the Copyright notice once
if not Copyright_Output then
Copyright_Output := True;
Display_Version
("GPRBUILD", "2012", Version_String => Gpr_Version_String);
end if;
end Copyright;
--------------
-- Scan_Arg --
--------------
procedure Scan_Arg
(Arg : String;
Command_Line : Boolean;
Success : out Boolean)
is
function Has_Prefix (Name : String) return Boolean;
-- Returns True if Arg start with Name
procedure Set_Param (P : in out Param; Name : String);
-- Set P with value for option Name
----------------
-- Has_Prefix --
----------------
function Has_Prefix (Name : String) return Boolean is
begin
pragma Assert (Arg'First = 1);
return Arg'Length >= Name'Length
and then Arg (1 .. Name'Length) = Name;
end Has_Prefix;
---------------
-- Set_Param --
---------------
procedure Set_Param (P : in out Param; Name : String) is
begin
P := (new String'
(Ensure_Directory (Arg (Name'Length + 2 .. Arg'Last))),
False);
end Set_Param;
Processed : Boolean := True;
begin
pragma Assert (Arg'First = 1);
Success := True;
if Arg'Length = 0 then
return;
end if;
-- 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
Fail_Program
(Project_Tree, "project file name missing after -P");
else
Project_File_Name_Expected := False;
Project_File_Name := new String'(Arg);
end if;
-- If preceding switch was -o, an executable name need to be
-- specified, not a switch.
elsif Search_Project_Dir_Expected then
if Arg (1) = '-' then
Fail_Program
(Project_Tree, "directory name missing after -aP");
else
Search_Project_Dir_Expected := False;
Prj.Env.Add_Directories (Root_Environment.Project_Path, Arg);
end if;
elsif Db_Directory_Expected then
Db_Directory_Expected := False;
Parse_Knowledge_Base (Project_Tree, Arg);
-- Set the processor/language for the following switches
-- Switches start with '-'
elsif Arg (1) = '-' then
if Has_Prefix (Source_Info_Option) then
Project_Tree.Source_Info_File_Name :=
new String'(Arg (Source_Info_Option'Length + 1 .. Arg'Last));
elsif Has_Prefix (Config_Project_Option) then
if Config_Project_File_Name /= null
and then (Autoconf_Specified
or else Config_Project_File_Name.all /=
Arg (Config_Project_Option'Length + 1 .. Arg'Last))
then
Fail_Program
(Project_Tree,
"several different configuration switches "
& "cannot be specified");
else
Autoconfiguration := False;
Autoconf_Specified := False;
Config_Project_File_Name :=
new String'
(Arg (Config_Project_Option'Length + 1 .. Arg'Last));
end if;
elsif Has_Prefix (Autoconf_Project_Option) then
if Hostparm.OpenVMS then
Fail_Program
(Project_Tree,
Autoconf_Project_Option & " cannot be used on VMS");
end if;
if Config_Project_File_Name /= null
and then (not Autoconf_Specified
or else Config_Project_File_Name.all /=
Arg (Autoconf_Project_Option'Length + 1 .. Arg'Last))
then
Fail_Program
(Project_Tree,
"several different configuration switches "
& "cannot be specified");
else
Config_Project_File_Name :=
new String'
(Arg (Autoconf_Project_Option'Length + 1 .. Arg'Last));
Autoconf_Specified := True;
end if;
elsif Arg = "-h" then
Usage_Needed := True;
elsif Arg = "-p" or else Arg = "--create-missing-dirs" then
Create_Dest_Dir := True;
elsif Arg'Length >= 2 and then Arg (2) = 'P' then
if Project_File_Name /= null then
Fail_Program
(Project_Tree,
"cannot have several project files specified");
elsif Arg'Length = 2 then
Project_File_Name_Expected := True;
else
Project_File_Name := new String'(Arg (3 .. Arg'Last));
end if;
elsif Arg'Length >= 3 and then Arg (1 .. 3) = "-aP" then
if Arg'Length = 3 then
Search_Project_Dir_Expected := True;
else
Prj.Env.Add_Directories
(Root_Environment.Project_Path, Arg (4 .. Arg'Last));
end if;
elsif Arg = "-q" then
Opt.Quiet_Output := True;
Opt.Verbose_Mode := False;
elsif Arg = "-r" then
Recursive := True;
elsif Arg = "-v" then
Opt.Verbose_Mode := True;
Opt.Quiet_Output := False;
elsif Arg = "-f" then
Force_Installations := True;
elsif Arg = "-a" then
All_Sources := True;
elsif Arg = "-d" then
Dry_Run := True;
elsif Arg'Length >= 3
and then Arg (2) = 'X'
and then Is_External_Assignment (Root_Environment, Arg)
then
-- Is_External_Assignment has side effects when it returns True
null;
elsif Arg'Length > 1 and then Arg (2) = '-' then
if Has_Prefix (Prefix_Project_Option) then
Set_Param (Global_Prefix_Dir, Prefix_Project_Option);
elsif Has_Prefix (Exec_Subdir_Option) then
Set_Param (Global_Exec_Subdir, Exec_Subdir_Option);
elsif Has_Prefix (Lib_Subdir_Option) then
Set_Param (Global_Lib_Subdir, Lib_Subdir_Option);
elsif Has_Prefix (Link_Lib_Subdir_Option) then
Set_Param (Global_Link_Lib_Subdir, Link_Lib_Subdir_Option);
elsif Has_Prefix (Sources_Subdir_Option) then
Set_Param (Global_Sources_Subdir, Sources_Subdir_Option);
elsif Has_Prefix (Project_Subdir_Option) then
Set_Param (Global_Project_Subdir, Project_Subdir_Option);
elsif Has_Prefix (Build_Var_Option) then
Build_Var := new String'
(Arg (Build_Var_Option'Length + 2 .. Arg'Last));
elsif Has_Prefix (Build_Name_Option) then
Free (Build_Name);
Build_Name := new String'
(Arg (Build_Name_Option'Length + 2 .. Arg'Last));
elsif Has_Prefix (Install_Name_Option) then
Free (Install_Name);
Install_Name := new String'
(Arg (Install_Name_Option'Length + 2 .. Arg'Last));
Install_Name_Default := False;
elsif Has_Prefix (Uninstall_Option) then
Usage_Mode := Uninstall_Mode;
elsif Has_Prefix (List_Option) then
Usage_Mode := List_Mode;
elsif Has_Prefix (Stat_Option) then
Output_Stats := True;
elsif Has_Prefix (Mode_Option) then
declare
Mode : String := Arg (Mode_Option'Length + 1 .. Arg'Last);
begin
To_Lower (Mode);
if Mode = "dev" then
For_Dev := True;
elsif Mode = "usage" then
For_Dev := False;
else
Processed := False;
end if;
end;
elsif Has_Prefix (Dry_Run_Option) then
Dry_Run := True;
elsif Has_Prefix (No_Lib_Link_Option) then
Add_Lib_Link := False;
elsif Has_Prefix (Subdirs_Option) then
Subdirs :=
new String'(Arg (Subdirs_Option'Length + 1 .. Arg'Last));
elsif Has_Prefix (Target_Project_Option) then
if Target_Name /= null then
if Target_Name.all /=
Arg (Target_Project_Option'Length + 1 .. Arg'Last)
then
Fail_Program
(Project_Tree,
"several different target switches "
& "cannot be specified");
end if;
else
Target_Name :=
new String'
(Arg (Target_Project_Option'Length + 1 .. Arg'Last));
end if;
else
Processed := False;
end if;
else
Processed := False;
end if;
elsif Command_Line then
-- The file name of a main or a project file
declare
File_Name : String := Arg;
begin
Canonical_Case_File_Name (File_Name);
if Usage_Mode = Uninstall_Mode
or else
(File_Name'Length > Project_File_Extension'Length
and then File_Name
(File_Name'Last - Project_File_Extension'Length + 1
.. File_Name'Last) = Project_File_Extension)
then
if Project_File_Name /= null then
Fail_Program
(Project_Tree,
"cannot have several project files specified");
else
Project_File_Name := new String'(File_Name);
end if;
else
-- Not a project file, then it is a main
Fail_Program (Project_Tree, "only project files expected");
end if;
end;
else
Processed := False;
end if;
if not Processed then
if Command_Line then
Fail_Program
(Project_Tree,
"illegal option """ & Arg & """ on the command line");
end if;
end if;
end Scan_Arg;
------------------------
-- Sigint_Intercepted --
------------------------
procedure Sigint_Intercepted is
begin
Write_Line ("*** Interrupted ***");
Delete_All_Temp_Files (Project_Tree.Shared);
OS_Exit (1);
end Sigint_Intercepted;
----------------
-- Initialize --
----------------
procedure Initialize is
procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
begin
-- Do some necessary package initializations
Csets.Initialize;
Namet.Initialize;
Snames.Initialize;
Stringt.Initialize;
Prj.Tree.Initialize (Root_Environment, Gprbuild_Flags);
Prj.Tree.Initialize (Project_Node_Tree);
Prj.Initialize (Project_Tree);
Mains.Delete;
-- Get the command line arguments, starting with --version and --help
Check_Version_And_Help
("GPRINSTALL", "2012", Version_String => Gpr_Version_String);
-- Now process the other options
Autoconfiguration := True;
declare
Do_Not_Care : Boolean;
begin
Scan_Args : for Next_Arg in 1 .. Argument_Count loop
Scan_Arg
(Argument (Next_Arg),
Command_Line => True,
Success => Do_Not_Care);
end loop Scan_Args;
end;
Mains.Set_Multi_Unit_Index (Project_Tree, Main_Index);
-- Target_Name has potentially been set when calling Scan_Arg, so we can
-- only initialize the project path after parsing the command line
-- arguments.
if Target_Name = null then
Prj.Env.Initialize_Default_Project_Path
(Root_Environment.Project_Path, Target_Name => "");
else
Prj.Env.Initialize_Default_Project_Path
(Root_Environment.Project_Path, Target_Name.all);
end if;
if Opt.Verbose_Mode then
Copyright;
end if;
if Usage_Needed then
Usage;
Usage_Needed := False;
end if;
-- Fail if command line ended with "-P"
if Project_File_Name_Expected then
Fail_Program
(Project_Tree, "project file name missing after -P");
elsif Search_Project_Dir_Expected then
Fail_Program
(Project_Tree, "directory name missing after -aP");
end if;
if Build_Name.all /= "default" and then Usage_Mode = Uninstall_Mode then
Fail_Program
(Project_Tree, "cannot specify --build-name in uninstall mode");
end if;
if Build_Var /= null and then Usage_Mode = Uninstall_Mode then
Fail_Program
(Project_Tree, "cannot specify --build-var in uninstall mode");
end if;
if Output_Stats and then Usage_Mode /= List_Mode then
Fail_Program
(Project_Tree, "cannot specify --stat in install/uninstall mode");
end if;
if Load_Standard_Base then
-- We need to parse the knowledge base so that we are able to
-- normalize the target names. Unfortunately, if we have to spawn
-- gprconfig, it will also have to parse that knowledge base on
-- its own.
Parse_Knowledge_Base (Project_Tree);
end if;
-- If no project file was specified, look first for a default
if Project_File_Name = null
and then Usage_Mode /= List_Mode
then
Try_Help;
Fail_Program (Project_Tree, "no project file specified");
end if;
-- Check prefix, if not specified set to default toolchain
if Global_Prefix_Dir.V = null then
-- Set to default for current toolchain
Global_Prefix_Dir := (new String'(Executable_Prefix_Path), True);
end if;
end Initialize;
-----------
-- Usage --
-----------
procedure Usage is
begin
if not Usage_Output then
Usage_Output := True;
Write_Str ("Usage: ");
Osint.Write_Program_Name;
Write_Str (" [-P] [.gpr] [opts]");
Write_Eol;
Write_Eol;
-- GPRINSTALL switches
Write_Str ("gprinstall switches:");
Write_Eol;
Display_Usage_Version_And_Help;
-- Line for Config_Project_Option
Write_Str (" ");
Write_Str (Config_Project_Option);
Write_Str ("file.cgpr");
Write_Eol;
Write_Str (" Specify the main config project file name");
Write_Eol;
-- Line for Autoconf_Project_Option
if not Hostparm.OpenVMS then
Write_Str (" ");
Write_Str (Autoconf_Project_Option);
Write_Str ("file.cgpr");
Write_Eol;
Write_Str
(" Specify/create the main config project file name");
Write_Eol;
end if;
-- Line for --prefix
Write_Line (" --prefix=");
Write_Line (" Install destination directory");
Write_Line (" --install-name=");
Write_Line (" The name of the installation");
Write_Line (" --sources-subdir=");
Write_Line (" The sources directory/sub-directory");
Write_Line (" --lib-subdir=");
Write_Line (" The library directory/sub-directory");
Write_Line (" --link-lib-subdir=");
Write_Line
(" The symlib directory/sub-directory to libraries");
Write_Line (" --exec-subdir=");
Write_Line (" The executbales directory/sub-directory");
Write_Line (" --project-subdir=");
Write_Line (" The project directory/sub-directory");
Write_Line (" --no-lib-link");
Write_Line
(" Do not copy shared lib in exec/lib directory");
-- Line for --subdirs=
Write_Line (" --subdirs=dir");
Write_Line (" Real obj/lib/exec dirs are subdirs");
-- Line for Target_Project_Option
Write_Str (" ");
Write_Str (Target_Project_Option);
Write_Str ("targetname");
Write_Eol;
Write_Str
(" Specify a target for cross platforms");
Write_Eol;
-- Line for --dry-run
Write_Line (" -d, --dry-run");
Write_Line (" Execute nothing, display commands");
-- Line for --build-var
Write_Line (" --build-var=");
Write_Line (" Name of the variable which identify a build");
-- Line for --build-name
Write_Line (" --build-name=");
Write_Line (" Build name value (default is ""Default"")");
-- Line for --mode
Write_Line (" --mode=[dev|usage]");
Write_Line
(" Kind of installation (default is ""dev"")");
-- Line for --uninstall
Write_Line (" --uninstall");
Write_Line
(" Remove all previously installed files");
-- Line for -aP
Write_Line (" -aP dir Add directory dir to project search path");
-- Line for -eL
Write_Line (" -eL "
& "Follow symbolic links when processing project files");
-- Line for -P
Write_Line (" -P proj Use Project File proj");
-- Line for -p
Write_Line (" -p, --create-missing-dirs");
Write_Line (" Create missing directories");
-- Line for -q
Write_Line (" -q Be quiet/terse");
-- Line for -r
Write_Line (" -r Recursive");
-- Line for -a
Write_Line (" -a Force copy of all sources");
-- Line for -f
Write_Line (" -f Force installaion, overwrite files");
-- Line for -v
Write_Line (" -v Verbose output");
-- Line for -X
Write_Line (" -Xnm=val Specify an external reference for "
& "Project Files");
Write_Eol;
end if;
end Usage;
User_Project_Node : Project_Node_Id;
begin
-- First initialize and read the command line arguments
Initialize;
-- And install Ctrl-C handler
Install_Int_Handler (Sigint_Intercepted'Unrestricted_Access);
-- Check command line arguments. These will be overridden when looking
-- for the configuration file
if Target_Name = null then
Target_Name := new String'("");
end if;
if Config_Project_File_Name = null then
Config_Project_File_Name := new String'("");
end if;
-- Then, parse the user's project and the configuration file. Apply the
-- configuration file to the project so that its settings are
-- automatically inherited by the project.
-- If either the project or the configuration file contains errors, the
-- following call with call Osint.Fail and never return
if Usage_Mode = Install_Mode then
begin
Parse_Project_And_Apply_Config
(Main_Project => Main_Project,
User_Project_Node => User_Project_Node,
Config_File_Name => Config_Project_File_Name.all,
Autoconf_Specified => Autoconf_Specified,
Project_File_Name => Project_File_Name.all,
Project_Tree => Project_Tree,
Env => Root_Environment,
Project_Node_Tree => Project_Node_Tree,
Packages_To_Check => Packages_To_Check,
Allow_Automatic_Generation => Autoconfiguration,
Automatically_Generated => Delete_Autoconf_File,
Config_File_Path => Configuration_Project_Path,
Target_Name => Target_Name.all,
Normalized_Hostname => Normalized_Hostname);
exception
when E : Prj.Conf.Invalid_Config =>
Osint.Fail (Exception_Message (E));
end;
if Main_Project = No_Project then
-- Don't flush messages in case of parsing error. This has already
-- been taken care when parsing the tree. Otherwise, it results in
-- the same message being displayed twice.
Fail_Program
(Project_Tree,
"""" & Project_File_Name.all & """ processing failed",
Flush_Messages => User_Project_Node /= Empty_Node);
end if;
if Configuration_Project_Path /= null then
Free (Config_Project_File_Name);
Config_Project_File_Name := new String'
(Base_Name (Configuration_Project_Path.all));
end if;
if Total_Errors_Detected > 0 then
Prj.Err.Finalize;
Fail_Program
(Project_Tree,
"problems while getting the configuration",
Flush_Messages => False);
end if;
Main_Project_Dir :=
new String'(Get_Name_String (Main_Project.Directory.Display_Name));
if Warnings_Detected > 0 then
Prj.Err.Finalize;
Prj.Err.Initialize;
end if;
Mains.Fill_From_Project (Main_Project, Project_Tree);
Compute_All_Imported_Projects (Main_Project, Project_Tree);
-- Source file lookups should be cached for efficiency.
-- Source files are not supposed to change.
Osint.Source_File_Data (Cache => True);
Install.Process (Project_Tree, Main_Project);
if Warnings_Detected /= 0 then
Prj.Err.Finalize;
end if;
elsif Usage_Mode = List_Mode then
DB.List;
else
if Install_Name = null then
Install_Name := new String'
(Ada.Directories.Base_Name (Project_File_Name.all));
end if;
Uninstall.Process (Install_Name.all);
end if;
Namet.Finalize;
if Usage_Mode = Install_Mode then
Finish_Program (Project_Tree, E_Success);
end if;
end Gprinstall.Main;
gprbuild-gpl-2014-src/src/gprbuild-compilation-process.ads 0000644 0000767 0000145 00000010624 12323721731 023216 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . C O M P I L A T I O N . P R O C E S S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- This package abstract out a process which can be either local or remote.
-- The communication with the remote instances are done through sockets.
with GNAT.OS_Lib;
package Gprbuild.Compilation.Process is
type Id is private;
type Remote_Id is mod 2 ** 64;
-- Represent a remote process id, this number is unique across all slaves.
-- Such number if created by the slaves using a slave id (unique number)
-- and a compilation number. Bother numbers are 32bits value:
--
-- 63 32 31 0
-- | [slave id] | [compilation number] |
Invalid_Process : constant Id;
function Create_Local (Pid : GNAT.OS_Lib.Process_Id) return Id;
-- Returns a local process for Pid
function Create_Remote (Pid : Remote_Id) return Id;
-- Returns a remote process (one running on a slave) for Pid
procedure Record_Environment
(Project : Project_Id;
Language : Name_Id;
Name, Value : String);
-- Record an environement variable to set when spawning a compilation. This
-- is for example to set CPATH if needed for the compilation of C sources.
function Run
(Executable : String;
Options : GNAT.OS_Lib.Argument_List;
Project : Project_Id;
Obj_Name : String;
Language : String := "";
Dep_Name : String := "";
Output_File : String := "";
Err_To_Out : Boolean := False;
Force_Local : Boolean := False) return Id;
-- Run Executable with the given options locally or on a remote slave.
-- Dep_File name is the name of the file that is expected to be generated
-- if the compilation is successful. If Force_Local is set then the
-- compilation will happen on the local machine.
function Get_Maximum_Processes return Positive;
-- The maximum number of simultaneous compilation supported. This is the
-- sum of the local parallelism and the sum of of remote slaves supported
-- processes.
-- For the hash table of jobs
type Header_Num is range 0 .. 2047;
function Hash (Process : Id) return Header_Num;
function Image (Pid : Remote_Id) return String;
-- Returns the string representation of Pid
procedure Record_Remote_Failure (Pid : Id; Slave : String);
-- This is to be able to display on which slaves a specific compilation has
-- failed.
function Get_Slave_For (Pid : Id) return String;
-- Returns the slave for the given compilation, or the empty string if the
-- compilation was successful or conducted locally.
private
type Process_Kind is (Local, Remote);
type Id (Kind : Process_Kind := Local) is record
case Kind is
when Local => Pid : Process_Id;
when Remote => R_Pid : Remote_Id;
end case;
end record;
Invalid_Process : constant Id := (Local, Pid => Invalid_Pid);
end Gprbuild.Compilation.Process;
gprbuild-gpl-2014-src/src/gprbuild-compilation-result.ads 0000644 0000767 0000145 00000004041 12323721731 023052 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . C O M P I L A T I O N . R E S U L T --
-- --
-- S p e c --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Gprbuild.Compilation.Process; use Gprbuild.Compilation.Process;
package Gprbuild.Compilation.Result is
procedure Add (Process : Id; Status : Boolean; Slave : String := "");
-- Add process Id with the given status into the list of results
procedure Wait (Process : out Id; Status : out Boolean);
-- Wait for a process to terminate (so a compilation process result) to be
-- available and returns the process Id and the corresponding status.
end Gprbuild.Compilation.Result;
gprbuild-gpl-2014-src/src/gprbuild-compilation-protocol.adb 0000644 0000767 0000145 00000061544 12323721731 023367 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . C O M P I L A T I O N . P R O T O C O L --
-- --
-- B o d y --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Directories; use Ada.Directories;
with Ada.Streams.Stream_IO;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps;
with GNAT.Rewrite_Data;
with GNAT.String_Split; use GNAT.String_Split;
with Gnatvsn; use Gnatvsn;
with Gpr_Util; use Gpr_Util;
package body Gprbuild.Compilation.Protocol is
Args_Sep : constant Character := '|';
-- Channel's argument separator
function Image (N : Natural) return String;
-- Returns string representation of N without leading space
procedure Send_File_Internal
(Channel : Communication_Channel;
Path_Name : String;
Cmd : Command_Kind);
-- Send file Path_Name over the channel with rewritting if needed
procedure Send_RAW_File_Content
(Channel : Communication_Channel;
Path_Name : String);
-- Send the file content untranslated
----------
-- Args --
----------
function Args (Cmd : Command) return Argument_List_Access is
begin
return Cmd.Args;
end Args;
-------------------
-- Clear_Rewrite --
-------------------
procedure Clear_Rewrite (Channel : in out Communication_Channel) is
begin
Channel.WD_From := Null_Unbounded_String;
Channel.WD_To := Null_Unbounded_String;
Channel.CD_From := Null_Unbounded_String;
Channel.CD_To := Null_Unbounded_String;
end Clear_Rewrite;
-----------
-- Close --
-----------
procedure Close (Channel : in out Communication_Channel) is
begin
begin
-- Make sure we never fail, the other end-point could have already
-- closed the channel (hard ctrl-c).
Shutdown_Socket (Channel.Sock);
exception
when others =>
null;
end;
Channel.Channel := null;
Clear_Rewrite (Channel);
end Close;
------------
-- Create --
------------
function Create (Sock : Socket_Type) return Communication_Channel is
begin
return Communication_Channel'
(Sock, Stream (Sock),
Null_Unbounded_String, Null_Unbounded_String,
Null_Unbounded_String, Null_Unbounded_String);
end Create;
-----------------
-- Get_Command --
-----------------
function Get_Command (Channel : Communication_Channel) return Command is
use Ada.Streams.Stream_IO;
function Handle_File (Cmd : Command) return Command;
-- A file has been recieved, write it to disk
function Handle_RAW_File (Cmd : Command) return Command;
-- A file has been recieved, write it to disk, no rewritte taking place
procedure Handle_Output (Cmd : in out Command);
-- A display output is received, read it and store it into the command
-----------------
-- Handle_File --
-----------------
function Handle_File (Cmd : Command) return Command is
File_Name : constant String :=
Translate_Receive (Channel, Cmd.Args (2).all);
Dir : constant String := Containing_Directory (File_Name);
procedure Input
(Item : out Stream_Element_Array;
Last : out Stream_Element_Offset);
-- Read and return some data from channel
procedure Output (Item : Stream_Element_Array);
-- Write data to file
Size : Stream_Element_Count :=
Stream_Element_Count'Value (Cmd.Args (1).all);
-- Number of bytes remaining to be read from channel
Rewriter : Rewrite_Data.Buffer :=
Rewrite_Data.Create
(To_String (Channel.WD_To),
To_String (Channel.WD_From));
Rewriter_CD : aliased Rewrite_Data.Buffer :=
Rewrite_Data.Create
(To_String (Channel.CD_To),
To_String (Channel.CD_From));
File : File_Type;
-----------
-- Input --
-----------
procedure Input
(Item : out Stream_Element_Array;
Last : out Stream_Element_Offset) is
begin
if Size = 0 then
Last := 0;
else
Last := Stream_Element_Count'Min (Item'Length, Size);
Stream_Element_Array'Read
(Channel.Channel, Item (Item'First .. Last));
Size := Size - Last;
end if;
end Input;
------------
-- Output --
------------
procedure Output (Item : Stream_Element_Array) is
begin
Write (File, Item);
end Output;
begin
Rewrite_Data.Link (Rewriter, Rewriter_CD'Unchecked_Access);
if Dir /= "" and then not Exists (Dir) then
Create_Directory (Dir);
end if;
Create (File, Out_File, File_Name);
Rewrite_Data.Rewrite (Rewriter, Input'Access, Output'Access);
Close (File);
return Get_Command (Channel);
end Handle_File;
---------------------
-- Handle_RAW_File --
---------------------
function Handle_RAW_File (Cmd : Command) return Command is
File_Name : constant String :=
Translate_Receive (Channel, Cmd.Args (1).all);
Dir : constant String := Containing_Directory (File_Name);
File : File_Type;
begin
if Dir /= "" and then not Exists (Dir) then
Create_Directory (Dir);
end if;
Create (File, Out_File, File_Name);
loop
declare
Data : constant Stream_Element_Array := Get_Raw_Data (Channel);
begin
exit when Data'Length = 0;
Write (File, Data);
end;
end loop;
Close (File);
return Get_Command (Channel);
end Handle_RAW_File;
-------------------
-- Handle_Output --
-------------------
procedure Handle_Output (Cmd : in out Command) is
function Is_Number (Cmd : Command) return Boolean is
(Is_Subset
(To_Set (Cmd.Args (1).all), Constants.Decimal_Digit_Set));
begin
if Cmd.Args'Length = 2
and then Is_Number (Cmd)
then
declare
Size : constant Natural :=
Natural'Value (Cmd.Args (1).all);
Result : String (1 .. Size);
begin
if Size = 0 then
Cmd.Output := Null_Unbounded_String;
else
String'Read (Channel.Channel, Result);
Cmd.Output := To_Unbounded_String (Result);
end if;
end;
else
raise Wrong_Command
with "Expected DP found " & Command_Kind'Image (Cmd.Cmd);
end if;
end Handle_Output;
Result : Command;
Args : Slice_Set;
begin
declare
Line : constant String := String'Input (Channel.Channel);
C : constant String :=
(if Line'Length >= 2
then Line (Line'First .. Line'First + 1)
else "");
begin
if C in
"EX" | "AK" | "TS" | "ES" | "FL" | "FR" | "OK" | "KO"
| "CX" | "CU" | "DP" | "EC"
then
Result.Cmd := Command_Kind'Value (C);
-- Slice arguments
Create
(Args,
Line (Line'First + 2 .. Line'Last),
String'(1 => Args_Sep));
Result.Args :=
new Argument_List (1 .. Integer (Slice_Count (Args)));
for K in Result.Args'Range loop
Result.Args (K) := new String'(Slice (Args, Slice_Number (K)));
end loop;
if Result.Cmd = FL then
-- We got some file data to write
return Handle_File (Result);
elsif Result.Cmd = FR then
return Handle_RAW_File (Result);
elsif Result.Cmd = DP then
-- We got an output to display
Handle_Output (Result);
end if;
else
if Line'Length > 0 then
raise Wrong_Command with Line;
else
raise Wrong_Command with "empty command line";
end if;
end if;
return Result;
end;
exception
when others =>
-- Any exception means that the channel has been closed
Result.Cmd := EC;
return Result;
end Get_Command;
-----------------
-- Get_Context --
-----------------
procedure Get_Context
(Channel : Communication_Channel;
Target : out Unbounded_String;
Project_Name : out Unbounded_String;
Build_Env : out Unbounded_String;
Sync : out Sync_Kind;
Timestamp : out Time_Stamp_Type;
Version : out Unbounded_String)
is
Line : constant Command := Get_Command (Channel);
begin
if Line.Cmd = CX
and then Line.Args'Length = 6
then
Target := To_Unbounded_String (Line.Args (1).all);
Project_Name := To_Unbounded_String (Line.Args (2).all);
Build_Env := To_Unbounded_String (Line.Args (3).all);
Sync := Sync_Kind'Value (Line.Args (4).all);
Timestamp := Time_Stamp_Type (Line.Args (5).all);
Version := To_Unbounded_String (Line.Args (6).all);
else
raise Wrong_Command
with "Expected CX found " & Command_Kind'Image (Line.Cmd);
end if;
end Get_Context;
-------------
-- Get_Pid --
-------------
procedure Get_Pid
(Channel : Communication_Channel;
Pid : out Process.Remote_Id;
Success : out Boolean)
is
Cmd : constant Command := Get_Command (Channel);
begin
if Cmd.Args'Length = 1
and then Cmd.Cmd in OK | KO
then
Pid := Process.Remote_Id'Value (Cmd.Args (1).all);
Success := (if Kind (Cmd) = KO then False);
end if;
end Get_Pid;
------------------
-- Get_Raw_Data --
------------------
function Get_Raw_Data
(Channel : Communication_Channel) return Stream_Element_Array is
begin
return Stream_Element_Array'Input (Channel.Channel);
end Get_Raw_Data;
-----------
-- Image --
-----------
function Image (N : Natural) return String is
N_Img : constant String := Natural'Image (N);
begin
return N_Img (N_Img'First + 1 .. N_Img'Last);
end Image;
----------
-- Kind --
----------
function Kind (Cmd : Command) return Command_Kind is
begin
return Cmd.Cmd;
end Kind;
------------
-- Output --
------------
function Output (Cmd : Command) return Unbounded_String is
begin
return Cmd.Output;
end Output;
--------------
-- Send_Ack --
--------------
procedure Send_Ack
(Channel : Communication_Channel; Pid : Process.Remote_Id) is
begin
String'Output
(Channel.Channel, Command_Kind'Image (AK) & Process.Image (Pid));
end Send_Ack;
-------------------
-- Send_Clean_Up --
-------------------
procedure Send_Clean_Up
(Channel : Communication_Channel; Project_Name : String) is
begin
String'Output
(Channel.Channel, Command_Kind'Image (CU) & Project_Name);
end Send_Clean_Up;
------------------
-- Send_Context --
------------------
procedure Send_Context
(Channel : Communication_Channel;
Target : String;
Project_Name : String;
Build_Env : String;
Sync : Sync_Kind) is
begin
String'Output
(Channel.Channel,
Command_Kind'Image (CX) & Target & Args_Sep & Project_Name
& Args_Sep & Build_Env
& Args_Sep & Sync_Kind'Image (Sync)
& Args_Sep & String (UTC_Time)
& Args_Sep & Gnat_Static_Version_String);
end Send_Context;
-----------------------------
-- Send_End_Of_Compilation --
-----------------------------
procedure Send_End_Of_Compilation (Channel : Communication_Channel) is
begin
String'Output (Channel.Channel, Command_Kind'Image (EC));
end Send_End_Of_Compilation;
---------------------------
-- Send_End_Of_File_List --
---------------------------
procedure Send_End_Of_File_List (Channel : Communication_Channel) is
begin
String'Output (Channel.Channel, Command_Kind'Image (ES));
end Send_End_Of_File_List;
---------------
-- Send_Exec --
---------------
procedure Send_Exec
(Channel : Communication_Channel;
Project : String;
Dir : String;
Command : String;
Options : Argument_List;
Obj_Name : String;
Dep_Name : String;
Env : String;
Filter : access function (Str, Sep : String) return String := null)
is
R_Cmd : Unbounded_String;
begin
-- Options are serialized into a string and separated with Opts_Sep
for K in Options'Range loop
if Filter /= null then
R_Cmd := R_Cmd & Filter (Options (K).all, WD_Path_Tag);
else
R_Cmd := R_Cmd & Options (K).all;
end if;
if K /= Options'Last then
R_Cmd := R_Cmd & Opts_Sep;
end if;
end loop;
-- Send the command over the channel
String'Output
(Channel.Channel,
Command_Kind'Image (EX)
& Filter (Project, WD_Path_Tag)
& Args_Sep & Dir & Args_Sep & Command
& Args_Sep & Obj_Name & Args_Sep & Dep_Name
& Args_Sep & To_String (R_Cmd)
& Args_Sep & Filter (Env, WD_Path_Tag));
end Send_Exec;
---------------
-- Send_File --
---------------
procedure Send_File
(Channel : Communication_Channel;
Path_Name : String;
Rewrite : Boolean) is
begin
if Rewrite then
Send_File_Internal (Channel, Path_Name, FL);
else
if Exists (Path_Name) then
String'Output
(Channel.Channel,
Command_Kind'Image (FR) & Translate_Send (Channel, Path_Name));
Send_RAW_File_Content (Channel, Path_Name);
end if;
end if;
end Send_File;
----------------
-- Sync_Files --
----------------
procedure Sync_Files
(Channel : Communication_Channel;
Root_Dir : String;
Files : File_Data_Set.Vector) is
begin
Create_Args : declare
Args : Unbounded_String;
First : Boolean := True;
begin
for F of Files loop
if First then
First := False;
else
Append (Args, Args_Sep);
end if;
Append (Args, F.Path_Name);
Append (Args, Args_Sep);
Append (Args, String (F.Timestamp));
end loop;
String'Output
(Channel.Channel,
Command_Kind'Image (TS) & To_String (Args));
end Create_Args;
declare
use Protocol;
Cmd : constant Command := Get_Command (Channel);
begin
if Kind (Cmd) = KO then
for Filename of Args (Cmd).all loop
Send_RAW_File_Content
(Channel,
(if Root_Dir = ""
then ""
else Root_Dir & Directory_Separator) & Filename.all);
end loop;
end if;
end;
end Sync_Files;
------------------------
-- Send_File_Internal --
------------------------
procedure Send_File_Internal
(Channel : Communication_Channel;
Path_Name : String;
Cmd : Command_Kind)
is
use Ada.Streams.Stream_IO;
procedure Input
(Item : out Stream_Element_Array; Last : out Stream_Element_Offset);
-- Get input data from file
procedure Output (Item : Stream_Element_Array);
-- Send data to channel
function File_Size return Natural;
-- Compute the size of the file as rewritten
File : File_Type;
F_Size : Natural;
Rewriter : Rewrite_Data.Buffer :=
Rewrite_Data.Create
(To_String (Channel.WD_From),
To_String (Channel.WD_To));
Rewriter_CD : aliased Rewrite_Data.Buffer :=
Rewrite_Data.Create
(To_String (Channel.CD_From),
To_String (Channel.CD_To));
---------------
-- File_Size --
---------------
function File_Size return Natural is
procedure Count (Item : Stream_Element_Array);
-- Count bytes
Result : Natural := Natural (Size (Path_Name));
-----------
-- Count --
-----------
procedure Count (Item : Stream_Element_Array) is
begin
Result := Result + Item'Length;
end Count;
begin
if Channel.WD_From /= Null_Unbounded_String
and then Length (Channel.WD_From) <= Result
then
Result := 0;
Rewrite_Data.Rewrite (Rewriter, Input'Access, Count'Access);
Reset (File);
end if;
return Result;
end File_Size;
-----------
-- Input --
-----------
procedure Input
(Item : out Stream_Element_Array; Last : out Stream_Element_Offset) is
begin
if End_Of_File (File) then
Last := 0;
else
Read (File, Item, Last);
end if;
end Input;
------------
-- Output --
------------
procedure Output (Item : Stream_Element_Array) is
begin
Stream_Element_Array'Write (Channel.Channel, Item);
end Output;
begin
Rewrite_Data.Link (Rewriter, Rewriter_CD'Unchecked_Access);
if Exists (Path_Name) then
Open (File, In_File, Path_Name);
-- First compute the file size as translated, note that this means
-- that we are parsing the file twice.
F_Size := File_Size;
String'Output
(Channel.Channel,
Command_Kind'Image (Cmd) & Image (F_Size)
& Args_Sep & Translate_Send (Channel, Path_Name));
if F_Size /= 0 then
Rewrite_Data.Rewrite (Rewriter, Input'Access, Output'Access);
end if;
Close (File);
else
raise Constraint_Error with "File not found : " & Path_Name;
end if;
end Send_File_Internal;
-------------
-- Send_Ko --
-------------
procedure Send_Ko
(Channel : Communication_Channel; Pid : Process.Remote_Id) is
begin
String'Output
(Channel.Channel, Command_Kind'Image (KO) & Process.Image (Pid));
end Send_Ko;
procedure Send_Ko (Channel : Communication_Channel) is
begin
String'Output (Channel.Channel, Command_Kind'Image (KO));
end Send_Ko;
procedure Send_Ko
(Channel : Communication_Channel;
Files : File_Data_Set.Vector)
is
Args : Unbounded_String;
First : Boolean := True;
begin
for F of Files loop
if First then
First := False;
else
Append (Args, Args_Sep);
end if;
Append (Args, To_String (F.Path_Name));
end loop;
String'Output
(Channel.Channel, Command_Kind'Image (KO) & To_String (Args));
end Send_Ko;
-------------
-- Send_Ok --
-------------
procedure Send_Ok
(Channel : Communication_Channel; Pid : Process.Remote_Id) is
begin
String'Output
(Channel.Channel, Command_Kind'Image (OK) & Process.Image (Pid));
end Send_Ok;
procedure Send_Ok (Channel : Communication_Channel) is
begin
String'Output (Channel.Channel, Command_Kind'Image (OK));
end Send_Ok;
-----------------
-- Send_Output --
-----------------
procedure Send_Output
(Channel : Communication_Channel; File_Name : String) is
begin
Send_File_Internal (Channel, File_Name, DP);
end Send_Output;
---------------------------
-- Send_RAW_File_Content --
---------------------------
procedure Send_RAW_File_Content
(Channel : Communication_Channel;
Path_Name : String)
is
use Ada;
type Buffer_Access is access Stream_Element_Array;
procedure Unchecked_Free is
new Unchecked_Deallocation (Stream_Element_Array, Buffer_Access);
Buffer : Buffer_Access;
Last : Stream_Element_Offset;
File : Stream_IO.File_Type;
begin
Buffer := new Stream_Element_Array (1 .. 2 * 1_024 * 1_024);
-- A somewhat large buffer is needed to transfer big file
-- efficiently. Here we use a 2Mb buffer which should be
-- large enough for read most file contents in one OS call.
--
-- This is allocated on the heap to avoid too much pressure on the
-- stack of the tasks.
-- Open the file in shared mode as multiple tasks could have
-- to send it.
Stream_IO.Open
(File, Stream_IO.In_File, Path_Name, Form => "shared=yes");
-- Always send an empty stream element array at the end.
-- This is used as EOF tag.
loop
Stream_IO.Read (File, Buffer.all, Last);
Stream_Element_Array'Output (Channel.Channel, Buffer (1 .. Last));
exit when Last = 0;
end loop;
Stream_IO.Close (File);
Unchecked_Free (Buffer);
end Send_RAW_File_Content;
-----------------------
-- Send_Slave_Config --
-----------------------
procedure Send_Slave_Config
(Channel : Communication_Channel;
Max_Process : Positive;
Root_Directory : String;
Clock_Status : Boolean) is
begin
String'Output
(Channel.Channel,
Command_Kind'Image (OK)
& Image (Max_Process)
& Args_Sep & Root_Directory
& Args_Sep & Boolean'Image (Clock_Status));
end Send_Slave_Config;
--------------------
-- Set_Rewrite_CD --
--------------------
procedure Set_Rewrite_CD
(Channel : in out Communication_Channel; Path : String) is
begin
Channel.CD_From := To_Unbounded_String (Normalize_Pathname (Path));
Channel.CD_To := To_Unbounded_String (CD_Path_Tag);
end Set_Rewrite_CD;
--------------------
-- Set_Rewrite_WD --
--------------------
procedure Set_Rewrite_WD
(Channel : in out Communication_Channel; Path : String) is
begin
Channel.WD_From := To_Unbounded_String (Path);
Channel.WD_To := To_Unbounded_String (WD_Path_Tag);
end Set_Rewrite_WD;
----------
-- Sock --
----------
function Sock (Channel : Communication_Channel) return Socket_Type is
begin
return Channel.Sock;
end Sock;
-----------------------
-- Translate_Receive --
-----------------------
function Translate_Receive
(Channel : Communication_Channel; Str : String) return String
is
P : constant Natural := Index (Str, To_String (Channel.WD_To));
begin
if P = 0 then
return Str;
else
return To_String (Channel.WD_From)
& Str (P + Length (Channel.WD_To) .. Str'Last);
end if;
end Translate_Receive;
--------------------
-- Translate_Send --
--------------------
function Translate_Send
(Channel : Communication_Channel; Str : String) return String
is
P : constant Natural := Index (Str, To_String (Channel.WD_From));
begin
if P = 0 then
return Str;
else
return To_String (Channel.WD_To)
& Str (P + Length (Channel.WD_From) .. Str'Last);
end if;
end Translate_Send;
end Gprbuild.Compilation.Protocol;
gprbuild-gpl-2014-src/src/gprinstall.adb 0000644 0000767 0000145 00000003557 12323721731 017563 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R I N S T A L L . M A I N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
package body Gprinstall is
---------
-- Dup --
---------
function Dup (P : Param) return Param is
begin
return (new String'(P.V.all), P.Default);
end Dup;
----------
-- Free --
----------
procedure Free (P : in out Param) is
begin
Free (P.V);
end Free;
end Gprinstall;
gprbuild-gpl-2014-src/src/gprconfig-main.adb 0000644 0000767 0000145 00000052122 12323721731 020274 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R C O N F I G --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Command_Line;
with Ada.Containers; use Ada.Containers;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Command_Line; use GNAT.Command_Line;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GprConfig.Knowledge; use GprConfig.Knowledge;
with GprConfig.Sdefault;
with GPR_Version;
with Hostparm;
with Namet; use Namet;
with Opt;
with Prj; use Prj;
with Switch;
procedure GprConfig.Main is
Default_Output_File : constant String := "default.cgpr";
-- Name of the configuration file used by gprbuild by default
-- ??? Should be shared with gprbuild
Output_File : Unbounded_String := To_Unbounded_String (Default_Output_File);
Selected_Target : Unbounded_String;
-- Value of --target switch
Target_Specified : Boolean := False;
Selected_Targets_Set : Targets_Set_Id;
-- Targets set id for the selected target
Opt_Validate : Boolean := False;
-- Whether we should validate the contents of the knowledge base
use Compiler_Lists;
procedure Help (Base : Knowledge_Base);
-- Display list of switches
procedure Usage;
-- Display list of options, no specific to current invocation, to be used
-- when switch --help is used.
procedure Check_Version_And_Help is
new Switch.Check_Version_And_Help_G (Usage);
procedure Display_Compilers_For_Parser
(Base : in out Knowledge_Base;
Compilers : in out Compiler_Lists.List);
-- Display the list of found compilers for use by an external parser
procedure Select_Compilers_Interactively
(Base : in out Knowledge_Base;
Compilers : in out Compiler_Lists.List);
-- Ask the user for compilers to be selected
procedure Show_Command_Line_Config (Compilers : Compiler_Lists.List);
-- Display the batch command line that would have the same effect as the
-- current selection of compilers.
type Boolean_Array is array (Count_Type range <>) of Boolean;
type All_Iterator (Count : Count_Type) is new Compiler_Iterator with
record
Filter_Matched : Boolean_Array (1 .. Count) := (others => False);
Filters : Compiler_Lists.List;
Compilers : Compiler_Lists.List;
end record;
procedure Callback
(Iterator : in out All_Iterator;
Base : in out Knowledge_Base;
Comp : Compiler;
From_Extra_Dir : Boolean;
Continue : out Boolean);
-- Search all compilers on path, preselecting the first one matching each
-- of the filters.
Base : Knowledge_Base;
Filters : Compiler_Lists.List;
Load_Standard_Base : Boolean := True;
Batch : Boolean := False;
Show_Targets : Boolean := False;
Show_Compilers : Boolean := False;
Compilers : Compiler_Lists.List;
package Compiler_Sort is
new Compiler_Lists.Generic_Sorting (Display_Before);
Valid_Switches : constant String :=
"-batch -config= -db: h o: v q -show-targets"
& " -validate -mi-show-compilers -target=";
--------------
-- Callback --
--------------
procedure Callback
(Iterator : in out All_Iterator;
Base : in out Knowledge_Base;
Comp : Compiler;
From_Extra_Dir : Boolean;
Continue : out Boolean)
is
New_Comp : Compiler := Comp;
C : Compiler_Lists.Cursor;
Index : Count_Type := 1;
begin
if Iterator.Filter_Matched /=
(Iterator.Filter_Matched'Range => True)
then
C := First (Iterator.Filters);
while Has_Element (C) loop
if not Iterator.Filter_Matched (Index)
and then Filter_Match
(Base, Comp => Comp, Filter => Element (C).all)
then
Set_Selection (New_Comp, True);
Iterator.Filter_Matched (Index) := True;
exit;
end if;
Index := Index + 1;
Next (C);
end loop;
end if;
-- Ignore compilers from extra directories, unless they have been
-- selected because of a --config argument
if Is_Selected (New_Comp) or else not From_Extra_Dir then
Put_Verbose
("Adding compiler to interactive menu "
& To_String (Base, Comp, True)
& " selected=" & Is_Selected (New_Comp)'Img);
Append (Iterator.Compilers, new Compiler'(New_Comp));
end if;
Continue := True;
end Callback;
----------
-- Help --
----------
procedure Help (Base : Knowledge_Base) is
Known : Unbounded_String;
begin
Known_Compiler_Names (Base, Known);
Usage;
Put_Line (" The known compilers are: " & To_String (Known));
end Help;
----------------------------------
-- Display_Compilers_For_Parser --
----------------------------------
procedure Display_Compilers_For_Parser
(Base : in out Knowledge_Base;
Compilers : in out Compiler_Lists.List)
is
Comp : Compiler_Lists.Cursor := First (Compilers);
Count : constant Integer := Integer (Length (Compilers));
Choices : array (1 .. Count) of Compiler_Lists.Cursor;
begin
for C in Choices'Range loop
Choices (C) := Comp;
Next (Comp);
end loop;
Filter_Compilers_List (Base, Compilers, Selected_Targets_Set);
Put
(To_String
(Base,
Compilers,
Selected_Only => False,
Show_Target => True,
Parser_Friendly => True));
end Display_Compilers_For_Parser;
------------------------------------
-- Select_Compilers_Interactively --
------------------------------------
procedure Select_Compilers_Interactively
(Base : in out Knowledge_Base;
Compilers : in out Compiler_Lists.List)
is
Comp : Compiler_Lists.Cursor := First (Compilers);
Tmp : Natural;
Choice : Natural;
Line : String (1 .. 1024);
Count : constant Integer := Integer (Length (Compilers));
Choices : array (1 .. Count) of Compiler_Lists.Cursor;
begin
for C in Choices'Range loop
Choices (C) := Comp;
Next (Comp);
end loop;
loop
Filter_Compilers_List (Base, Compilers, Selected_Targets_Set);
Put_Line ("--------------------------------------------------");
Put_Line
("gprconfig has found the following compilers on your PATH.");
Put_Line
("Only those matching the target and the selected compilers"
& " are displayed.");
Put (To_String
(Base, Compilers, Selected_Only => False,
Show_Target => Selected_Targets_Set = All_Target_Sets));
Put
("Select or unselect the following compiler (or ""s"" to save): ");
Get_Line (Line, Tmp);
exit when Tmp = 1 and then Line (1) = 's';
if Tmp = 0 then
Choice := 0;
else
begin
Choice := Natural'Value (Line (1 .. Tmp));
if Choice > Choices'Last then
Choice := 0;
end if;
exception
when Constraint_Error =>
Choice := 0;
end;
end if;
if Choice = 0 then
Put_Line ("Unrecognized choice");
else
Set_Selection
(Compilers, Choices (Choice),
not Is_Selected (Element (Choices (Choice)).all));
end if;
end loop;
end Select_Compilers_Interactively;
------------------------------
-- Show_Command_Line_Config --
------------------------------
procedure Show_Command_Line_Config (Compilers : Compiler_Lists.List) is
C : Compiler_Lists.Cursor;
begin
if not Is_Empty (Compilers) then
New_Line;
Put_Line ("You can regenerate the same config file in batch mode");
Put_Line (" with the following command line:");
Put ("gprconfig --batch");
Put (" --target=");
if Selected_Target = Null_Unbounded_String then
Put ("all");
else
Put (To_String (Selected_Target));
end if;
C := First (Compilers);
while Has_Element (C) loop
if Is_Selected (Element (C).all) then
Put (" --config="
& To_String
(Base, Element (C).all, As_Config_Arg => True));
end if;
Next (C);
end loop;
New_Line;
New_Line;
end if;
end Show_Command_Line_Config;
-----------
-- Usage --
-----------
procedure Usage is
begin
Switch.Display_Usage_Version_And_Help;
Put_Line (" --target=target (" & Sdefault.Hostname & " by default)");
Put_Line
(" Select specified target or ""all"" for any target.");
Put_Line (" --show-targets : List all compiler targets available.");
Put_Line (" --mi-show-compilers : List all compilers available in a " &
"parser-friendly way.");
Put_Line (" --batch : batch mode, no interactive compiler selection.");
Put_Line (" -v : verbose mode.");
Put_Line (" -q : quiet output.");
Put_Line (" -o file : Name and directory of the output file.");
Put_Line (" default is " & To_String (Output_File));
Put_Line (" --db dir : Parse dir as an additional knowledge base.");
Put_Line (" --db- : Do not load the standard knowledge base from:");
Put_Line (" " & Default_Knowledge_Base_Directory);
Put_Line (" --validate : Validate the contents of the knowledge base");
Put_Line (" before loading.");
Put_Line (" --config=language[,version[,runtime[,path[,name]]]]");
Put_Line (" Preselect a compiler.");
Put_Line (" Name is either one of the names of the blocks");
Put_Line (" in the knowledge base ('GCC', 'GCC-28',...) or");
Put_Line (" the base name of an executable ('gcc',");
Put_Line (" 'gnatmake').");
Put_Line (" An empty string can be specified for any of the");
Put_Line (" optional parameters");
end Usage;
Saved_Verbosity : Verbosity := Default;
begin
Namet.Initialize;
Selected_Target := To_Unbounded_String (Sdefault.Hostname);
-- First, check if --version or --help is used
Check_Version_And_Help
("GPRCONFIG",
"2006",
Version_String => GPR_Version.Gpr_Version_String);
-- Now check whether we should parse the default knownledge base.
-- This needs to be done first, since that influences --config and -h
-- at least.
Initialize_Option_Scan;
loop
case Getopt (Valid_Switches) is
when '-' =>
if Full_Switch = "-db" then
if Parameter = "-" then
Load_Standard_Base := False;
end if;
elsif Full_Switch = "-validate" then
Opt_Validate := True;
elsif Full_Switch = "-target" then
Target_Specified := True;
if Parameter = "all" then
Selected_Target := Null_Unbounded_String;
else
Selected_Target := To_Unbounded_String (Parameter);
Output_File := To_Unbounded_String (Parameter & ".cgpr");
end if;
elsif Full_Switch = "-show-targets" then
-- By default, display all targets available
Selected_Target := Null_Unbounded_String;
end if;
when 'q' =>
Opt.Quiet_Output := True;
Current_Verbosity := Default;
when 'v' =>
case Current_Verbosity is
when Default => Current_Verbosity := Medium;
when others => Current_Verbosity := High;
end case;
Opt.Quiet_Output := False;
when ASCII.NUL =>
exit;
when others =>
null;
end case;
end loop;
Saved_Verbosity := Current_Verbosity;
Current_Verbosity := Default;
if Load_Standard_Base then
Parse_Knowledge_Base
(Base, Default_Knowledge_Base_Directory, Validate => Opt_Validate);
end if;
-- Now check all the other command line switches
Initialize_Option_Scan;
loop
case Getopt (Valid_Switches) is
when '-' =>
if Full_Switch = "-config" then
declare
Requires_Comp : Boolean;
Comp : Compiler_Access;
begin
Parse_Config_Parameter
(Base => Base,
Config => Parameter,
Compiler => Comp,
Requires_Compiler => Requires_Comp);
if Requires_Comp then
Append (Filters, Comp);
else
Append (Compilers, Comp);
end if;
end;
elsif Full_Switch = "-batch" then
Batch := True;
elsif Full_Switch = "-mi-show-compilers" then
Show_Compilers := True;
elsif Full_Switch = "-show-targets" then
Show_Targets := True;
elsif Full_Switch = "-db" then
if Parameter = "-" then
null; -- already processed
else
Parse_Knowledge_Base
(Base, Parameter, Validate => Opt_Validate);
end if;
end if;
when 'h' =>
Help (Base);
return;
when 'o' =>
Output_File := To_Unbounded_String (Parameter);
when 'q' | 'v' | 't' =>
null; -- already processed
when others =>
exit;
end case;
end loop;
Current_Verbosity := Saved_Verbosity;
Put_Verbose ("Only compilers matching target "
& To_String (Selected_Target)
& " will be preserved");
Get_Targets_Set
(Base, To_String (Selected_Target), Selected_Targets_Set);
if Batch or Hostparm.OpenVMS then
Complete_Command_Line_Compilers
(Base,
Selected_Targets_Set,
Filters,
Compilers);
else
declare
Iter : All_Iterator (Length (Filters));
begin
Iter.Filters := Filters;
Foreach_Compiler_In_Path
(Iterator => Iter,
Base => Base,
On_Target => Selected_Targets_Set,
Extra_Dirs => Extra_Dirs_From_Filters (Filters));
Splice (Target => Compilers,
Before => No_Element,
Source => Iter.Compilers);
end;
if Show_Targets or else Current_Verbosity /= Default then
declare
use String_Lists;
All_Target : String_Lists.List;
C : Compiler_Lists.Cursor := First (Compilers);
begin
Put_Line ("List of targets supported by a compiler:");
while Has_Element (C) loop
if Target (Element (C).all) /= No_Name then
declare
Cur_Target : constant String :=
Get_Name_String (Target (Element (C).all));
T : String_Lists.Cursor := First (All_Target);
Dup : Boolean := False;
begin
while Has_Element (T) loop
if Element (T) = Cur_Target then
Dup := True;
exit;
end if;
Next (T);
end loop;
if not Dup then
Put (Cur_Target);
if Cur_Target = Sdefault.Hostname then
Put (" (native target)");
end if;
New_Line;
Append (All_Target, Cur_Target);
end if;
end;
end if;
Next (C);
end loop;
end;
if Show_Targets then
return;
end if;
end if;
if Is_Empty (Compilers) then
if Selected_Target /= Null_Unbounded_String then
Put_Line
(Standard_Error,
"No compilers found for target " & To_String (Selected_Target));
else
Put_Line (Standard_Error, "No compilers found");
end if;
Ada.Command_Line.Set_Exit_Status (1);
return;
end if;
Compiler_Sort.Sort (Compilers);
if Show_Compilers then
Display_Compilers_For_Parser (Base, Compilers);
return;
else
Select_Compilers_Interactively (Base, Compilers);
Show_Command_Line_Config (Compilers);
end if;
end if;
if not Target_Specified then
Get_Targets_Set
(Base, GprConfig.Sdefault.Hostname, Selected_Targets_Set);
Selected_Target :=
To_Unbounded_String (Normalized_Target (Base, Selected_Targets_Set));
end if;
if Output_File /= Null_Unbounded_String then
-- Look for runtime directories XML files
declare
Cursor : Compiler_Lists.Cursor;
Comp : Compiler_Access;
begin
Cursor := Compiler_Lists.First (Compilers);
while Compiler_Lists.Has_Element (Cursor) loop
Comp := Compiler_Lists.Element (Cursor);
if Runtime_Dir_Of (Comp) /= No_Name then
declare
RTS : constant String :=
Get_Name_String (Runtime_Dir_Of (Comp));
Last : Natural := RTS'Last;
begin
if RTS (Last) = '/' or else
RTS (Last) = Directory_Separator
then
Last := Last - 1;
end if;
if Last - RTS'First > 6 and then
RTS (Last - 5 .. Last) = "adalib" and then
(RTS (Last - 6) = Directory_Separator or else
(RTS (Last - 6) = '/'))
then
Last := Last - 6;
else
Last := RTS'Last;
end if;
Parse_Knowledge_Base (Base, RTS (RTS'First .. Last));
end;
end if;
Compiler_Lists.Next (Cursor);
end loop;
end;
Generate_Configuration
(Base,
Compilers,
To_String (Output_File),
To_String (Selected_Target));
end if;
exception
when Invalid_Config =>
Put_Line
(Standard_Error, "Invalid configuration specified with --config");
Ada.Command_Line.Set_Exit_Status (1);
when Generate_Error =>
Put_Line
(Standard_Error, "Generation of configuration files failed");
Ada.Command_Line.Set_Exit_Status (3);
when E : Knowledge_Base_Validation_Error =>
Put_Verbose (Exception_Information (E));
Ada.Command_Line.Set_Exit_Status (4);
when E : Invalid_Knowledge_Base =>
Put_Line
(Standard_Error, "Invalid setup of the gprconfig knowledge base");
Put_Verbose (Exception_Information (E));
Ada.Command_Line.Set_Exit_Status (4);
when End_Error =>
null;
when Invalid_Switch | Invalid_Parameter =>
Put_Line ("Invalid command line switch: -" & Full_Switch);
Try_Help;
Ada.Command_Line.Set_Exit_Status (2);
end GprConfig.Main;
gprbuild-gpl-2014-src/src/create_ada_runtime_project.adb 0000644 0000767 0000145 00000030570 12323721731 022740 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT SYSTEM UTILITIES --
-- --
-- C R E A T E _ A D A _ R U N T I M E _ P R O J E C T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006-2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- This utility creates the Ada runtime project file ada_runtime.gpr
-- This project file resides in the parent directory of adainclude (the source
-- directory) and adalib (the object directory). It is "externally built". Its
-- package Naming gives the mapping of the source file names to unit names.
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Command_Line; use GNAT.Command_Line;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.HTable; use GNAT.HTable;
procedure Create_Ada_Runtime_Project is
Err : exception;
-- Raised to terminate execution
Project_File : Ada.Text_IO.File_Type;
-- The project file being created
Adainclude : String_Access := new String'("adainclude");
-- The path name of the adainclude directory, given as argument of the
-- utility.
Dir : Dir_Type;
Str : String (1 .. 1_000);
Last : Natural;
Gcc : constant String := "gcc";
Gcc_Path : String_Access;
Args : Argument_List (1 .. 6) :=
(1 => new String'("-c"),
2 => new String'("-gnats"),
3 => new String'("-gnatu"),
4 => new String'("-x"),
5 => new String'("ada"),
6 => null);
-- The arguments used when invoking the Ada compiler to get the name and
-- kind (spec or body) of the unit contained in a source file.
Success : Boolean;
Return_Code : Integer;
Mapping_File_Name : String_Access := new String'("gnat_runtime.mapping");
-- Location of the default mapping file.
Output_File : String_Access := new String'("ada_runtime.gpr");
-- Name of the final project file being created
Output_File_Name : constant String := "output.txt";
Output : Ada.Text_IO.File_Type;
-- The text file where the output of the compiler invocation is stored.
-- This is temporary output from gcc
Line : String (1 .. 1_000);
Line_Last : Natural;
Spec : Boolean;
Verbose_Mode : Boolean := False;
-- True if switch -v is used
subtype Header_Num is Natural range 0 .. 4095;
function Hash (Key : String_Access) return Header_Num;
function Equal (K1, K2 : String_Access) return Boolean;
type Element is record
Spec : Boolean := False;
Unit : String_Access := null;
end record;
No_Element : constant Element := (False, null);
package Mapping is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
Element => Element,
No_Element => No_Element,
Key => String_Access,
Hash => Hash,
Equal => Equal);
-- A hash table to keep the mapping of source file names to unit names
-- found in file gnat_runtime.mapping.
Key : String_Access;
Elem : Element;
function Hash is new GNAT.HTable.Hash (Header_Num);
procedure Get_Mapping (Mapping_File : String);
-- Read file mapping file to get the mapping of source file names
-- to unit names and populate hash table Mapping.
-- If the file doesn't exist, nothing is done, but
-- Create_Ada_Runtime_Project will execute more slowly
procedure Fail (S : String);
-- Outputs S to Standard_Error, followed by a newline and then raises the
-- exception Err.
procedure Help;
-- Display help on using this application
-----------
-- Equal --
-----------
function Equal (K1, K2 : String_Access) return Boolean is
begin
if K1 = null or else K2 = null then
return K1 = K2;
else
return K1.all = K2.all;
end if;
end Equal;
----------
-- Fail --
----------
procedure Fail (S : String) is
begin
Put_Line (Standard_Error, S);
raise Err;
end Fail;
-----------------
-- Get_Mapping --
-----------------
procedure Get_Mapping (Mapping_File : String) is
File : File_Type;
Line : String (1 .. 1_000);
Last : Natural;
begin
Open (File, In_File, Mapping_File);
while not End_Of_File (File) loop
Get_Line (File, Line, Last);
-- Skip the line if it is a comment line
if Last > 2 and then Line (1 .. 2) /= "--" then
Key := new String'(Line (1 .. Last));
Get_Line (File, Line, Last);
Elem.Spec := Line (1 .. Last) = "spec";
Get_Line (File, Line, Last);
Elem.Unit := new String'(Line (1 .. Last));
Mapping.Set (Key, Elem);
end if;
end loop;
Close (File);
exception
when others =>
if Is_Open (File) then
Close (File);
end if;
if Verbose_Mode then
Put_Line (Standard_Error, "Could not read " & Mapping_File);
end if;
end Get_Mapping;
----------
-- Hash --
----------
function Hash (Key : String_Access) return Header_Num is
begin
if Key = null then
return 0;
else
return Hash (Key.all);
end if;
end Hash;
----------
-- Help --
----------
procedure Help is
begin
Put_Line (" -adainclude : Location of the adainclude directory");
Put_Line (" -mapping : Location of the pre-built mapping file");
Put_Line (" -o : Output file name");
Put_Line (" -v : Verbose mode");
Put_Line (" Default is " & Output_File.all);
end Help;
-- Start of processing for Create_Ada_Runtime_Project
begin
-- The utility needs to be invoked with only one argument: the path name
-- of the adainclude directory.
loop
case Getopt ("adainclude: o: mapping: h v") is
when 'a' =>
Free (Adainclude);
Adainclude := new String'(Parameter);
when 'm' =>
Free (Mapping_File_Name);
Mapping_File_Name := new String'(Parameter);
when 'o' =>
Free (Output_File);
Output_File := new String'(Parameter);
when 'h' =>
Help;
return;
when 'v' =>
Verbose_Mode := True;
when others =>
exit;
end case;
end loop;
Gcc_Path := Locate_Exec_On_Path (Gcc);
if Gcc_Path = null then
Fail ("cannot find " & Gcc);
end if;
Get_Mapping (Mapping_File_Name.all);
-- Change the working directory to the adainclude directory
begin
Change_Dir (Adainclude.all);
exception
when Directory_Error =>
Fail ("cannot find adainclude directory " & Adainclude.all);
end;
-- Create the project file in the parent directory of adainclude
Create (Project_File, Out_File, Output_File.all);
-- Put the first lines that are always the same
Put_Line (Project_File, "project Ada_Runtime is");
New_Line (Project_File);
Put_Line (Project_File, " for Languages use (""Ada"");");
Put_Line (Project_File, " for Source_Dirs use ("""
& Adainclude.all & """);");
Put_Line (Project_File, " for Object_Dir use """
& Adainclude.all
& ".." & Directory_Separator & "adalib"";");
New_Line (Project_File);
Put_Line (Project_File, " for Externally_Built use ""true"";");
New_Line (Project_File);
Put_Line (Project_File, " package Naming is");
Open (Dir, ".");
-- For each regular file in the adainclude directory, invoke the compiler
-- to get the unit name.
loop
Read (Dir, Str, Last);
exit when Last = 0;
if Is_Regular_File (Str (1 .. Last)) then
Key := new String'(Str (1 .. Last));
Elem := Mapping.Get (Key);
-- Mapping found in hash table
if Elem /= No_Element then
if To_Lower (Elem.Unit.all) /= Str (1 .. Last - 4) then
Put (Project_File, " for ");
if Elem.Spec then
Put (Project_File, "Spec (""");
else
Put (Project_File, "Body (""");
end if;
Put (Project_File, Elem.Unit.all);
Put (Project_File, """) use """);
Put (Project_File, Str (1 .. Last));
Put_Line (Project_File, """;");
end if;
-- Case where Mapping.Get returned no element: use the compiler
-- to get the unit name.
else
Args (Args'Last) := new String'(Str (1 .. Last));
if Verbose_Mode then
Put (Gcc_Path.all);
for J in Args'Range loop
Put (' ' & Args (J).all);
end loop;
New_Line;
end if;
Spawn (Gcc_Path.all, Args, Output_File_Name, Success, Return_Code);
if Success then
Open (Output, In_File, Output_File_Name);
if not End_Of_File (Output) then
Get_Line (Output, Line, Line_Last);
-- Find the first closing parenthesis
Char_Loop : for J in 1 .. Line_Last loop
if Line (J) = ')' then
if J >= 13 and then Line (1 .. 4) = "Unit" then
-- No need for a spec or body declaration if the
-- file name is as expected.
if To_Lower (Line (6 .. J - 7)) /=
Str (1 .. Last - 4)
then
Spec := Line (J - 5 .. J) = "(spec)";
Put (Project_File, " for ");
if Spec then
Put (Project_File, "Spec (""");
else
Put (Project_File, "Body (""");
end if;
Put (Project_File, Line (6 .. J - 7));
Put (Project_File, """) use """);
Put (Project_File, Str (1 .. Last));
Put_Line (Project_File, """;");
end if;
end if;
exit Char_Loop;
end if;
end loop Char_Loop;
end if;
Close (Output);
end if;
end if;
end if;
end loop;
-- Put the closing lines and close the project file
Put_Line (Project_File, " end Naming;");
New_Line (Project_File);
Put_Line (Project_File, "end Ada_Runtime;");
Close (Project_File);
-- Clean up: delete the output file
Delete_File (Output_File_Name, Success);
exception
when Invalid_Switch | Invalid_Parameter =>
Put_Line ("Invalid switch: " & Full_Switch);
Help;
when Err =>
Set_Exit_Status (1);
when others =>
Put_Line ("unexpected exception");
raise;
end Create_Ada_Runtime_Project;
gprbuild-gpl-2014-src/src/gprconfig-sdefault.ads.in 0000644 0000767 0000145 00000004063 12323721731 021606 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R C O N F I G --
-- --
-- S p e c --
-- --
-- Copyright (C) 2006-2012, AdaCore --
-- --
-- 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, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package GprConfig.Sdefault is
pragma Warnings (Off);
Hostname : constant String := "@host@";
end GprConfig.Sdefault;
gprbuild-gpl-2014-src/src/forcomp.adb 0000644 0000767 0000145 00000016275 12323721731 017052 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- F O R C O M P --
-- --
-- B o d y --
-- --
-- Copyright (C) 2010-2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- This program is used on VMS as a front end to invoke the DEC Fortran
-- compiler.
pragma Extend_System (Aux_DEC);
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Osint; use Osint;
with System; use System;
procedure Forcomp is
subtype Cond_Value_Type is System.Unsigned_Longword;
Output_File_Name : String_Access;
procedure Spawn (Status : out Cond_Value_Type; Command : String;
Input_File : String := String'Null_Parameter;
Output_File : String := String'Null_Parameter);
pragma Import (External, Spawn);
pragma Import_Valued_Procedure
(Spawn, "LIB$SPAWN",
(Cond_Value_Type, String, String, String),
(Value, Descriptor (S), Descriptor (S), Descriptor (S)));
-- LIB$SPAWN is used to invoke the compiler
procedure Stop (Status : Cond_Value_Type);
pragma Import (External, Stop);
pragma Import_Procedure (Stop, "LIB$STOP", Mechanism => Value);
-- LIB$STOP is used to set the error code when the invocation of the
-- compiler fails.
Success : constant Cond_Value_Type := 1;
Command : constant String := "fortran";
Status : Cond_Value_Type;
Include_Directory : constant String := "/INCLUDE=";
Output_File : constant String := "-o";
Verbose : Boolean := False;
procedure Add
(S : in out String_Access;
Last : in out Natural;
Value : String);
-- Add string Value to string variable S, updating Last
---------
-- Add --
---------
procedure Add
(S : in out String_Access;
Last : in out Natural;
Value : String)
is
begin
while S'Last < Last + Value'Length loop
declare
New_S : constant String_Access := new String (1 .. 2 * S'Last);
begin
New_S (1 .. Last) := S (1 .. Last);
Free (S);
S := New_S;
end;
end loop;
S (Last + 1 .. Last + Value'Length) := Value;
Last := Last + Value'Length;
end Add;
begin
declare
Command_String : String_Access := new String (1 .. 40);
-- This is the command string that will be used to invoke the compiler
Last_Command : Natural := 0;
Includes : String_Access := new String (1 .. 40);
-- As they can be only one /INCLUDE= option, we regroupe all directories
-- in string Includes.
Last_Include : Natural := 0;
Arg_Num : Natural;
begin
Add (Command_String, Last_Command, Command);
Arg_Num := 0;
while Arg_Num < Argument_Count loop
Arg_Num := Arg_Num + 1;
declare
Arg : constant String := Argument (Arg_Num);
begin
-- If this command is /INCLUDE=, add the directory to string
-- Includes.
if Arg'Length > Include_Directory'Length and then
Arg (Arg'First .. Arg'First + Include_Directory'Length - 1) =
Include_Directory
then
if Last_Include = 0 then
Add (Includes, Last_Include, Include_Directory & "(");
else
Add (Includes, Last_Include, ",");
end if;
declare
Dir : constant String :=
Arg (Arg'First + Include_Directory'Length .. Arg'Last);
New_Dir : String_Access;
begin
if Is_Directory (Dir) then
New_Dir := To_Host_Dir_Spec (Dir, False);
Add (Includes, Last_Include, New_Dir.all);
else
Add (Includes, Last_Include, Dir);
end if;
end;
-- If it is "-o", the next argument is the output file
elsif Arg = Output_File then
if Arg_Num < Argument_Count then
Arg_Num := Arg_Num + 1;
Output_File_Name := To_Host_File_Spec (Argument (Arg_Num));
end if;
-- If it is "-v", skip the argument and set Verbose to True
elsif Arg = "-v" then
Verbose := True;
-- Otherwise, add argument to the command string
else
declare
New_Arg : String_Access;
begin
if Is_Regular_File (Arg) then
New_Arg := To_Host_File_Spec (Arg);
elsif Is_Directory (Arg) then
New_Arg := To_Host_Dir_Spec (Arg, False);
end if;
if New_Arg /= null then
Add (Command_String, Last_Command, " " & New_Arg.all);
else
Add (Command_String, Last_Command, " " & Arg);
end if;
end;
end if;
end;
end loop;
-- If there was at least one /INCLUDE= switch, add /INCLUDE= with all
-- directories to the command string.
if Last_Include /= 0 then
Add
(Command_String,
Last_Command,
" " & Includes (1 .. Last_Include) & ")");
end if;
-- Invoke Fortran
declare
Cmd : constant String (1 .. Last_Command) :=
Command_String (1 .. Last_Command);
begin
if Verbose then
Put_Line (Cmd);
end if;
if Output_File_Name /= null then
Spawn (Status, Cmd, Output_File => Output_File_Name.all);
else
Spawn (Status, Cmd);
end if;
if (Status mod 2) /= Success then
Stop (Status);
end if;
end;
end;
end Forcomp;
gprbuild-gpl-2014-src/src/gprbuild-compilation-slave.adb 0000644 0000767 0000145 00000074313 12323721731 022636 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . C O M P I L A T I O N . S L A V E --
-- --
-- B o d y --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Calendar; use Ada.Calendar;
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Vectors; use Ada;
with Ada.Directories; use Ada.Directories;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Maps.Constants; use Ada.Strings;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with GNAT.Sockets; use GNAT; use GNAT.Sockets;
with GNAT.String_Split; use GNAT.String_Split;
with Output; use Output;
with Snames; use Snames;
with Gpr_Util; use Gpr_Util;
with Gprbuild.Compilation.Protocol; use Gprbuild.Compilation.Protocol;
with Gprbuild.Compilation.Result;
with Gprbuild.Compilation.Sync;
package body Gprbuild.Compilation.Slave is
type Slave_Data is record
Host : Unbounded_String;
User : Unbounded_String;
Port : Port_Type;
Sync : Sync_Kind;
end record;
No_Slave_Data : constant Slave_Data :=
(Port => Port_Type'Last, others => <>);
package Slaves_N is new Containers.Vectors (Positive, Slave_Data);
Slaves_Data : Slaves_N.Vector;
type Slave is record
Sock : Integer;
Data : Slave_Data;
Channel : Communication_Channel;
Current : Natural := 0;
Max_Processes : Positive := 1;
Root_Dir : Unbounded_String;
Rsync_Pid : Process_Id;
Included_Artifact_Patterns : Str_Vect.Vector;
end record;
function "<" (K1, K2 : Slave) return Boolean is (K1.Sock < K2.Sock);
function "=" (K1, K2 : Slave) return Boolean is (K1.Sock = K2.Sock);
No_Slave : constant Slave :=
(-1, No_Slave_Data, Current => Natural'Last, others => <>);
package Slave_S is new Containers.Ordered_Sets (Slave);
-- The key is the C socket number
function Connect_Slave
(S_Data : Slave_Data;
Project_Name : String) return Slave;
-- Connect to the slave and return the corresponding object
-- Ack transient signal stored into this variable
protected Wait_Ack is
procedure Set (Pid : Remote_Id);
entry Get (Pid : out Remote_Id);
private
Is_Set : Boolean := False;
Id : Remote_Id;
end Wait_Ack;
task type Wait_Remote;
-- Wait for incoming data from all registred slaves
type Wait_Remote_Ref is access Wait_Remote;
WR : Wait_Remote_Ref;
-- Will be initialized only if the distributed mode is activated
Compiler_Path : constant OS_Lib.String_Access :=
Locate_Exec_On_Path ("gnatls");
Project_Name : Unbounded_String;
-- Current project name being compiled
Root_Dir : Unbounded_String;
-- Root directory from where the sources are to be synchronized with the
-- slaves. This is by default the directory containing the main project
-- file. The value is changed with the Root_Dir attribute value of the
-- project file's Remote package.
Remote_Process : Shared_Counter;
Slaves_Sockets : Socket_Set_Type;
Max_Processes : Natural := 0;
protected Slaves is
procedure Insert (S : Slave);
-- Add a slave into the pool
function Find (Socket : Integer) return Slave;
-- Find a slave given the socket number
function Get_Free return Slave;
-- Returns a slave with free compilation slot
function Count return Natural;
-- Returns the number of registered slaves
procedure Increment_Current (S : in out Slave);
-- Increment the number of processes handled by slave
procedure Decrement_Current (S : in out Slave);
-- Decrement the number of processes handled by slave
procedure Set_Rewrite_CD (S : in out Slave; Path : String);
-- Record rewriting of the compiler directory
procedure Set_Rewrite_WD (S : in out Slave; Path : String);
-- Record rewriting of the wording directory
procedure Iterate (Proc : access procedure (S : in out Slave));
-- Iterate over all slaves in the pool and call proc
procedure Clear;
-- Clear the pool
private
Pool : Slave_S.Set;
end Slaves;
----------------------------
-- Clean_Up_Remote_Slaves --
----------------------------
procedure Clean_Up_Remote_Slaves
(Tree : Project_Tree_Ref;
Project : Project_Id)
is
pragma Unreferenced (Tree);
procedure Clean_Up_Remote_Slave
(S_Data : Slave_Data;
Project_Name : String);
-- Clean-up slave
---------------------------
-- Clean_Up_Remote_Slave --
---------------------------
procedure Clean_Up_Remote_Slave
(S_Data : Slave_Data;
Project_Name : String)
is
function User_Host return String is
(if S_Data.User = Null_Unbounded_String
then To_String (S_Data.Host)
else To_String (S_Data.User) & '@' & To_String (S_Data.Host));
S : Slave;
begin
-- Only clean-up when the sources are not shared
if S_Data.Sync = Protocol.Rsync then
S := Connect_Slave (S_Data, Project_Name);
-- Send the clean-up request
Protocol.Send_Clean_Up (S.Channel, Project_Name);
declare
Cmd : constant Command := Get_Command (S.Channel);
begin
if Kind (Cmd) = OK then
if Opt.Verbose_Mode then
Write_Line
("Clean-up done on " & To_String (S_Data.Host));
end if;
elsif Kind (Cmd) = KO then
Write_Line ("Slave cannot clean-up " & User_Host);
OS_Exit (1);
else
Write_Line
("protocol error: " & Command_Kind'Image (Kind (Cmd)));
OS_Exit (1);
end if;
end;
Protocol.Send_End_Of_Compilation (S.Channel);
Close (S.Channel);
end if;
end Clean_Up_Remote_Slave;
begin
for S of Slaves_Data loop
Clean_Up_Remote_Slave (S, Get_Name_String (Project.Name));
end loop;
end Clean_Up_Remote_Slaves;
-------------------
-- Connect_Slave --
-------------------
function Connect_Slave
(S_Data : Slave_Data;
Project_Name : String) return Slave
is
Address : Sock_Addr_Type;
Sock : Socket_Type;
S : Slave;
Status : Selector_Status;
begin
S.Data := S_Data;
if S.Data.Host = Null_Unbounded_String then
Write_Line ("A slave must have a name, aborting");
OS_Exit (1);
end if;
Address.Addr := Addresses
(Get_Host_By_Name (To_String (S.Data.Host)), 1);
Address.Port := S_Data.Port;
Create_Socket (Sock);
Set_Socket_Option (Sock, Socket_Level, (Reuse_Address, True));
Connect_Socket (Sock, Address, Timeout => 2.0, Status => Status);
if Status in Expired .. Aborted then
Write_Line
("Cannot connect to slave "
& To_String (S.Data.Host) & ", aborting");
OS_Exit (1);
end if;
S.Channel := Create (Sock);
-- Do initial handshake
Protocol.Send_Context
(S.Channel, Get_Target, Project_Name, Slave_Env.all, S.Data.Sync);
declare
Cmd : constant Command := Get_Command (S.Channel);
Parameters : constant Argument_List_Access := Args (Cmd);
begin
if Kind (Cmd) = OK and then Parameters'Length = 3 then
S.Max_Processes := Natural'Value (Parameters (1).all);
S.Root_Dir := To_Unbounded_String (Parameters (2).all);
if not Boolean'Value (Parameters (3).all) then
Write_Line
("warning: non synchronized clock detected for "
& To_String (S.Data.Host));
end if;
elsif Kind (Cmd) = KO then
Write_Line
("build slave is not compatible : " & To_String (S.Data.Host));
OS_Exit (1);
else
Write_Line ("protocol error: " & Command_Kind'Image (Kind (Cmd)));
OS_Exit (1);
end if;
end;
return S;
end Connect_Slave;
-----------------------
-- Get_Max_Processes --
-----------------------
function Get_Max_Processes return Natural is
begin
return Max_Processes;
end Get_Max_Processes;
-------------------
-- Record_Slaves --
-------------------
procedure Record_Slaves (Option : String) is
S : Slice_Set;
procedure Parse_Build_Slave (V : String);
-- Parse the build slave V
-----------------------
-- Parse_Build_Slave --
-----------------------
procedure Parse_Build_Slave (V : String) is
User : Unbounded_String;
Host : Unbounded_String;
Port : Port_Type := Default_Port;
Sync : Sync_Kind := Protocol.Rsync;
F : Natural := V'First;
I : Natural := Index (V, "://");
begin
-- Check for protocol
if I /= 0 then
if V (F .. I - 1) = "rsync" then
Sync := Protocol.Rsync;
elsif V (F .. I - 1) = "gpr" then
Sync := Gpr;
else
Write_Line ("error: unknown protocol in " & V);
OS_Exit (1);
end if;
F := I + 3;
end if;
-- Check for user
I := Index (V, "@", From => F);
if I /= 0 then
User := To_Unbounded_String (V (F .. I - 1));
F := I + 1;
end if;
-- Get for port
I := Index (V, ":", From => F);
if I = 0 then
Host := To_Unbounded_String (V (F .. V'Last));
else
Host := To_Unbounded_String (V (F .. I - 1));
declare
Port_Str : constant String := V (I + 1 .. V'Last);
begin
if Strings.Maps.Is_Subset
(Maps.To_Set (Port_Str),
Maps.Constants.Decimal_Digit_Set)
then
Port := Port_Type'Value (V (I + 1 .. V'Last));
else
Write_Line ("error: invalid port value in " & V);
OS_Exit (1);
end if;
end;
end if;
Slaves_Data.Append (Slave_Data'(Host, User, Port, Sync));
end Parse_Build_Slave;
begin
Create (S, Option, ",");
for K in 1 .. Slice_Count (S) loop
Parse_Build_Slave (Slice (S, K));
end loop;
end Record_Slaves;
----------------------------
-- Register_Remote_Slaves --
----------------------------
procedure Register_Remote_Slaves
(Tree : Project_Tree_Ref;
Project : Project_Id)
is
use type Containers.Count_Type;
procedure Register_Remote_Slave
(S_Data : Slave_Data;
Project_Name : String);
-- Register a slave living on Host for the given project name. User is
-- used when calling rsync, it is the remote machine user name, if empty
-- the local user name is used.
Start, Stop : Calendar.Time;
procedure Insert
(V : out Str_Vect.Vector;
Values : String_List_Id);
-- Inserts all values into the vector
Excluded_Patterns : Str_Vect.Vector;
Included_Patterns : Str_Vect.Vector;
Included_Artifact_Patterns : Str_Vect.Vector;
------------
-- Insert --
------------
procedure Insert
(V : out Str_Vect.Vector;
Values : String_List_Id)
is
Idx : String_List_Id := Values;
begin
while Idx /= Nil_String loop
declare
Item : constant String_Element :=
Tree.Shared.String_Elements.Table (Idx);
begin
V.Append (Get_Name_String (Item.Value));
Idx := Item.Next;
end;
end loop;
end Insert;
---------------------------
-- Register_Remote_Slave --
---------------------------
procedure Register_Remote_Slave
(S_Data : Slave_Data;
Project_Name : String)
is
function User_Host return String is
(if S_Data.User = Null_Unbounded_String
then To_String (S_Data.Host)
else To_String (S_Data.User) & '@' & To_String (S_Data.Host));
S : Slave;
begin
S := Connect_Slave (S_Data, Project_Name);
Set (Slaves_Sockets, Sock (S.Channel));
-- Sum the Max_Process values
Max_Processes := Max_Processes + S.Max_Processes;
if Opt.Verbose_Mode then
Write_Str ("Register slave " & User_Host & ",");
Write_Str (Integer'Image (S.Max_Processes));
Write_Line (" process(es)");
Write_Line (" location: " & To_String (S.Root_Dir));
end if;
-- Let's double check that Root_Dir and Projet_Name are not empty,
-- this is a safety check to avoid rsync detroying remote environment
-- as rsync is using the --delete options.
if Length (S.Root_Dir) = 0 then
Write_Line ("error: Root_Dir cannot be empty");
OS_Exit (1);
end if;
if Project_Name = "" then
Write_Line ("error: Project_Name cannot be empty");
OS_Exit (1);
end if;
Compilation.Sync.To_Slave
(Sync => S_Data.Sync,
Channel => S.Channel,
Project_Name => Project_Name,
Root_Dir => To_String (Root_Dir),
Slave_Root_Dir => To_String (S.Root_Dir),
Host => To_String (S_Data.Host),
User => To_String (S_Data.User),
Included_Patterns => Included_Patterns,
Excluded_Patterns => Excluded_Patterns);
-- Now that all slave's data is known and set, record it
S.Sock := To_C (Sock (S.Channel));
S.Included_Artifact_Patterns := Included_Artifact_Patterns;
Slaves.Insert (S);
end Register_Remote_Slave;
Pcks : Package_Table.Table_Ptr renames Tree.Shared.Packages.Table;
Pck : Package_Id := Project.Decl.Packages;
begin
Project_Name := To_Unbounded_String (Get_Name_String (Project.Name));
Root_Dir := To_Unbounded_String
(Containing_Directory (Get_Name_String (Project.Path.Display_Name)));
-- Check for Root_Dir attribute and Excluded_Patterns
Look_Remote_Package : while Pck /= No_Package loop
if Pcks (Pck).Decl /= No_Declarations
and then Pcks (Pck).Name = Name_Remote
then
declare
Id : Variable_Id := Pcks (Pck).Decl.Attributes;
begin
while Id /= No_Variable loop
declare
V : constant Variable :=
Tree.Shared.Variable_Elements.Table (Id);
begin
if not V.Value.Default then
if V.Name = Name_Root_Dir then
declare
RD : constant String :=
Get_Name_String (V.Value.Value);
begin
if Is_Absolute_Path (RD) then
Root_Dir := To_Unbounded_String (RD);
else
Root_Dir := To_Unbounded_String
(Normalize_Pathname
(To_String (Root_Dir)
& Directory_Separator & RD));
end if;
if not Exists (To_String (Root_Dir))
or else not Is_Directory (To_String (Root_Dir))
then
Write_Line
("error: " & To_String (Root_Dir)
& " is not a directory"
& " or does not exists");
OS_Exit (1);
else
Write_Line
("root dir : " & To_String (Root_Dir));
end if;
end;
elsif V.Name = Name_Excluded_Patterns then
Insert (Excluded_Patterns, V.Value.Values);
elsif V.Name = Name_Included_Patterns then
Insert (Included_Patterns, V.Value.Values);
elsif V.Name = Name_Included_Artifact_Patterns then
Insert (Included_Artifact_Patterns, V.Value.Values);
end if;
end if;
end;
Id := Tree.Shared.Variable_Elements.Table (Id).Next;
end loop;
end;
end if;
Pck := Pcks (Pck).Next;
end loop Look_Remote_Package;
-- Check if Excluded_Patterns and Included_Patterns are set
if Included_Patterns.Length /= 0
and then Excluded_Patterns.Length /= 0
then
Write_Line
("error: Excluded_Patterns and Included_Patterns are exclusive");
OS_Exit (1);
end if;
-- Then registers the build slaves
Start := Calendar.Clock;
for S of Slaves_Data loop
Register_Remote_Slave (S, To_String (Project_Name));
end loop;
Sync.Wait;
Stop := Calendar.Clock;
if Opt.Verbose_Mode then
Write_Str (" All data synchronized in ");
Write_Str (Duration'Image (Stop - Start));
Write_Line (" seconds");
end if;
-- We are in remote mode, the initialization was successful, start tasks
-- now.
if WR = null then
WR := new Wait_Remote;
end if;
end Register_Remote_Slaves;
---------
-- Run --
---------
function Run
(Project : Project_Id;
Language : String;
Options : GNAT.OS_Lib.Argument_List;
Obj_Name : String;
Dep_Name : String := "";
Env : String := "") return Id
is
CWD : constant String := Current_Directory;
-- CWD is the directory from which the command is run
RD : constant String := To_String (Root_Dir);
S : Slave := Slaves.Get_Free;
-- Get a free slave for conducting the compilation
function Filter_String
(O : String; Sep : String := WD_Path_Tag) return String;
-- Make O PATH relative to RD. For option -gnatec and -gnatem makes
-- the specified filename absolute in the slave environment and send
-- the file to the slave.
-------------------
-- Filter_String --
-------------------
function Filter_String
(O : String;
Sep : String := WD_Path_Tag) return String
is
Pos : constant Natural := Index (O, RD);
begin
if Pos = 0 then
return O;
else
-- Note that we transfer files only when they are under the
-- project root.
if O'Length > 8
and then O (O'First .. O'First + 7) in "-gnatem=" | "-gnatec="
then
-- Send the corresponding file to the slave
declare
File_Name : constant String := O (O'First + 8 .. O'Last);
begin
if Exists (File_Name) then
Send_File (S.Channel, File_Name, Rewrite => True);
else
Write_Line
("File not found " & File_Name);
Write_Line
("Please check that Built_Root is properly set");
end if;
return O (O'First .. O'First + 7)
& Translate_Send (S.Channel, File_Name);
end;
end if;
return O (O'First .. Pos - 1)
& Sep & Filter_String (O (Pos + RD'Length + 1 .. O'Last));
end if;
end Filter_String;
Pid : Remote_Id;
begin
-- Record the rewrite information for this channel only if we are not
-- using a shared directory.
Slaves.Set_Rewrite_WD (S, Path => RD);
if Compiler_Path /= null then
Slaves.Set_Rewrite_CD
(S,
Path => Containing_Directory
(Containing_Directory (Compiler_Path.all)));
end if;
Send_Exec
(S.Channel,
Get_Name_String (Project.Path.Display_Name),
Filter_String (CWD, Sep => ""),
Language, Options, Obj_Name, Dep_Name, Env,
Filter_String'Access);
Remote_Process.Increment;
-- Wait for the Ack from the remore host, this is set by the Wait_Remote
-- task.
Wait_Ack.Get (Pid);
return Create_Remote (Pid);
exception
when E : others =>
Write_Line ("Unexpected exception: " & Exception_Information (E));
OS_Exit (1);
end Run;
------------
-- Slaves --
------------
protected body Slaves is
--------------------
-- Change_Current --
--------------------
procedure Change_Current (S : in out Slave; Value : Integer) is
Position : constant Slave_S.Cursor := Pool.Find (S);
begin
Pool (Position).Current := Pool (Position).Current + Value;
end Change_Current;
-----------
-- Clear --
-----------
procedure Clear is
begin
Pool.Clear;
end Clear;
-----------
-- Count --
-----------
function Count return Natural is
begin
return Natural (Pool.Length);
end Count;
-----------------------
-- Decrement_Current --
-----------------------
procedure Decrement_Current (S : in out Slave) is
begin
Change_Current (S, -1);
end Decrement_Current;
----------
-- Find --
----------
function Find (Socket : Integer) return Slave is
S : constant Slave := (Sock => Socket, others => <>);
Position : constant Slave_S.Cursor := Pool.Find (S);
begin
if Slave_S.Has_Element (Position) then
return Slave_S.Element (Position);
else
return No_Slave;
end if;
end Find;
--------------
-- Get_Free --
--------------
function Get_Free return Slave is
begin
for S of Pool loop
if S.Current < S.Max_Processes then
return S;
end if;
end loop;
return No_Slave;
end Get_Free;
-----------------------
-- Increment_Current --
-----------------------
procedure Increment_Current (S : in out Slave) is
begin
Change_Current (S, 1);
end Increment_Current;
------------
-- Insert --
------------
procedure Insert (S : Slave) is
begin
Pool.Insert (S);
end Insert;
-------------
-- Iterate --
-------------
procedure Iterate (Proc : access procedure (S : in out Slave)) is
begin
for C in Pool.Iterate loop
declare
S : Slave := Slave_S.Element (C);
begin
Proc (S);
Pool (C) := S;
end;
end loop;
end Iterate;
--------------------
-- Set_Rewrite_CD --
--------------------
procedure Set_Rewrite_CD (S : in out Slave; Path : String) is
Position : constant Slave_S.Cursor := Pool.Find (S);
begin
Set_Rewrite_CD (Pool (Position).Channel, Path => Path);
S := Pool (Position);
end Set_Rewrite_CD;
--------------------
-- Set_Rewrite_WD --
--------------------
procedure Set_Rewrite_WD (S : in out Slave; Path : String) is
Position : constant Slave_S.Cursor := Pool.Find (S);
begin
Set_Rewrite_WD (Pool (Position).Channel, Path => Path);
S := Pool (Position);
end Set_Rewrite_WD;
end Slaves;
------------------------------
-- Unregister_Remote_Slaves --
------------------------------
procedure Unregister_Remote_Slaves is
procedure Unregister (S : in out Slave);
-- Unregister given slave
Start, Stop : Time;
----------------
-- Unregister --
----------------
procedure Unregister (S : in out Slave) is
begin
Send_End_Of_Compilation (S.Channel);
Close (S.Channel);
-- Sync back the object code if needed
Sync.From_Slave
(Sync => S.Data.Sync,
Project_Name => To_String (Project_Name),
Root_Dir => To_String (Root_Dir),
Slave_Root_Dir => To_String (S.Root_Dir),
User => To_String (S.Data.User),
Host => To_String (S.Data.Host),
Included_Artifact_Patterns => S.Included_Artifact_Patterns);
end Unregister;
begin
Start := Clock;
Slaves.Iterate (Unregister'Access);
Sync.Wait;
Stop := Clock;
if Opt.Verbose_Mode and then Slaves.Count > 0 then
Write_Str (" All data synchronized in ");
Write_Str (Duration'Image (Stop - Start));
Write_Line (" seconds");
end if;
Slaves.Clear;
end Unregister_Remote_Slaves;
--------------
-- Wait_Ack --
--------------
protected body Wait_Ack is
---------
-- Set --
---------
procedure Set (Pid : Remote_Id) is
begin
Id := Pid;
Is_Set := True;
end Set;
---------
-- Get --
---------
entry Get (Pid : out Remote_Id) when Is_Set is
begin
Pid := Id;
Is_Set := False;
end Get;
end Wait_Ack;
-----------------
-- Wait_Remote --
-----------------
task body Wait_Remote is
use type Slave_S.Cursor;
Proc : Id;
Pid : Remote_Id;
Selector : Selector_Type;
Status : Selector_Status;
R_Set, W_Set : Socket_Set_Type;
Sock : Socket_Type;
S : Slave;
begin
-- In this task we are only interrested by the incoming data, so we do
-- not wait on socket ready for writting.
Sockets.Empty (W_Set);
Create_Selector (Selector);
loop
-- Let's wait for at least some process to monitor
Remote_Process.Wait_Non_Zero;
-- Wait for response from all registered slaves
Copy (Slaves_Sockets, R_Set);
Check_Selector (Selector, R_Set, W_Set, Status);
if Status = Completed then
Get (R_Set, Sock);
pragma Assert
(Sock /= No_Socket, "no socket returned by selector");
S := Slaves.Find (To_C (Sock));
if S /= No_Slave then
declare
Cmd : constant Command := Get_Command (S.Channel);
Success : Boolean;
begin
-- A display output
if Kind (Cmd) = DP then
-- Write output to the console
Write_Str (To_String (Protocol.Output (Cmd)));
Get_Pid (S.Channel, Pid, Success);
Proc := Create_Remote (Pid);
Remote_Process.Decrement;
Slaves.Decrement_Current (S);
Result.Add (Proc, Success, To_String (S.Data.Host));
-- An acknowledgment of an compilation job
elsif Kind (Cmd) = AK then
declare
Pid : constant Remote_Id :=
Remote_Id'Value (Args (Cmd)(1).all);
begin
Slaves.Increment_Current (S);
Wait_Ack.Set (Pid);
end;
elsif Kind (Cmd) = EC then
null;
else
raise Constraint_Error with "Unexpected command: "
& Command_Kind'Image (Kind (Cmd));
end if;
end;
end if;
else
if Opt.Verbose_Mode and then Opt.Verbosity_Level = Opt.High then
Write_Line
("warning: selector in " & Selector_Status'Image (Status)
& " state");
end if;
end if;
Sockets.Empty (R_Set);
end loop;
exception
when E : others =>
Write_Line (Exception_Information (E));
OS_Exit (1);
end Wait_Remote;
end Gprbuild.Compilation.Slave;
gprbuild-gpl-2014-src/src/gprinstall-uninstall.ads 0000644 0000767 0000145 00000003260 12323721731 021602 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R I N S T A L L . M A I N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
package Gprinstall.Uninstall is
procedure Process (Install_Name : String);
-- Uninstall Project
end Gprinstall.Uninstall;
gprbuild-gpl-2014-src/src/gprmunch.sh 0000755 0000767 0000145 00000003234 10612067551 017110 0 ustar gnatmail gnat #!/bin/sh
if [ $# != 1 ]; then
echo "Bad number of arguments";
exit 2
fi
exch_file=$1
cp $exch_file $exch_file.saved
# Save stdin and use exchange file as input.
exec >&3
exec < $exch_file
# Save and set IFS to new line.
OLD_IFS=$IFS
IFS="
"
# Parse exchange file.
section='Unknown'
dep_files=""
bindsec='Unknown'
nm="nm-not-defined"
cc="cc-not-defined"
verbose=""
while read line; do
case $line in
"[MAIN BASE NAME]") section="base name" ;;
"[COMPILER PATH]") section="discard" ;;
"[COMPILER OPTIONS]") section="discard" ;;
"[DEPENDENCY FILES]") section="dependency" ;;
"[BINDING OPTIONS]") section="options" ;;
"[VERBOSE]") verbose=y; section="Unknown" ;;
\[*) echo "Unknown section ($line)"; exit 1 ;;
*) case $section in
"discard") ;;
"Unknown") echo "Malformed exchange file"; exit 1 ;;
"base name") basename=$line ;;
"dependency") dep_files="$dep_files $line" ;;
"options")
case $line in
--nm=*) nm=`echo $line | sed -e "s/^--nm=//"` ;;
--cc=*) cc=`echo $line | sed -e "s/^--cc=//"` ;;
*) echo "Unknown binder option ($line)" ;;
esac ;;
*) echo "Internal error (section $section) unhandled"; exit 1 ;;
esac
esac
done
# Restore IFS and stdin.
IFS=$OLD_IFS
exec 3>&1
exec 3>&-
# Convert dependancy files to object files.
object_files=`echo $dep_files | sed -e 's/\\.d\$/.o/'`
# Do the real work.
$nm $object_files | munch > cpp__$basename.c
$cc -c cpp__$basename.c
# Generate the exchange file.
cat > $1 < True);
-- The project tree
Force_Deletions : Boolean := False;
-- Set to True by switch -f. When True, attempts to delete non writable
-- files will be done.
Do_Nothing : Boolean := False;
-- Set to True when switch -n is specified. When True, no file is deleted.
-- gnatclean only lists the files that would have been deleted if the
-- switch -n had not been specified.
File_Deleted : Boolean := False;
-- Set to True if at least one file has been deleted
Copyright_Displayed : Boolean := False;
Usage_Displayed : Boolean := False;
-- Flags set to True when the action is performed, to avoid duplicate
-- displays.
All_Projects : Boolean := False;
-- Set to True when option -r is used, so that all projects in the project
-- tree are cleaned.
package Processed_Projects is new Table.Table
(Table_Component_Type => Project_Id,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Cleangpr.Processed_Projects");
-- Table to keep track of what project files have been processed, when
-- switch -r is specified.
procedure Clean_Project
(Project : Project_Id;
Project_Tree : Project_Tree_Ref;
Main : Boolean;
Remove_Executables : Boolean);
-- Do the cleaning work for Project.
-- This procedure calls itself recursively when there are several
-- project files in the tree rooted at the main project file and switch -r
-- has been specified.
-- Main is True iff Project is a main project.
-- If Remove_Executables is true, the binder files and results of the
-- linker are also removed.
procedure Delete (In_Directory : String; File : String);
-- Delete one file, or list the file name if switch -n is specified
end Gprclean;
gprbuild-gpl-2014-src/src/gpr_util.ads 0000644 0000767 0000145 00000027506 12323721731 017252 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R _ U T I L --
-- --
-- S p e c --
-- --
-- Copyright (C) 2007-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- This package contains constants, variable and subprograms used by gprbuild
-- and gprclean.
with Ada.Calendar; use Ada;
with GNAT.MD5; use GNAT.MD5;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with ALI;
with Namet; use Namet;
with Prj; use Prj;
with Prj.Tree; use Prj.Tree;
with Types;
package Gpr_Util is
Partial_Prefix : constant String := "p__";
Begin_Info : constant String := "-- BEGIN Object file/option list";
End_Info : constant String := "-- END Object file/option list ";
Project_Node_Tree : constant Project_Node_Tree_Ref :=
new Project_Node_Tree_Data;
-- This is also used to hold project path and scenario variables
Success : Boolean := False;
-- Config project
Config_Project_Option : constant String := "--config=";
Autoconf_Project_Option : constant String := "--autoconf=";
Target_Project_Option : constant String := "--target=";
Prefix_Project_Option : constant String := "--prefix";
No_Name_Map_File_Option : constant String := "--map-file-option";
Restricted_To_Languages_Option : constant String :=
"--restricted-to-languages=";
Distributed_Option : constant String := "--distributed=";
Slave_Env_Option : constant String := "--slave-env";
Slave_Env_Auto : Boolean := False;
Dry_Run_Option : constant String := "--dry-run";
Named_Map_File_Option : constant String := No_Name_Map_File_Option & '=';
Config_Path : String_Access := null;
Target_Name : String_Access := null;
Config_Project_File_Name : String_Access := null;
Configuration_Project_Path : String_Access := null;
-- Base name and full path to the configuration project file
Autoconfiguration : Boolean := True;
-- Whether we are using an automatically config (from gprconfig)
Autoconf_Specified : Boolean := False;
-- Whether the user specified --autoconf on the gprbuild command line
Delete_Autoconf_File : Boolean := False;
-- This variable is used by gprclean to decide if the config project file
-- should be cleaned. It is set to True when the config project file is
-- automatically generated or --autoconf= is used.
-- Default project
Default_Project_File_Name : constant String := "default.gpr";
-- Implicit project
Implicit_Project_File_Path : constant String :=
"share" &
Directory_Separator &
"gpr" &
Directory_Separator &
'_' &
Default_Project_File_Name;
-- User projects
Project_File_Name : String_Access := null;
-- The name of the project file specified with switch -P
No_Project_File_Found : Boolean := False;
-- True when no project file is specified and there is no .gpr file
-- in the current working directory.
Main_Project : Project_Id;
-- The project id of the main project
RTS_Option : constant String := "--RTS=";
RTS_Language_Option : constant String := "--RTS:";
Db_Directory_Expected : Boolean := False;
-- True when last switch was --db
Distributed_Mode : Boolean := False;
-- Wether the distributed compilation mode has been activated
Slave_Env : String_Access;
-- The name of the distributed build environment
-- Packages of project files where unknown attributes are errors
Naming_String : aliased String := "naming";
Builder_String : aliased String := "builder";
Compiler_String : aliased String := "compiler";
Binder_String : aliased String := "binder";
Linker_String : aliased String := "linker";
Clean_String : aliased String := "clean";
-- Name of packages to be checked when parsing/processing project files
List_Of_Packages : aliased String_List :=
(Naming_String'Access,
Builder_String'Access,
Compiler_String'Access,
Binder_String'Access,
Linker_String'Access,
Clean_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
-- Local subprograms
function Binder_Exchange_File_Name
(Main_Base_Name : File_Name_Type; Prefix : Name_Id) return String_Access;
-- Returns the name of the binder exchange file corresponding to an
-- object file and a language.
-- Main_Base_Name must have no extension specified
procedure Create_Response_File
(Format : Response_File_Format;
Objects : String_List;
Other_Arguments : String_List;
Resp_File_Options : String_List;
Name_1 : out Path_Name_Type;
Name_2 : out Path_Name_Type);
-- Create a temporary file as a response file that contains either the list
-- of Objects in the correct Format, or for Format GCC the list of all
-- arguments. It is the responsibility of the caller to delete this
-- temporary file if needed.
----------
-- Misc --
----------
procedure Find_Binding_Languages
(Tree : Project_Tree_Ref;
Root_Project : Project_Id);
-- Check if in the project tree there are sources of languages that have
-- a binder driver.
-- Populates Tree's appdata (Binding and There_Are_Binder_Drivers).
-- Nothing is done if the binding languages were already searched for
-- this Tree.
-- This also performs the check for aggregated project trees.
function Get_Compiler_Driver_Path
(Project_Tree : Project_Tree_Ref;
Lang : Language_Ptr) return String_Access;
-- Get, from the config, the path of the compiler driver. This is first
-- looked for on the PATH if needed.
-- Returns "null" if no compiler driver was specified for the language, and
-- exit with an error if one was specified but not found.
procedure Locate_Runtime
(Project_Tree : Project_Tree_Ref;
Language : Name_Id);
-- Wrapper around Set_Runtime_For. If RTS_Name is a base name (a name
-- without path separator), then calls Set_Runtime_For. Otherwise, convert
-- it to an absolute path (possibly by searching it in the project path)
procedure Look_For_Default_Project;
-- Check if default.gpr exists in the current directory. If it does, use
-- it. Otherwise, if there is only one file ending with .gpr, use it.
function Partial_Name
(Lib_Name : String;
Number : Natural;
Object_Suffix : String) return String;
-- Returns the name of an object file created by the partial linker
function Shared_Libgcc_Dir (Run_Time_Dir : String) return String;
-- Returns the directory of the shared version of libgcc, if it can be
-- found, otherwise returns an empty string.
package Knowledge is
function Normalized_Hostname return String;
-- Return the normalized name of the host on which gprbuild is running.
-- The knowledge base must have been parsed first.
procedure Parse_Knowledge_Base
(Project_Tree : Project_Tree_Ref;
Directory : String := "");
end Knowledge;
procedure Need_To_Compile
(Source : Source_Id;
Tree : Project_Tree_Ref;
In_Project : Project_Id;
Must_Compile : out Boolean;
The_ALI : out ALI.ALI_Id;
Object_Check : Boolean;
Always_Compile : Boolean);
-- Check if a source need to be compiled.
-- A source need to be compiled if:
-- - Force_Compilations is True
-- - No object file generated for the language
-- - Object file does not exist
-- - Dependency file does not exist
-- - Switches file does not exist
-- - Either of these 3 files are older than the source or any source it
-- depends on.
-- If an ALI file had to be parsed, it is returned as The_ALI, so that the
-- caller does not need to parse it again.
--
-- Object_Check should be False when switch --no-object-check is used. When
-- True, presence of the object file and its time stamp are checked to
-- decide if a file needs to be compiled.
--
-- Tree is the project tree in which Source is found (or the root tree when
-- not using aggregate projects).
--
-- Always_Compile should be True when gprbuid is called with -f -u and at
-- least one source on the command line.
function Project_Compilation_Failed
(Prj : Project_Id;
Recursive : Boolean := True) return Boolean;
-- Returns True if all compilations for Prj (and all projects it depends on
-- if Recursive is True) were successful and False otherwise.
procedure Set_Failed_Compilation_Status (Prj : Project_Id);
-- Record compilation failure status for the given project
Maximum_Size : Integer;
pragma Import (C, Maximum_Size, "__gnat_link_max");
-- Maximum number of bytes to put in an invocation of the
-- Archive_Builder.
function Ensure_Directory (Path : String) return String;
-- Returns Path with an ending directory separator
function File_MD5 (Pathname : String) return Message_Digest;
-- Returns the file MD5 signature. Raises Name_Error if Pathname does not
-- exists.
function Relative_Path (Pathname, To : String) return String;
-- Returns the relative pathname which corresponds to Pathname when
-- starting from directory to. Both Pathname and To must be absolute paths.
procedure Create_Sym_Link (From, To : String);
-- Create a relative symlink in From pointing to To
-- Architecture
function Get_Target return String;
-- Returns the current target for the compilation
function Compute_Slave_Env
(Project : Project_Tree_Ref; Auto : Boolean) return String;
-- Compute a slave environment based on the command line parameter and
-- the project variables. We want the same slave environment for identical
-- build. Data is a string that must be taken into account in the returned
-- value.
function UTC_Time return Types.Time_Stamp_Type;
-- Returns the UTC time
function Check_Diff
(Ts1, Ts2 : Types.Time_Stamp_Type;
Max_Drift : Duration := 5.0) return Boolean;
-- Check two time stamps, returns True if both time are in a range of
-- Max_Drift seconds maximum.
function To_Time_Stamp (Time : Calendar.Time) return Types.Time_Stamp_Type;
-- Returns Time as a time stamp type
end Gpr_Util;
gprbuild-gpl-2014-src/src/gprconfig-knowledge.adb 0000644 0000767 0000145 00000442573 12323721731 021344 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R C O N F I G --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Containers; use Ada.Containers;
with Ada.Directories; use Ada.Directories;
with Ada.Environment_Variables; use Ada.Environment_Variables;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.IO_Exceptions;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Hash;
with Ada.Strings.Hash_Case_Insensitive;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
with DOM.Core.Nodes; use DOM.Core, DOM.Core.Nodes;
with DOM.Core.Documents;
with Schema.Dom_Readers; use Schema.Dom_Readers;
with Schema.Schema_Readers; use Schema.Schema_Readers;
with Schema.Validators; use Schema.Validators;
with Input_Sources.File; use Input_Sources.File;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Expect; use GNAT.Expect;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Regpat; use GNAT.Regpat;
with GNAT.Strings; use GNAT.Strings;
with GprConfig.Sdefault; use GprConfig.Sdefault;
with Makeutl; use Makeutl;
with Namet; use Namet;
with Opt;
with Prj; use Prj;
with Sax.Readers; use Sax.Readers;
package body GprConfig.Knowledge is
package String_Maps is new Ada.Containers.Indefinite_Hashed_Maps
(String, Unbounded_String, Ada.Strings.Hash_Case_Insensitive, "=");
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Pattern_Matcher, Pattern_Matcher_Access);
type External_Value_Item is record
Value : Name_Id;
Alternate : Name_Id := No_Name;
Extracted_From : Name_Id;
end record;
-- Value is the actual value of the node.
-- Extracted_From will either be set to Value itself, or when the node is
-- a to the full directory, before the regexp match.
-- When the value comes from a node, Extracted_From is set to the
-- full output of the shell command.
package External_Value_Lists is new Ada.Containers.Doubly_Linked_Lists
(External_Value_Item);
package String_To_External_Value is new
Ada.Containers.Indefinite_Hashed_Maps
(Key_Type => String,
Element_Type => External_Value_Lists.Cursor,
Hash => Ada.Strings.Hash,
Equivalent_Keys => "=",
"=" => External_Value_Lists."=");
package CDM renames Compiler_Description_Maps;
package CFL renames Compiler_Filter_Lists;
use Compiler_Lists, CFL, Compilers_Filter_Lists;
use Configuration_Lists, String_Maps;
use External_Value_Lists, String_Lists;
use External_Value_Nodes;
Case_Sensitive_Files : constant Boolean := Directory_Separator = '\';
On_Windows : constant Boolean := Directory_Separator = '\';
Ignore_Compiler : exception;
-- Raised when the compiler should be ignored
Indentation_Level : Integer := 0;
-- Current indentation level for traces
function Get_Variable_Value
(Comp : Compiler;
Name : String) return String;
-- Return the value of a predefined or user-defined variable.
-- If the variable is not defined a warning is emitted and an empty
-- string is returned.
function Get_Name_String_Or_Null (Name : Name_Id) return String;
-- Return the string stored in Name (or the empty string if Name is
-- No_Name)
procedure Put_Verbose (Config : Configuration);
-- Debug put for Config
function Get_Attribute
(N : Node; Attribute : String; Default : String) return String;
-- Return the value of an attribute, or Default if the attribute does not
-- exist
function Is_Supported_Config
(Base : Knowledge_Base;
Compilers : Compiler_Lists.List) return Boolean;
-- Whether we know how to link code compiled with all the selected
-- compilers.
function Is_Language_With_No_Compiler
(Base : Knowledge_Base;
Language_LC : String) return Boolean;
-- Given a language name (lower case), returns True if that language is
-- known to require no compiler
function Node_Value_As_String (N : Node) return String;
-- Return the value of the node, concatenating all Text children
function Ends_With (Str, Suffix : String) return Boolean;
-- Whether the string ends with Suffix. Always True if Suffix is the empty
-- string.
procedure Foreach_Compiler_In_Dir
(Iterator : in out Compiler_Iterator'Class;
Base : in out Knowledge_Base;
Directory : String;
From_Extra_Dir : Boolean;
On_Target : Targets_Set_Id;
Path_Order : Integer;
Continue : out Boolean);
-- Find all known compilers in Directory, and call Iterator.Callback as
-- appropriate.
procedure Get_Words
(Words : String;
Filter : Namet.Name_Id;
Separator1 : Character;
Separator2 : Character;
Map : out String_Lists.List;
Allow_Empty_Elements : Boolean);
-- Return the list of words in Words. Splitting is done on special
-- characters, so as to be compatible with a list of languages or a list of
-- runtimes
-- If Allow_Empty_Elements is false, then empty strings are not stored in
-- the list.
function Name_As_Directory (Dir : String) return String;
-- Ensure that Dir ends with a directory separator
function Get_String_No_Adalib (Str : String) return Namet.Name_Id;
-- Return the name without "adalib" at the end
function Get_String (Str : String) return Namet.Name_Id;
function Get_String_Or_No_Name (Str : String) return Namet.Name_Id;
-- Same as Name_Find, but does not require the user to modify
-- Name_Buffer manually.
-- The second version returns No_Name is the string is empty
procedure Get_External_Value
(Attribute : String;
Value : External_Value;
Comp : Compiler;
Split_Into_Words : Boolean := True;
Merge_Same_Dirs : Boolean := False;
Processed_Value : out External_Value_Lists.List);
-- Computes the value of Value, depending on its type. When an external
-- command needs to be executed, Path is put first on the PATH environment
-- variable.
-- Raises Ignore_Compiler if the value doesn't match its
-- regexp.
-- The node is also taken into account.
-- If Split_Into_Words is true, then the value read from or as a
-- constant string is further assumed to be a comma-separated or space-
-- separated string, and split.
-- Comparisong with Matching is case-insensitive (this is needed for
-- languages, does not matter for versions, is not used for targets)
--
-- If Merge_Same_Dirs is True, then the values that come from a
-- node will be merged (the last one is kept, other removed) if
-- they point to the same physical directory (after normalizing names).
--
-- This is only for use within a context.
procedure Foreach_Language_Runtime
(Iterator : in out Compiler_Iterator'Class;
Base : in out Knowledge_Base;
Name : Name_Id;
Executable : Name_Id;
Directory : String;
Prefix : Name_Id;
From_Extra_Dir : Boolean;
On_Target : Targets_Set_Id;
Descr : Compiler_Description;
Path_Order : Integer;
Continue : out Boolean);
-- For each language/runtime parsed in Languages/Runtimes, create a new
-- compiler in the list, if it matches Matching.
-- If Stop_At_First_Match is true, then only the first matching compiler is
-- returned, which provides a significant speedup in some cases
function Is_Windows_Executable (Filename : String) return Boolean;
-- Verify that a given filename is indeed an executable
procedure Parse_All_Dirs
(Processed_Value : out External_Value_Lists.List;
Visited : in out String_To_External_Value.Map;
Current_Dir : String;
Path_To_Check : String;
Regexp : Pattern_Matcher;
Regexp_Str : String;
Value_If_Match : Name_Id;
Group : Integer;
Group_Match : String := "";
Group_Count : Natural := 0;
Contents : Pattern_Matcher_Access := null;
Merge_Same_Dirs : Boolean);
-- Parse all subdirectories of Current_Dir for those that match
-- Path_To_Check (see description of ). When a match is found,
-- the regexp is evaluated against the current directory, and the matching
-- parenthesis group is appended to Append_To (comma-separated).
-- If Group is -1, then Value_If_Match is used instead of the parenthesis
-- group.
-- Group_Match is the substring that matched Group (if it has been matched
-- already). Group_Count is the number of parenthesis groups that have been
-- processed so far. The idea is to compute the matching substring as we
-- go, since the regexp might no longer match in the end, if for instance
-- it includes ".." directories.
--
-- If Merge_Same_Dirs is True, then the values that come from a
-- node will be merged (the last one is kept, other removed) if
-- they point to the same physical directory (after normalizing names). In
-- this case, Visited contains the list of normalized directory names.
--
-- Contents, if specified, is a regular expression. It indicates that any
-- file matching the pattern should be parsed, and the first line matching
-- that regexp should be used as the name of the file instead. This is a
-- way to simulate symbolic links on platforms that do not use them.
generic
with function Callback (Var_Name, Index : String) return String;
function Substitute_Variables (Str : String) return String;
-- Substitute variables in Str (their value is computed through Callback)
function Substitute_Variables_In_Compiler_Description
(Str : String; Comp : Compiler) return String;
function Substitute_Variables_In_Configuration
(Base : Knowledge_Base;
Str : String;
Comps : Compiler_Lists.List) return String;
-- Substitute the special "$..." names.
-- Depending on the XML nodes we are in (specified by the context) the list
-- of variables might be different.
procedure Match
(Filter : Compilers_Filter_Lists.List;
Compilers : Compiler_Lists.List;
Matching_Compiler : out Compiler_Access;
Matched : out Boolean);
procedure Match
(Filter : Compilers_Filter;
Compilers : Compiler_Lists.List;
Matching_Compiler : out Compiler_Access;
Matched : out Boolean);
procedure Match
(Filter : Compiler_Filter;
Compilers : Compiler_Lists.List;
Matching_Compiler : out Compiler_Access;
Matched : out Boolean);
-- Check whether Filter matches (and set Matched to the result).
-- Matching_Compiler is set if there was a single node, and is
-- to set the first compiler that matched in that node
function Match
(Target_Filter : String_Lists.List;
Negate : Boolean;
Compilers : Compiler_Lists.List) return Boolean;
-- Return True if Filter matches the list of selected configurations
procedure Merge_Config
(Base : Knowledge_Base;
Packages : in out String_Maps.Map;
Compilers : Compiler_Lists.List;
Config : String);
-- Merge the contents of Config into Packages, so that each attributes ends
-- up in the right package, and the packages are not duplicated.
-- Selected_Compiler is the compiler that made the chunk match the filters.
-- If there were several filter, No_Compiler should be passed
-- in argument.
procedure Skip_Spaces (Str : String; Index : in out Integer);
-- Move Index from its current position to the next non-whitespace
-- character in Str
procedure Skip_Spaces_Backward (Str : String; Index : in out Integer);
-- Same as Skip_Spaces, but goes backward
function Is_Regexp (Str : String) return Boolean;
-- Whether Str is a regular expression
Exec_Suffix : constant GNAT.Strings.String_Access :=
Get_Executable_Suffix;
function Unquote
(Str : String; Remove_Quoted : Boolean := False) return String;
-- Remove special '\' quoting characters from Str.
-- As a special case, if Remove_Quoted is true, then '\' and the following
-- char are simply omitted in the output.
-- For instance:
-- Str="A\." Remove_Quoted=False => output is "A."
-- Str="A\." Remove_Quoted=False => output is "A"
-------------------
-- Get_Attribute --
-------------------
function Get_Attribute
(N : Node; Attribute : String; Default : String) return String
is
Attr : constant Node := Get_Named_Item (Attributes (N), Attribute);
begin
if Attr = null then
return Default;
else
return Node_Value (Attr);
end if;
end Get_Attribute;
--------------------------
-- Node_Value_As_String --
--------------------------
function Node_Value_As_String (N : Node) return String is
Result : Unbounded_String;
Child : Node := First_Child (N);
begin
while Child /= null loop
exit when Node_Type (Child) = Element_Node;
Append (Result, Node_Value (Child));
Child := Next_Sibling (Child);
end loop;
return To_String (Result);
end Node_Value_As_String;
-------------
-- Unquote --
-------------
function Unquote
(Str : String; Remove_Quoted : Boolean := False) return String
is
Str2 : String (Str'Range);
S : Integer := Str'First;
Index : Integer := Str2'First;
begin
while S <= Str'Last loop
if Str (S) = '\' then
S := S + 1;
if not Remove_Quoted then
Str2 (Index) := Str (S);
Index := Index + 1;
end if;
else
Str2 (Index) := Str (S);
Index := Index + 1;
end if;
S := S + 1;
end loop;
return Str2 (Str2'First .. Index - 1);
end Unquote;
---------------
-- Ends_With --
---------------
function Ends_With (Str, Suffix : String) return Boolean is
begin
return Suffix = ""
or else
(Str'Length >= Suffix'Length
and then Str (Str'Last - Suffix'Length + 1 .. Str'Last) = Suffix);
end Ends_With;
---------------------------
-- Is_Windows_Executable --
---------------------------
function Is_Windows_Executable (Filename : String) return Boolean is
type Byte is mod 256;
for Byte'Size use 8;
for Byte'Alignment use 1;
type Bytes is array (Positive range <>) of Byte;
Windows_Pattern : constant Bytes := (77, 90, 144, 0);
Fd : constant File_Descriptor := Open_Read (Filename, Binary);
B : Bytes (1 .. 4);
N_Read : Integer;
begin
N_Read := Read (Fd, B'Address, 4);
Close (Fd);
if N_Read < 4 then
return False;
else
if B = Windows_Pattern then
return True;
else
return False;
end if;
end if;
end Is_Windows_Executable;
---------------
-- Is_Regexp --
---------------
function Is_Regexp (Str : String) return Boolean is
-- Take into account characters quoted by '\'. We just remove them for
-- now, so that when we quote the regexp it won't see these potentially
-- special characters.
-- The goal is that for instance "\.\." is not considered as a regexp,
-- but "\.." is.
Str2 : constant String := Unquote (Str, Remove_Quoted => True);
begin
return GNAT.Regpat.Quote (Str2) /= Str2;
end Is_Regexp;
-----------------
-- Put_Verbose --
-----------------
procedure Put_Verbose (Str : String; Indent_Delta : Integer := 0) is
begin
if Current_Verbosity /= Default then
if Indent_Delta < 0 then
Indentation_Level := Indentation_Level - 2;
end if;
if Str /= "" then
Put_Line (Standard_Error, (1 .. Indentation_Level => ' ') & Str);
end if;
if Indent_Delta > 0 then
Indentation_Level := Indentation_Level + 2;
end if;
end if;
end Put_Verbose;
-----------------------
-- Name_As_Directory --
-----------------------
function Name_As_Directory (Dir : String) return String is
begin
if Dir = ""
or else Dir (Dir'Last) = Directory_Separator
or else Dir (Dir'Last) = '/'
then
return Dir;
else
return Dir & Directory_Separator;
end if;
end Name_As_Directory;
----------------------------------
-- Is_Language_With_No_Compiler --
----------------------------------
function Is_Language_With_No_Compiler
(Base : Knowledge_Base;
Language_LC : String) return Boolean
is
C : String_Lists.Cursor := First (Base.No_Compilers);
begin
while Has_Element (C) loop
if String_Lists.Element (C) = Language_LC then
return True;
end if;
Next (C);
end loop;
return False;
end Is_Language_With_No_Compiler;
RTS_List : GNAT.OS_Lib.String_List_Access :=
new GNAT.OS_Lib.String_List (1 .. 4);
-- List of the knowledge base directories that hac=ve already been parsed
RTS_Last : Natural := 0;
-- Index of the last directory in RTS_List
--------------------------
-- Parse_Knowledge_Base --
--------------------------
procedure Parse_Knowledge_Base
(Base : in out Knowledge_Base;
Directory : String;
Parse_Compiler_Info : Boolean := True;
Validate : Boolean := False)
is
procedure Parse_Compiler_Description
(Base : in out Knowledge_Base;
File : String;
Description : Node);
-- Parse a compiler description described by N. Appends the result to
-- Base.Compilers or Base.No_Compilers
procedure Parse_Configuration
(Append_To : in out Configuration_Lists.List;
File : String;
Description : Node);
-- Parse a configuration node
procedure Parse_Targets_Set
(Append_To : in out Targets_Set_Vectors.Vector;
File : String;
Description : Node);
-- Parse a targets set node
--------------------------------
-- Parse_Compiler_Description --
--------------------------------
procedure Parse_Compiler_Description
(Base : in out Knowledge_Base;
File : String;
Description : Node)
is
procedure Parse_External_Value
(Value : out External_Value;
File : String;
External : Node);
-- Parse an XML node that describes an external value
--------------------------
-- Parse_External_Value --
--------------------------
procedure Parse_External_Value
(Value : out External_Value;
File : String;
External : Node)
is
Tmp : Node := First_Child (External);
External_Node : External_Value_Node;
Is_Done : Boolean := True;
Static_Value : constant String := Node_Value_As_String (External);
Has_Static : Boolean := False;
begin
for S in Static_Value'Range loop
if Static_Value (S) /= ' '
and then Static_Value (S) /= ASCII.LF
then
Has_Static := True;
exit;
end if;
end loop;
-- Constant value is not within a nested node
if Has_Static then
External_Node :=
(Typ => Value_Constant,
Value => Get_String (Static_Value));
Append (Value, External_Node);
Is_Done := False;
end if;
while Tmp /= null loop
if Node_Type (Tmp) /= Element_Node then
null;
elsif Node_Name (Tmp) = "external" then
if not Is_Done then
Append (Value, (Typ => Value_Done));
end if;
External_Node :=
(Typ => Value_Shell,
Command => Get_String (Node_Value_As_String (Tmp)));
Append (Value, External_Node);
Is_Done := False;
elsif Node_Name (Tmp) = "directory" then
declare
C : constant String :=
Get_Attribute (Tmp, "contents", "");
Contents : Pattern_Matcher_Access;
begin
if C /= "" then
Contents := new Pattern_Matcher'(Compile (C));
end if;
External_Node :=
(Typ => Value_Directory,
Directory => Get_String
(Node_Value_As_String (Tmp)),
Contents => Contents,
Dir_If_Match => No_Name,
Directory_Group => 0);
end;
begin
External_Node.Directory_Group := Integer'Value
(Get_Attribute (Tmp, "group", "0"));
exception
when Constraint_Error =>
External_Node.Directory_Group := -1;
External_Node.Dir_If_Match :=
Get_String (Get_Attribute (Tmp, "group", "0"));
end;
Append (Value, External_Node);
Is_Done := True;
elsif Node_Name (Tmp) = "getenv" then
if not Is_Done then
Append (Value, (Typ => Value_Done));
end if;
declare
Name : constant String := Get_Attribute (Tmp, "name", "");
begin
if Ada.Environment_Variables.Exists (Name) then
External_Node :=
(Typ => Value_Constant,
Value => Get_String
(Ada.Environment_Variables.Value (Name)));
else
Put_Verbose ("warning: environment variable '" & Name
& "' is not defined");
External_Node :=
(Typ => Value_Constant,
Value => No_Name);
end if;
end;
Append (Value, External_Node);
Is_Done := False;
elsif Node_Name (Tmp) = "filter" then
External_Node :=
(Typ => Value_Filter,
Filter => Get_String (Node_Value_As_String (Tmp)));
Append (Value, External_Node);
Is_Done := True;
elsif Node_Name (Tmp) = "must_match" then
External_Node :=
(Typ => Value_Must_Match,
Must_Match => Get_String (Node_Value_As_String (Tmp)));
Append (Value, External_Node);
Is_Done := True;
elsif Node_Name (Tmp) = "grep" then
External_Node :=
(Typ => Value_Grep,
Regexp_Re => new Pattern_Matcher'
(Compile (Get_Attribute (Tmp, "regexp", ".*"),
Multiple_Lines)),
Group => Integer'Value
(Get_Attribute (Tmp, "group", "0")));
Append (Value, External_Node);
elsif Node_Name (Tmp) = "nogrep" then
External_Node :=
(Typ => Value_Nogrep,
Regexp_No => new Pattern_Matcher'
(Compile (Get_Attribute (Tmp, "regexp", ".*"),
Multiple_Lines)));
Append (Value, External_Node);
else
Put_Line (Standard_Error, "Invalid XML description for "
& Node_Name (External) & " in file " & File);
Put_Line
(Standard_Error, " Invalid tag: " & Node_Name (Tmp));
Value := Null_External_Value;
end if;
Tmp := Next_Sibling (Tmp);
end loop;
if not Is_Done then
Append (Value, (Typ => Value_Done));
end if;
exception
when Constraint_Error =>
Put_Line (Standard_Error, "Invalid group number for "
& Node_Name (External)
& " in file " & File);
Value := Null_External_Value;
end Parse_External_Value;
Compiler : Compiler_Description;
N : Node := First_Child (Description);
Lang : External_Value_Lists.List;
C : External_Value_Lists.Cursor;
begin
while N /= null loop
if Node_Type (N) /= Element_Node then
null;
elsif Node_Name (N) = "executable" then
declare
Prefix : constant String :=
Get_Attribute (N, "prefix", "@@");
Val : constant String := Node_Value_As_String (N);
begin
if Val = "" then
-- A special language that requires no executable. We do
-- not store it in the list of compilers, since these
-- should not be detected on the PATH anyway.
Compiler.Executable := No_Name;
else
Compiler.Executable := Get_String (Val);
begin
Compiler.Prefix_Index := Integer'Value (Prefix);
exception
when Constraint_Error =>
Compiler.Prefix_Index := -1;
end;
if not Ends_With (Val, Exec_Suffix.all) then
Compiler.Executable_Re := new Pattern_Matcher'
(Compile ("^" & Val & Exec_Suffix.all & "$"));
else
Compiler.Executable_Re := new Pattern_Matcher'
(Compile ("^" & Val & "$"));
end if;
Base.Check_Executable_Regexp := True;
end if;
exception
when Expression_Error =>
Put_Line
(Standard_Error,
"Invalid regular expression found in the configuration"
& " files: " & Val
& " while parsing " & File);
Unchecked_Free (Compiler.Executable_Re);
end;
elsif Node_Name (N) = "name" then
Compiler.Name := Get_String (Node_Value_As_String (N));
elsif Node_Name (N) = "version" then
Parse_External_Value
(Value => Compiler.Version,
File => File,
External => N);
elsif Node_Name (N) = "variable" then
declare
Name : constant String := Get_Attribute (N, "name", "@@");
begin
Append (Compiler.Variables, (Typ => Value_Variable,
Var_Name => Get_String (Name)));
Parse_External_Value
(Value => Compiler.Variables,
File => File,
External => N);
end;
elsif Node_Name (N) = "languages" then
Parse_External_Value
(Value => Compiler.Languages,
File => File,
External => N);
elsif Node_Name (N) = "runtimes" then
declare
Defaults : constant String :=
Get_Attribute (N, "default", "");
begin
if Defaults /= "" then
Get_Words (Defaults, No_Name, ' ', ',',
Compiler.Default_Runtimes, False);
end if;
Parse_External_Value
(Value => Compiler.Runtimes,
File => File,
External => N);
end;
elsif Node_Name (N) = "target" then
Parse_External_Value
(Value => Compiler.Target,
File => File,
External => N);
else
Put_Line
(Standard_Error, "Unknown XML tag in " & File & ": "
& Node_Name (N));
raise Invalid_Knowledge_Base;
end if;
N := Next_Sibling (N);
end loop;
if Compiler.Executable = No_Name then
Get_External_Value
(Attribute => "languages",
Value => Compiler.Languages,
Comp => No_Compiler,
Split_Into_Words => True,
Processed_Value => Lang);
C := First (Lang);
while Has_Element (C) loop
String_Lists.Append
(Base.No_Compilers,
To_Lower
(Get_Name_String
(External_Value_Lists.Element (C).Value)));
Next (C);
end loop;
elsif Compiler.Name /= No_Name then
CDM.Include (Base.Compilers, Compiler.Name, Compiler);
end if;
end Parse_Compiler_Description;
-------------------------
-- Parse_Configuration --
-------------------------
procedure Parse_Configuration
(Append_To : in out Configuration_Lists.List;
File : String;
Description : Node)
is
Config : Configuration;
Chunk : Unbounded_String;
N : Node := First_Child (Description);
N2 : Node;
Compilers : Compilers_Filter;
Ignore_Config : Boolean := False;
Negate : Boolean;
Filter : Compiler_Filter;
begin
Config.Supported := True;
while N /= null loop
if Node_Type (N) /= Element_Node then
null;
elsif Node_Name (N) = "compilers" then
Compilers := No_Compilers_Filter;
N2 := First_Child (N);
while N2 /= null loop
if Node_Type (N2) /= Element_Node then
null;
elsif Node_Name (N2) = "compiler" then
declare
Version : constant String :=
Get_Attribute (N2, "version", "");
Runtime : constant String :=
Get_Attribute (N2, "runtime", "");
begin
Filter := Compiler_Filter'
(Name => Get_String_Or_No_Name
(Get_Attribute (N2, "name", "")),
Version => Get_String_Or_No_Name (Version),
Version_Re => null,
Runtime => Get_String_Or_No_Name (Runtime),
Runtime_Re => null,
Language_LC => Get_String_Or_No_Name
(To_Lower (Get_Attribute (N2, "language", ""))));
if Version /= "" then
Filter.Version_Re := new Pattern_Matcher'
(Compile (Version, Case_Insensitive));
end if;
if Runtime /= "" then
Filter.Runtime_Re := new Pattern_Matcher'
(Compile (Runtime, Case_Insensitive));
end if;
end;
Append (Compilers.Compiler, Filter);
else
Put_Line
(Standard_Error, "Unknown XML tag in " & File & ": "
& Node_Name (N2));
raise Invalid_Knowledge_Base;
end if;
N2 := Next_Sibling (N2);
end loop;
Compilers.Negate := Boolean'Value
(Get_Attribute (N, "negate", "False"));
Append (Config.Compilers_Filters, Compilers);
elsif Node_Name (N) = "targets" then
if not Is_Empty (Config.Targets_Filters) then
Put_Line (Standard_Error,
"Can have a single filter in " & File);
else
N2 := First_Child (N);
while N2 /= null loop
if Node_Type (N2) /= Element_Node then
null;
elsif Node_Name (N2) = "target" then
Append (Config.Targets_Filters,
Get_Attribute (N2, "name", ""));
else
Put_Line
(Standard_Error, "Unknown XML tag in " & File & ": "
& Node_Name (N2));
raise Invalid_Knowledge_Base;
end if;
N2 := Next_Sibling (N2);
end loop;
Config.Negate_Targets := Boolean'Value
(Get_Attribute (N, "negate", "False"));
end if;
elsif Node_Name (N) = "hosts" then
-- Resolve this filter immediately. This saves memory, since we
-- don't need to store it in memory if we know it won't apply.
N2 := First_Child (N);
Negate := Boolean'Value
(Get_Attribute (N, "negate", "False"));
Ignore_Config := not Negate;
while N2 /= null loop
if Node_Type (N2) /= Element_Node then
null;
elsif Node_Name (N2) = "host" then
if Match
(Get_Attribute (N2, "name", ""), Sdefault.Hostname)
then
Ignore_Config := Negate;
exit;
end if;
else
Put_Line
(Standard_Error, "Unknown XML tag in " & File & ": "
& Node_Name (N2));
raise Invalid_Knowledge_Base;
end if;
N2 := Next_Sibling (N2);
end loop;
exit when Ignore_Config;
elsif Node_Name (N) = "config" then
if Node_Value_As_String (N) = "" then
Config.Supported := False;
else
Append (Chunk, Node_Value_As_String (N));
end if;
else
Put_Line (Standard_Error, "Unknown XML tag in " & File & ": "
& Node_Name (N));
raise Invalid_Knowledge_Base;
end if;
N := Next_Sibling (N);
end loop;
if not Ignore_Config then
Config.Config := Get_String (To_String (Chunk));
Append (Append_To, Config);
end if;
end Parse_Configuration;
-----------------------
-- Parse_Targets_Set --
-----------------------
procedure Parse_Targets_Set
(Append_To : in out Targets_Set_Vectors.Vector;
File : String;
Description : Node)
is
Name : Name_Id := No_Name;
Set : Target_Lists.List;
Pattern : Pattern_Matcher_Access;
N : Node := First_Child (Description);
begin
while N /= null loop
if Node_Type (N) /= Element_Node then
null;
elsif Node_Name (N) = "target" then
declare
Val : constant String := Node_Value_As_String (N);
begin
Pattern := new Pattern_Matcher'(Compile ("^" & Val & "$"));
Target_Lists.Append (Set, Pattern);
if Name = No_Name then
Name := Get_String (Val);
end if;
exception
when Expression_Error =>
Put_Line
("Invalid regular expression " & Val
& " found in the target-set while parsing " & File);
raise Invalid_Knowledge_Base;
end;
else
Put_Line (Standard_Error, "Unknown XML tag in " & File & ": "
& Node_Name (N));
raise Invalid_Knowledge_Base;
end if;
N := Next_Sibling (N);
end loop;
if not Target_Lists.Is_Empty (Set) then
Targets_Set_Vectors.Append (Append_To, (Name, Set));
end if;
end Parse_Targets_Set;
Search : Search_Type;
File : Directory_Entry_Type;
File_Node : Node;
N : Node;
Reader : Schema.Dom_Readers.Tree_Reader;
Input : File_Input;
Schema : Schema_Reader;
Dir : constant String :=
Normalize_Pathname (Directory, Case_Sensitive => False);
begin
-- Do not parse several times the same database directory
for J in 1 .. RTS_Last loop
if RTS_List (J).all = Dir then
return;
end if;
end loop;
-- Extend RTS_List if it is full
if RTS_Last = RTS_List'Last then
declare
New_List : constant GNAT.OS_Lib.String_List_Access :=
new GNAT.OS_Lib.String_List (1 .. RTS_List'Length * 2);
begin
New_List (1 .. RTS_Last) := RTS_List (1 .. RTS_Last);
RTS_List := New_List;
end;
end if;
RTS_Last := RTS_Last + 1;
RTS_List (RTS_Last) := new String'(Dir);
if Current_Verbosity = High then
Standard.Schema.Set_Debug_Output (True);
end if;
Reader.Set_Feature (Schema_Validation_Feature, Validate);
Reader.Set_Feature (Validation_Feature, False); -- Do not use DTD
if Validate then
-- Load the XSD file used to validate the knowledge base
declare
Filename : constant String :=
Format_Pathname
(Default_Knowledge_Base_Directory
& "/gprconfig.xsd");
XSD : File_Input;
begin
Put_Verbose ("Parsing " & Filename);
Open (Filename, XSD);
Parse (Schema, XSD);
Close (XSD);
Reader.Set_Grammar (Get_Grammar (Schema));
Free (Schema);
exception
when Ada.Directories.Name_Error =>
Put_Line
(Standard_Error,
"Installation error: could not find the file " & Filename);
raise Knowledge_Base_Validation_Error;
when XML_Validation_Error =>
Put_Line (Standard_Error, Get_Error_Message (Schema));
raise Knowledge_Base_Validation_Error;
end;
end if;
Put_Verbose ("Parsing knowledge base at " & Dir);
Start_Search
(Search,
Directory => Dir,
Pattern => "*.xml",
Filter => (Ordinary_File => True, others => False));
while More_Entries (Search) loop
Get_Next_Entry (Search, File);
Put_Verbose ("Parsing file " & Full_Name (File));
Open (Full_Name (File), Input);
Parse (Reader, Input);
Close (Input);
File_Node := DOM.Core.Documents.Get_Element (Get_Tree (Reader));
if Node_Name (File_Node) = "gprconfig" then
N := First_Child (File_Node);
while N /= null loop
if Node_Type (N) /= Element_Node then
null;
elsif Node_Name (N) = "compiler_description" then
if Parse_Compiler_Info then
Parse_Compiler_Description
(Base => Base,
File => Simple_Name (File),
Description => N);
end if;
elsif Node_Name (N) = "configuration" then
if Parse_Compiler_Info then
Parse_Configuration
(Append_To => Base.Configurations,
File => Simple_Name (File),
Description => N);
end if;
elsif Node_Name (N) = "targetset" then
Parse_Targets_Set
(Append_To => Base.Targets_Sets,
File => Simple_Name (File),
Description => N);
else
Put_Line (Standard_Error,
"Unknown XML tag in " & Simple_Name (File) & ": "
& Node_Name (N));
raise Invalid_Knowledge_Base;
end if;
N := Next_Sibling (N);
end loop;
else
Put_Line (Standard_Error,
"Invalid toplevel XML tag in " & Simple_Name (File));
end if;
Free (Reader);
end loop;
End_Search (Search);
exception
when Ada.Directories.Name_Error =>
Put_Verbose ("Directory not found: " & Directory);
when Invalid_Knowledge_Base | Knowledge_Base_Validation_Error =>
raise;
when E : XML_Fatal_Error =>
Put_Line (Standard_Error, Exception_Message (E));
raise Invalid_Knowledge_Base;
when XML_Validation_Error =>
Put_Line (Standard_Error, Get_Error_Message (Reader));
raise Knowledge_Base_Validation_Error;
when E : others =>
Put_Line
(Standard_Error,
"Unexpected exception while parsing knowledge base: "
& Exception_Information (E));
raise Invalid_Knowledge_Base;
end Parse_Knowledge_Base;
------------------------
-- Get_Variable_Value --
------------------------
function Get_Variable_Value
(Comp : Compiler;
Name : String) return String
is
N : constant Name_Id := Get_String (Name);
begin
if Variables_Maps.Contains (Comp.Variables, N) then
return Get_Name_String (Variables_Maps.Element (Comp.Variables, N));
elsif Name = "HOST" then
return Sdefault.Hostname;
elsif Name = "TARGET" then
return Get_Name_String (Comp.Target);
elsif Name = "RUNTIME_DIR" then
return Name_As_Directory (Get_Name_String (Comp.Runtime_Dir));
elsif Name = "EXEC" then
return Get_Name_String_Or_Null (Comp.Executable);
elsif Name = "VERSION" then
return Get_Name_String_Or_Null (Comp.Version);
elsif Name = "LANGUAGE" then
return Get_Name_String_Or_Null (Comp.Language_LC);
elsif Name = "RUNTIME" then
return Get_Name_String_Or_Null (Comp.Runtime);
elsif Name = "PREFIX" then
return Get_Name_String_Or_Null (Comp.Prefix);
elsif Name = "PATH" then
return Get_Name_String (Comp.Path);
elsif Name = "GPRCONFIG_PREFIX" then
return Executable_Prefix_Path;
end if;
raise Invalid_Knowledge_Base
with "variable '" & Name & "' is not defined";
end Get_Variable_Value;
--------------------------
-- Substitute_Variables --
--------------------------
function Substitute_Variables (Str : String) return String is
Str_Len : constant Natural := Str'Last;
Pos : Natural := Str'First;
Last : Natural := Pos;
Result : Unbounded_String;
Word_Start, Word_End, Tmp : Natural;
Has_Index : Boolean;
begin
while Pos < Str_Len loop
if Str (Pos) = '$' and then Str (Pos + 1) = '$' then
Append (Result, Str (Last .. Pos - 1));
Append (Result, "$");
Last := Pos + 2;
Pos := Last;
elsif Str (Pos) = '$' then
if Str (Pos + 1) = '{' then
Word_Start := Pos + 2;
Tmp := Pos + 2;
while Tmp <= Str_Len and then Str (Tmp) /= '}' loop
Tmp := Tmp + 1;
end loop;
Tmp := Tmp + 1;
Word_End := Tmp - 2;
else
Word_Start := Pos + 1;
Tmp := Pos + 1;
while Tmp <= Str_Len
and then (Is_Alphanumeric (Str (Tmp)) or else Str (Tmp) = '_')
loop
Tmp := Tmp + 1;
end loop;
Word_End := Tmp - 1;
end if;
Append (Result, Str (Last .. Pos - 1));
Has_Index := False;
for W in Word_Start .. Word_End loop
if Str (W) = '(' then
Has_Index := True;
if Str (Word_End) /= ')' then
Put_Line
(Standard_Error,
"Missing closing parenthesis in variable name: "
& Str (Word_Start .. Word_End));
raise Invalid_Knowledge_Base;
else
Append
(Result,
Callback
(Var_Name => Str (Word_Start .. W - 1),
Index => Str (W + 1 .. Word_End - 1)));
end if;
exit;
end if;
end loop;
if not Has_Index then
Append (Result, Callback (Str (Word_Start .. Word_End), ""));
end if;
Last := Tmp;
Pos := Last;
else
Pos := Pos + 1;
end if;
end loop;
Append (Result, Str (Last .. Str_Len));
return To_String (Result);
end Substitute_Variables;
--------------------------------------------------
-- Substitute_Variables_In_Compiler_Description --
--------------------------------------------------
function Substitute_Variables_In_Compiler_Description
(Str : String;
Comp : Compiler) return String
is
function Callback (Var_Name, Index : String) return String;
--------------
-- Callback --
--------------
function Callback (Var_Name, Index : String) return String is
begin
if Index /= "" then
Put_Line
(Standard_Error,
"Indexed variables only allowed in (in "
& Var_Name & "(" & Index & ")");
raise Invalid_Knowledge_Base;
end if;
return Get_Variable_Value (Comp, Var_Name);
end Callback;
function Do_Substitute is new Substitute_Variables (Callback);
begin
return Do_Substitute (Str);
end Substitute_Variables_In_Compiler_Description;
-------------------------------------------
-- Substitute_Variables_In_Configuration --
-------------------------------------------
function Substitute_Variables_In_Configuration
(Base : Knowledge_Base;
Str : String;
Comps : Compiler_Lists.List) return String
is
function Callback (Var_Name, Index : String) return String;
--------------
-- Callback --
--------------
function Callback (Var_Name, Index : String) return String is
C : Compiler_Lists.Cursor;
Comp : Compiler_Access;
Idx : constant Name_Id := Get_String_Or_No_Name (To_Lower (Index));
begin
if Var_Name = "GPRCONFIG_PREFIX" then
return Executable_Prefix_Path;
elsif Index = "" then
if Var_Name = "TARGET"
and then not Is_Empty (Comps)
then
-- Can have an optional language index.
-- If there is no index, all compilers share the same target,
-- so just take that of the first compiler in the list
return Normalized_Target
(Base,
Compiler_Lists.Element (First (Comps)).Targets_Set);
else
Put_Line
(Standard_Error,
"Ambiguous variable substitution, need to specify the"
& " language (in " & Var_Name & ")");
raise Invalid_Knowledge_Base;
end if;
else
C := First (Comps);
while Has_Element (C) loop
Comp := Compiler_Lists.Element (C);
if Comp.Selected
and then Comp.Language_LC = Idx
then
return Get_Variable_Value (Comp.all, Var_Name);
end if;
Next (C);
end loop;
end if;
return "";
end Callback;
function Do_Substitute is new Substitute_Variables (Callback);
begin
return Do_Substitute (Str);
end Substitute_Variables_In_Configuration;
--------------------
-- Parse_All_Dirs --
--------------------
procedure Parse_All_Dirs
(Processed_Value : out External_Value_Lists.List;
Visited : in out String_To_External_Value.Map;
Current_Dir : String;
Path_To_Check : String;
Regexp : Pattern_Matcher;
Regexp_Str : String;
Value_If_Match : Name_Id;
Group : Integer;
Group_Match : String := "";
Group_Count : Natural := 0;
Contents : Pattern_Matcher_Access := null;
Merge_Same_Dirs : Boolean)
is
procedure Save_File (Current_Dir : String; Val : Name_Id);
-- Mark the given directory as valid for the configuration.
-- This takes care of removing duplicates if needed.
---------------
-- Save_File --
---------------
procedure Save_File (Current_Dir : String; Val : Name_Id) is
begin
if not Merge_Same_Dirs then
Put_Verbose (": SAVE " & Current_Dir);
Append
(Processed_Value,
(Value => Val,
Alternate => No_Name,
Extracted_From => Get_String_No_Adalib (Current_Dir)));
else
declare
use String_To_External_Value;
Normalized : constant String := Normalize_Pathname
(Name => Current_Dir,
Directory => "",
Resolve_Links => True,
Case_Sensitive => True);
Prev : External_Value_Lists.Cursor;
Rec : External_Value_Item;
begin
if Visited.Contains (Normalized) then
Put_Verbose (": ALREADY FOUND ("
& Get_Name_String (Val) & ") "
& Current_Dir);
Prev := Visited.Element (Normalized);
Rec := External_Value_Lists.Element (Prev);
Rec.Alternate := Val;
External_Value_Lists.Replace_Element
(Container => Processed_Value,
Position => Prev,
New_Item => Rec);
else
Put_Verbose (": SAVE (" & Get_Name_String (Val)
& ") " & Current_Dir);
Append
(Processed_Value,
(Value => Val,
Alternate => No_Name,
Extracted_From => Get_String_No_Adalib (Current_Dir)));
Visited.Include
(Normalized, External_Value_Lists.Last (Processed_Value));
end if;
end;
end if;
end Save_File;
First : constant Integer := Path_To_Check'First;
Last : Integer;
Val : Name_Id;
begin
if Path_To_Check'Length = 0
or else Path_To_Check = "/"
or else Path_To_Check = "" & Directory_Separator
then
if Group = -1 then
Val := Value_If_Match;
else
Val := Get_String (Group_Match);
end if;
if Contents /= null
and then Is_Regular_File (Current_Dir)
then
Put_Verbose (": Checking inside file " & Current_Dir);
declare
F : File_Type;
begin
Open (F, In_File, Current_Dir);
while not End_Of_File (F) loop
declare
Line : constant String := Get_Line (F);
begin
Put_Verbose (": read line " & Line);
if Match (Contents.all, Line) then
Save_File
(Normalize_Pathname
(Name => Line,
Directory => Dir_Name (Current_Dir),
Resolve_Links => True),
Val);
exit;
end if;
end;
end loop;
Close (F);
end;
else
Save_File (Current_Dir, Val);
end if;
else
-- Do not split on '\', since we document we only accept UNIX paths
-- anyway. This leaves \ for regexp quotes
Last := First + 1;
while Last <= Path_To_Check'Last
and then Path_To_Check (Last) /= '/'
loop
Last := Last + 1;
end loop;
-- If we do not have a regexp.
if not Is_Regexp (Path_To_Check (First .. Last - 1)) then
declare
Dir : constant String :=
Normalize_Pathname
(Current_Dir, Resolve_Links => False)
& Directory_Separator
& Unquote (Path_To_Check (First .. Last - 1));
Remains : constant String :=
Path_To_Check (Last + 1 .. Path_To_Check'Last);
begin
if (Remains'Length = 0
or else Remains = "/"
or else Remains = "" & Directory_Separator)
and then Is_Regular_File (Dir)
then
Put_Verbose (": Found file " & Dir);
-- If there is such a subdir, keep checking
Parse_All_Dirs
(Processed_Value => Processed_Value,
Visited => Visited,
Current_Dir => Dir,
Path_To_Check => Remains,
Regexp => Regexp,
Regexp_Str => Regexp_Str,
Value_If_Match => Value_If_Match,
Group => Group,
Group_Match => Group_Match,
Group_Count => Group_Count,
Contents => Contents,
Merge_Same_Dirs => Merge_Same_Dirs);
elsif Is_Directory (Dir) then
Put_Verbose (": Recurse into " & Dir);
-- If there is such a subdir, keep checking
Parse_All_Dirs
(Processed_Value => Processed_Value,
Visited => Visited,
Current_Dir => Dir & Directory_Separator,
Path_To_Check => Remains,
Regexp => Regexp,
Regexp_Str => Regexp_Str,
Value_If_Match => Value_If_Match,
Group => Group,
Group_Match => Group_Match,
Group_Count => Group_Count,
Contents => Contents,
Merge_Same_Dirs => Merge_Same_Dirs);
else
Put_Verbose (": No such directory: " & Dir);
end if;
end;
-- Else we have a regexp, check all files
else
declare
File_Re : constant String :=
Path_To_Check (First .. Last - 1);
File_Regexp : constant Pattern_Matcher := Compile (File_Re);
Search : Search_Type;
File : Directory_Entry_Type;
Filter : Ada.Directories.Filter_Type;
begin
if Current_Verbosity /= Default and then File_Re = ".." then
Put_Verbose
("Potential error: .. is generally not meant as a regexp,"
& " and should be quoted in this case, as in \.\.");
end if;
if Path_To_Check (Last) = '/' then
Put_Verbose
(": Check directories in " & Current_Dir
& " that match " & File_Re);
Filter := (Directory => True, others => False);
else
Put_Verbose
(": Check files in " & Current_Dir
& " that match " & File_Re);
Filter := (others => True);
end if;
Start_Search
(Search => Search,
Directory => Current_Dir,
Filter => Filter,
Pattern => "");
while More_Entries (Search) loop
Get_Next_Entry (Search, File);
if Simple_Name (File) /= "."
and then Simple_Name (File) /= ".."
then
declare
Matched : Match_Array (0 .. Integer'Max (Group, 0));
Simple : constant String := Simple_Name (File);
Count : constant Natural :=
Paren_Count (File_Regexp);
begin
Match (File_Regexp, Simple, Matched);
if Matched (0) /= No_Match then
Put_Verbose
(": Matched " & Simple_Name (File));
if Group_Count < Group
and then Group_Count + Count >= Group
then
Put_Verbose
(": Found matched group: "
& Simple (Matched (Group - Group_Count).First
.. Matched (Group - Group_Count).Last));
Parse_All_Dirs
(Processed_Value => Processed_Value,
Visited => Visited,
Current_Dir =>
Full_Name (File) & Directory_Separator,
Path_To_Check => Path_To_Check
(Last + 1 .. Path_To_Check'Last),
Regexp => Regexp,
Regexp_Str => Regexp_Str,
Value_If_Match => Value_If_Match,
Group => Group,
Group_Match =>
Simple (Matched (Group - Group_Count).First
.. Matched (Group - Group_Count).Last),
Group_Count => Group_Count + Count,
Contents => Contents,
Merge_Same_Dirs => Merge_Same_Dirs);
else
Parse_All_Dirs
(Processed_Value => Processed_Value,
Visited => Visited,
Current_Dir =>
Full_Name (File) & Directory_Separator,
Path_To_Check => Path_To_Check
(Last + 1 .. Path_To_Check'Last),
Regexp => Regexp,
Regexp_Str => Regexp_Str,
Value_If_Match => Value_If_Match,
Group => Group,
Group_Match => Group_Match,
Group_Count => Group_Count + Count,
Contents => Contents,
Merge_Same_Dirs => Merge_Same_Dirs);
end if;
end if;
end;
end if;
end loop;
end;
end if;
end if;
end Parse_All_Dirs;
------------------------
-- Get_External_Value --
------------------------
procedure Get_External_Value
(Attribute : String;
Value : External_Value;
Comp : Compiler;
Split_Into_Words : Boolean := True;
Merge_Same_Dirs : Boolean := False;
Processed_Value : out External_Value_Lists.List)
is
Saved_Path : constant String :=
Ada.Environment_Variables.Value ("PATH");
Status : aliased Integer;
Extracted_From : Name_Id := No_Name;
Tmp_Result : Unbounded_String;
Node_Cursor : External_Value_Nodes.Cursor := First (Value);
Node : External_Value_Node;
From_Static : Boolean := False;
Visited : String_To_External_Value.Map;
begin
Clear (Processed_Value);
while Has_Element (Node_Cursor) loop
while Has_Element (Node_Cursor) loop
Node := External_Value_Nodes.Element (Node_Cursor);
case Node.Typ is
when Value_Variable =>
Extracted_From := Node.Var_Name;
when Value_Constant =>
if Node.Value = No_Name then
Tmp_Result := Null_Unbounded_String;
else
Tmp_Result := To_Unbounded_String
(Substitute_Variables_In_Compiler_Description
(Get_Name_String (Node.Value), Comp));
end if;
From_Static := True;
Put_Verbose
(Attribute & ": constant := " & To_String (Tmp_Result));
when Value_Shell =>
Ada.Environment_Variables.Set
("PATH",
Get_Name_String (Comp.Path)
& Path_Separator & Saved_Path);
declare
Command : constant String :=
Substitute_Variables_In_Compiler_Description
(Get_Name_String (Node.Command), Comp);
begin
Tmp_Result := Null_Unbounded_String;
declare
Args : Argument_List_Access :=
Argument_String_To_List (Command);
Output : constant String := Get_Command_Output
(Command => Args (Args'First).all,
Arguments => Args (Args'First + 1 .. Args'Last),
Input => "",
Status => Status'Unchecked_Access,
Err_To_Out => True);
begin
GNAT.Strings.Free (Args);
Ada.Environment_Variables.Set ("PATH", Saved_Path);
Tmp_Result := To_Unbounded_String (Output);
if Current_Verbosity = High then
Put_Verbose (Attribute & ": executing """ & Command
& """ output=""" & Output & """");
elsif Current_Verbosity = Medium then
Put_Verbose
(Attribute & ": executing """ & Command
& """ output= no match");
end if;
end;
exception
when Invalid_Process =>
Put_Verbose ("Spawn failed for " & Command);
end;
when Value_Directory =>
declare
Search : constant String :=
Substitute_Variables_In_Compiler_Description
(Get_Name_String (Node.Directory), Comp);
begin
if Search (Search'First) = '/' then
Put_Verbose
(Attribute & ": search directories matching "
& Search & ", starting from /", 1);
Parse_All_Dirs
(Processed_Value => Processed_Value,
Visited => Visited,
Current_Dir => "",
Path_To_Check => Search,
Contents => Node.Contents,
Regexp =>
Compile (Search (Search'First + 1
.. Search'Last)),
Regexp_Str => Search,
Value_If_Match => Node.Dir_If_Match,
Merge_Same_Dirs => Merge_Same_Dirs,
Group => Node.Directory_Group);
else
if Current_Verbosity /= Default then
Put_Verbose
(Attribute & ": search directories matching "
& Search & ", starting from "
& Get_Name_String (Comp.Path), 1);
end if;
Parse_All_Dirs
(Processed_Value => Processed_Value,
Visited => Visited,
Current_Dir => Get_Name_String (Comp.Path),
Path_To_Check => Search,
Contents => Node.Contents,
Regexp => Compile (Search),
Regexp_Str => Search,
Value_If_Match => Node.Dir_If_Match,
Merge_Same_Dirs => Merge_Same_Dirs,
Group => Node.Directory_Group);
end if;
Put_Verbose ("Done search directories", -1);
end;
when Value_Grep =>
declare
Matched : Match_Array (0 .. Node.Group);
Tmp_Str : constant String := To_String (Tmp_Result);
begin
Match (Node.Regexp_Re.all, Tmp_Str, Matched);
if Matched (0) /= No_Match then
Tmp_Result := To_Unbounded_String
(Tmp_Str (Matched (Node.Group).First ..
Matched (Node.Group).Last));
Put_Verbose (Attribute & ": grep matched="""
& To_String (Tmp_Result) & """");
else
Tmp_Result := Null_Unbounded_String;
Put_Verbose (Attribute & ": grep no match");
end if;
end;
when Value_Nogrep =>
declare
Matched : Match_Array (0 .. 0);
Tmp_Str : constant String := To_String (Tmp_Result);
begin
Match (Node.Regexp_No.all, Tmp_Str, Matched);
if Matched (0) /= No_Match then
Put_Verbose (Attribute & ": nogrep matched="""
& Tmp_Str & """");
raise Ignore_Compiler;
else
Put_Verbose (Attribute & ": nogrep no match");
end if;
end;
when Value_Must_Match =>
if not Match
(Expression => Get_Name_String (Node.Must_Match),
Data => To_String (Tmp_Result))
then
if Current_Verbosity /= Default then
Put_Verbose
("Ignore compiler since external value """
& To_String (Tmp_Result) & """ must match "
& Get_Name_String (Node.Must_Match));
end if;
Tmp_Result := Null_Unbounded_String;
raise Ignore_Compiler;
end if;
exit;
when Value_Done
| Value_Filter =>
exit;
end case;
Next (Node_Cursor);
end loop;
case Node.Typ is
when Value_Done | Value_Filter | Value_Must_Match =>
if Tmp_Result = Null_Unbounded_String then
-- Value could not be computed
if Extracted_From /= No_Name then
Append
(Processed_Value,
External_Value_Item'
(Value => No_Name,
Alternate => No_Name,
Extracted_From => Extracted_From));
end if;
elsif Split_Into_Words then
declare
Split : String_Lists.List;
C : String_Lists.Cursor;
Filter : Name_Id;
begin
if Node.Typ = Value_Filter then
Filter := Node.Filter;
else
Filter := No_Name;
end if;
-- When an external value is defined as a static string,
-- the only valid separator is ','. When computed
-- however, we also allow space as a separator
if From_Static then
Get_Words
(Words => To_String (Tmp_Result),
Filter => Filter,
Separator1 => ',',
Separator2 => ',',
Map => Split,
Allow_Empty_Elements => False);
else
Get_Words
(Words => To_String (Tmp_Result),
Filter => Filter,
Separator1 => ' ',
Separator2 => ',',
Map => Split,
Allow_Empty_Elements => False);
end if;
C := First (Split);
while Has_Element (C) loop
Append
(Processed_Value,
External_Value_Item'
(Value => Get_String
(String_Lists.Element (C)),
Alternate => No_Name,
Extracted_From => Extracted_From));
Next (C);
end loop;
end;
else
Append
(Processed_Value,
External_Value_Item'
(Value => Get_String (To_String (Tmp_Result)),
Alternate => No_Name,
Extracted_From => Extracted_From));
end if;
when others =>
null;
end case;
Extracted_From := No_Name;
Next (Node_Cursor);
end loop;
end Get_External_Value;
---------------
-- Get_Words --
---------------
procedure Get_Words
(Words : String;
Filter : Namet.Name_Id;
Separator1 : Character;
Separator2 : Character;
Map : out String_Lists.List;
Allow_Empty_Elements : Boolean)
is
First : Integer := Words'First;
Last : Integer;
Filter_Set : String_Lists.List;
begin
if Filter /= No_Name then
Get_Words (Get_Name_String (Filter), No_Name, Separator1,
Separator2, Filter_Set,
Allow_Empty_Elements => True);
end if;
if not Allow_Empty_Elements then
while First <= Words'Last
and then (Words (First) = Separator1
or else Words (First) = Separator2)
loop
First := First + 1;
end loop;
end if;
while First <= Words'Last loop
if Words (First) /= Separator1
and then Words (First) /= Separator2
then
Last := First + 1;
while Last <= Words'Last
and then Words (Last) /= Separator1
and then Words (Last) /= Separator2
loop
Last := Last + 1;
end loop;
else
Last := First;
end if;
if (Allow_Empty_Elements or else First <= Last - 1)
and then
(Is_Empty (Filter_Set)
or else Contains (Filter_Set, Words (First .. Last - 1)))
then
Append (Map, Words (First .. Last - 1));
end if;
First := Last + 1;
end loop;
end Get_Words;
------------------------------
-- Foreach_Language_Runtime --
------------------------------
procedure Foreach_Language_Runtime
(Iterator : in out Compiler_Iterator'Class;
Base : in out Knowledge_Base;
Name : Name_Id;
Executable : Name_Id;
Directory : String;
Prefix : Name_Id;
From_Extra_Dir : Boolean;
On_Target : Targets_Set_Id;
Descr : Compiler_Description;
Path_Order : Integer;
Continue : out Boolean)
is
Target : External_Value_Lists.List;
Version : External_Value_Lists.List;
Languages : External_Value_Lists.List;
Runtimes : External_Value_Lists.List;
Variables : External_Value_Lists.List;
Comp : Compiler;
C, C2 : External_Value_Lists.Cursor;
CS : String_Lists.Cursor;
begin
Continue := True;
-- verify that the compiler is indeed a real executable
-- on Windows and not a cygwin symbolic link
if On_Windows
and then not Is_Windows_Executable
(Directory & Directory_Separator & Get_Name_String (Executable))
then
Continue := True;
return;
end if;
Comp.Name := Name;
Comp.Path := Get_String
(Name_As_Directory
(Normalize_Pathname (Directory, Case_Sensitive => False)));
Comp.Base_Name := Get_String
(GNAT.Directory_Operations.Base_Name
(Get_Name_String (Executable), Suffix => Exec_Suffix.all));
Comp.Path_Order := Path_Order;
Comp.Prefix := Prefix;
Comp.Executable := Executable;
-- Check the target first, for efficiency. If it doesn't match, no need
-- to compute other attributes.
if Executable /= No_Name then
if not Is_Empty (Descr.Target) then
Get_External_Value
("target",
Value => Descr.Target,
Comp => Comp,
Split_Into_Words => False,
Processed_Value => Target);
if not Is_Empty (Target) then
Comp.Target :=
External_Value_Lists.Element (First (Target)).Value;
Get_Targets_Set
(Base, Get_Name_String (Comp.Target), Comp.Targets_Set);
else
Put_Verbose ("Target unknown for this compiler");
Comp.Targets_Set := Unknown_Targets_Set;
end if;
if On_Target /= All_Target_Sets
and then Comp.Targets_Set /= On_Target
then
Put_Verbose
("Target for this compiler does not match --target");
Continue := True;
return;
end if;
else
Put_Verbose ("Target unspecified, always match");
Comp.Targets_Set := All_Target_Sets;
end if;
-- Then get the value of the remaining attributes. For most of them,
-- we must be able to find a valid value, or the compiler is simply
-- ignored
Get_External_Value
("version",
Value => Descr.Version,
Comp => Comp,
Split_Into_Words => False,
Processed_Value => Version);
if Is_Empty (Version) then
Put_Verbose ("Ignore compiler, since couldn't guess its version");
Continue := True;
return;
end if;
Comp.Version := External_Value_Lists.Element (First (Version)).Value;
Get_External_Value
("variables",
Value => Descr.Variables,
Comp => Comp,
Split_Into_Words => False,
Processed_Value => Variables);
C := First (Variables);
while Has_Element (C) loop
declare
Ext : constant External_Value_Item :=
External_Value_Lists.Element (C);
begin
if Ext.Value = No_Name then
if Current_Verbosity /= Default then
Put_Verbose
("Ignore compiler since variable '"
& Get_Name_String (Ext.Extracted_From) & "' is empty");
end if;
Continue := True;
return;
end if;
if Variables_Maps.Contains
(Comp.Variables, Ext.Extracted_From)
then
Put_Line
(Standard_Error, "Variable '"
& Get_Name_String (Ext.Extracted_From)
& "' is already defined");
else
Variables_Maps.Insert
(Comp.Variables, Ext.Extracted_From, Ext.Value);
end if;
end;
Next (C);
end loop;
end if;
Get_External_Value
("languages",
Value => Descr.Languages,
Comp => Comp,
Split_Into_Words => True,
Processed_Value => Languages);
if Is_Empty (Languages) then
Put_Verbose ("Ignore compiler, since no language could be computed");
Continue := True;
return;
end if;
if Executable /= No_Name then
Get_External_Value
("runtimes",
Value => Descr.Runtimes,
Comp => Comp,
Split_Into_Words => True,
Merge_Same_Dirs => True,
Processed_Value => Runtimes);
if not Is_Empty (Runtimes) then
-- This loop makes sure that the default runtime appears first in
-- the list (and thus is selected automatically when using
-- --batch). This doesn't impact the interactive display, where
-- the runtimes will be sorted alphabetically anyway (see
-- Display_Before)
CS := First (Descr.Default_Runtimes);
Defaults_Loop :
while Has_Element (CS) loop
C2 := First (Runtimes);
while Has_Element (C2) loop
if Get_Name_String (External_Value_Lists.Element (C2).Value)
= String_Lists.Element (CS)
then
Prepend (Runtimes, External_Value_Lists.Element (C2));
Delete (Runtimes, C2);
exit Defaults_Loop;
end if;
Next (C2);
end loop;
Next (CS);
end loop Defaults_Loop;
end if;
end if;
C := First (Languages);
while Has_Element (C) loop
declare
L : constant Name_Id := External_Value_Lists.Element (C).Value;
begin
Comp.Language_Case := L;
Comp.Language_LC := Get_String (To_Lower (Get_Name_String (L)));
if Is_Empty (Runtimes) then
if Descr.Runtimes /= Null_External_Value then
Put_Verbose ("No runtime found where one is required for: "
& Get_Name_String (Comp.Path));
else
Callback
(Iterator => Iterator,
Base => Base,
Comp => Comp,
From_Extra_Dir => From_Extra_Dir,
Continue => Continue);
if not Continue then
return;
end if;
end if;
else
C2 := First (Runtimes);
while Has_Element (C2) loop
Comp.Runtime := External_Value_Lists.Element (C2).Value;
Comp.Alt_Runtime :=
External_Value_Lists.Element (C2).Alternate;
Comp.Runtime_Dir :=
External_Value_Lists.Element (C2).Extracted_From;
Callback
(Iterator => Iterator,
Base => Base,
Comp => Comp,
From_Extra_Dir => From_Extra_Dir,
Continue => Continue);
if not Continue then
return;
end if;
Next (C2);
end loop;
end if;
end;
Next (C);
end loop;
exception
when Ignore_Compiler =>
null;
end Foreach_Language_Runtime;
---------------
-- To_String --
---------------
function To_String
(Base : Knowledge_Base;
Comp : Compiler;
As_Config_Arg : Boolean;
Show_Target : Boolean := False;
Rank_In_List : Integer := -1;
Parser_Friendly : Boolean := False) return String
is
function Runtime_Or_Alternate return String;
function Runtime_Or_Empty return String;
function Rank return String;
function Target return String;
-- Return various aspects of the compiler;
--------------------------
-- Runtime_Or_Alternate --
--------------------------
function Runtime_Or_Alternate return String is
begin
if Comp.Alt_Runtime /= No_Name then
return Get_Name_String (Comp.Alt_Runtime);
elsif Comp.Runtime /= No_Name then
return Get_Name_String (Comp.Runtime);
else
return "";
end if;
end Runtime_Or_Alternate;
----------------------
-- Runtime_Or_Empty --
----------------------
function Runtime_Or_Empty return String is
begin
if Comp.Runtime /= No_Name then
if Comp.Alt_Runtime = No_Name then
return " (" & Get_Name_String (Comp.Runtime) & " runtime)";
else
return
" (" & Get_Name_String (Comp.Runtime) &
" [" & Get_Name_String (Comp.Alt_Runtime) &
"] runtime)";
end if;
else
return "";
end if;
end Runtime_Or_Empty;
----------
-- Rank --
----------
function Rank return String is
Result : String (1 .. 4) := " ";
Img : constant String := Rank_In_List'Img;
begin
if Rank_In_List > 0 then
Result (4 - Img'Length + 1 .. 4) := Img;
end if;
if Comp.Selected then
Result (1) := '*';
end if;
return Result;
end Rank;
------------
-- Target --
------------
function Target return String is
begin
if Show_Target then
return " on " & Get_Name_String (Comp.Target);
else
return "";
end if;
end Target;
begin
if As_Config_Arg then
return Get_Name_String_Or_Null (Comp.Language_Case)
& ',' & Get_Name_String_Or_Null (Comp.Version)
& ',' & Get_Name_String_Or_Null (Comp.Runtime)
& ',' & Get_Name_String_Or_Null (Comp.Path)
& ',' & Get_Name_String_Or_Null (Comp.Name);
elsif Parser_Friendly then
return Rank & " target:"
& Get_Name_String_Or_Null (Comp.Target) & ASCII.LF
& Rank & " normalized_target:"
& Normalized_Target (Base, Comp.Targets_Set) & ASCII.LF
& Rank & " executable:"
& Get_Name_String_Or_Null (Comp.Executable) & ASCII.LF
& Rank & " path:"
& Get_Name_String_Or_Null (Comp.Path) & ASCII.LF
& Rank & " lang:"
& Get_Name_String_Or_Null (Comp.Language_Case) & ASCII.LF
& Rank & " name:"
& Get_Name_String_Or_Null (Comp.Name) & ASCII.LF
& Rank & " version:"
& Get_Name_String_Or_Null (Comp.Version) & ASCII.LF
& Rank & " runtime:"
& Runtime_Or_Alternate & ASCII.LF
& Rank & " native:"
& Boolean'Image
(Query_Targets_Set (Base, Hostname) = Comp.Targets_Set);
elsif Comp.Executable = No_Name then
-- A language that requires no compiler
return Rank
& ". "
& Get_Name_String_Or_Null (Comp.Language_Case)
& " (no compiler required)";
else
return Rank
& ". "
& Get_Name_String_Or_Null (Comp.Name) & " for "
& Get_Name_String_Or_Null (Comp.Language_Case)
& " in " & Get_Name_String_Or_Null (Comp.Path)
& Target
& " version " & Get_Name_String_Or_Null (Comp.Version)
& Runtime_Or_Empty;
end if;
end To_String;
---------------
-- To_String --
---------------
function To_String
(Base : Knowledge_Base;
Compilers : Compiler_Lists.List;
Selected_Only : Boolean;
Show_Target : Boolean := False;
Parser_Friendly : Boolean := False) return String
is
Comp : Compiler_Lists.Cursor := First (Compilers);
Result : Unbounded_String;
Rank : Natural := 1;
begin
while Has_Element (Comp) loop
if Compiler_Lists.Element (Comp).Selected
or else (not Selected_Only
and then Compiler_Lists.Element (Comp).Selectable)
then
Append
(Result,
To_String
(Base,
Compiler_Lists.Element (Comp).all, False,
Show_Target => Show_Target,
Rank_In_List => Rank,
Parser_Friendly => Parser_Friendly));
Append (Result, ASCII.LF);
end if;
Rank := Rank + 1;
Next (Comp);
end loop;
return To_String (Result);
end To_String;
-----------------------------
-- Foreach_Compiler_In_Dir --
-----------------------------
procedure Foreach_Compiler_In_Dir
(Iterator : in out Compiler_Iterator'Class;
Base : in out Knowledge_Base;
Directory : String;
From_Extra_Dir : Boolean;
On_Target : Targets_Set_Id;
Path_Order : Integer;
Continue : out Boolean)
is
use CDM;
function Executable_Pattern return String;
pragma Inline (Executable_Pattern);
-- Returns a pattern which matchs executable
------------------------
-- Executable_Pattern --
------------------------
function Executable_Pattern return String is
begin
if On_Windows then
return "*.{exe,bat,cmd}";
else
return "";
end if;
end Executable_Pattern;
C : CDM.Cursor;
Search : Search_Type;
Dir : Directory_Entry_Type;
begin
-- Since the name of an executable can be a regular expression, we need
-- to look at all files in the directory to see if they match. This
-- requires more system calls than if the name was always a simple
-- string. So we first check which of the two algorithms should be used.
Continue := True;
if Current_Verbosity /= Default then
Put_Verbose ("Foreach compiler in "
& Directory & " regexp="
& Boolean'Image (Base.Check_Executable_Regexp)
& " extra_dir=" & From_Extra_Dir'Img,
1);
end if;
if Base.Check_Executable_Regexp then
begin
Start_Search
(Search => Search,
Directory => Directory,
Pattern => Executable_Pattern);
exception
when Ada.Directories.Name_Error =>
Put_Verbose ("No such directory:" & Directory, -1);
Continue := True;
return;
when Ada.Directories.Use_Error =>
Put_Verbose ("Directory not readable:" & Directory, -1);
Continue := True;
return;
end;
For_All_Files_In_Dir : loop
begin
exit For_All_Files_In_Dir when not More_Entries (Search);
Get_Next_Entry (Search, Dir);
C := First (Base.Compilers);
while Has_Element (C) loop
declare
Config : constant Compiler_Description :=
CDM.Element (C);
Simple : constant String := Simple_Name (Dir);
Matches : Match_Array
(0 .. Integer'Max (0, Config.Prefix_Index));
Matched : Boolean;
Prefix : Name_Id := No_Name;
begin
-- A language with no expected compiler => always match
if Config.Executable = No_Name then
Put_Verbose
(Get_Name_String (Key (C))
& " requires no compiler",
1);
Continue := True;
Foreach_Language_Runtime
(Iterator => Iterator,
Base => Base,
Name => Key (C),
Executable => No_Name,
Directory => "",
On_Target => Unknown_Targets_Set,
Prefix => No_Name,
From_Extra_Dir => From_Extra_Dir,
Descr => Config,
Path_Order => Path_Order,
Continue => Continue);
Put_Verbose ("", -1);
exit For_All_Files_In_Dir when not Continue;
Matched := False;
elsif Config.Executable_Re /= null then
Match
(Config.Executable_Re.all,
Data => Simple,
Matches => Matches);
Matched := Matches (0) /= No_Match;
else
Matched := (Get_Name_String (Config.Executable)
& Exec_Suffix.all) = Simple_Name (Dir);
end if;
if Matched then
Put_Verbose
(Get_Name_String (Key (C))
& " is candidate: filename=" & Simple,
1);
if Config.Executable_Re /= null
and then Config.Prefix_Index >= 0
and then Matches (Config.Prefix_Index) /=
No_Match
then
Prefix := Get_String
(Simple (Matches
(Config.Prefix_Index).First ..
Matches (Config.Prefix_Index).Last));
end if;
Continue := True;
Foreach_Language_Runtime
(Iterator => Iterator,
Base => Base,
Name => Key (C),
Executable => Get_String (Simple),
Directory => Directory,
On_Target => On_Target,
Prefix => Prefix,
From_Extra_Dir => From_Extra_Dir,
Descr => Config,
Path_Order => Path_Order,
Continue => Continue);
Put_Verbose ("", -1);
exit For_All_Files_In_Dir when not Continue;
end if;
end;
Next (C);
end loop;
exception
when Ada.Directories.Name_Error | Ada.Directories.Use_Error =>
null;
end;
end loop For_All_Files_In_Dir;
else
-- Do not search all entries in the directory, but check explictly
-- for the compilers. This results in a lot less system calls, and
-- thus is faster.
C := First (Base.Compilers);
while Has_Element (C) loop
declare
Config : constant Compiler_Description :=
CDM.Element (C);
F : constant String :=
Normalize_Pathname
(Name =>
Get_Name_String (Config.Executable),
Directory => Directory,
Resolve_Links => False,
Case_Sensitive =>
Case_Sensitive_Files) & Exec_Suffix.all;
begin
if Ada.Directories.Exists (F) then
Put_Verbose ("--------------------------------------");
Put_Verbose
("Processing "
& Get_Name_String (Config.Name) & " in " & Directory);
Foreach_Language_Runtime
(Iterator => Iterator,
Base => Base,
Name => Key (C),
Executable => Config.Executable,
Prefix => No_Name,
From_Extra_Dir => From_Extra_Dir,
On_Target => On_Target,
Directory => Directory,
Descr => Config,
Path_Order => Path_Order,
Continue => Continue);
exit when not Continue;
end if;
exception
when Ada.Directories.Name_Error | Ada.Directories.Use_Error =>
null;
when Ignore_Compiler =>
-- Nothing to do, the compiler has not been inserted
null;
end;
Next (C);
end loop;
end if;
Put_Verbose ("", -1);
end Foreach_Compiler_In_Dir;
------------------------------
-- Foreach_Compiler_In_Path --
------------------------------
procedure Foreach_Compiler_In_Path
(Iterator : in out Compiler_Iterator;
Base : in out Knowledge_Base;
On_Target : Targets_Set_Id;
Extra_Dirs : String := "")
is
Dirs : String_Lists.List;
Map : String_Lists.List;
procedure Process_Path
(Path : String; Prefix : Character; Prepend_To_List : Boolean);
-- Add a directory to the list of directories to examine
------------------
-- Process_Path --
------------------
procedure Process_Path
(Path : String; Prefix : Character; Prepend_To_List : Boolean)
is
First, Last : Natural;
begin
First := Path'First;
while First <= Path'Last loop
-- Skip null entries on PATH
if Path (First) = GNAT.OS_Lib.Path_Separator then
First := First + 1;
else
Last := First + 1;
while Last <= Path'Last
and then Path (Last) /= GNAT.OS_Lib.Path_Separator
loop
Last := Last + 1;
end loop;
declare
-- Use a hash to make sure we do not parse the same
-- directory twice. This is both more efficient and avoids
-- duplicates in the final result list. To handle the case
-- of links (on linux for instance /usr/bin/X11 points to
-- ".", ie /usr/bin, and compilers would appear duplicated),
-- we resolve symbolic links. This call is also set to fold
-- to lower-case when appropriate
Normalized : constant String :=
Name_As_Directory
(Normalize_Pathname
(Path (First .. Last - 1),
Resolve_Links => True,
Case_Sensitive => False));
begin
if not Contains (Map, Normalized) then
Append (Map, Normalized);
-- Rerun normalize_pathname without resolve_links so that
-- the displayed path looks familiar to the user (no ..,
-- ./ or quotes, but still using the path as shown in
-- $PATH)
declare
Final_Path : constant String :=
Normalize_Pathname
(Path (First .. Last - 1),
Resolve_Links => False,
Case_Sensitive => False);
begin
-- Windows is somewhat slow at parsing directories, do
-- not look into any directory under C:\windows as
-- there is no compiler to be found there anyway.
if not On_Windows
or else
(Final_Path'Length > 10
and then
To_Lower (Final_Path
(Final_Path'First .. Final_Path'First + 9)) /=
"c:\windows")
then
Put_Verbose ("Will examine "
& Prefix & " " & Final_Path);
if Prepend_To_List then
Prepend (Dirs, Prefix & Final_Path);
else
Append (Dirs, Prefix & Final_Path);
end if;
end if;
end;
end if;
end;
First := Last + 1;
end if;
end loop;
end Process_Path;
Dir : String_Lists.Cursor;
Path_Order : Positive := 1;
Continue : Boolean;
begin
-- Preprocess the list of directories that will be searched. When a
-- directory appears both in Extra_Dirs and in Path, we prepend it to
-- the PATH for optimization purposes: no need to look in all the PATH
-- if the compiler(s) will match in that directory. However, this has
-- the result that a command line with --config that specifies a path
-- and one that doesn't might find the second compiler in the same
-- path even if it is not the first one on the PATH. That's minor, and
-- a workaround is for the user to specify path for all --config args.
--
-- We will also need to know later whether the directory comes from
-- PATH or extra_dirs. If a directory appears in both, it is said to
-- come from PATH, so that all its compilers are taken into account.
-- As a special convention, the first character of the directory name is
-- set to 'E' if the dir comes from extra_dirs, or 'P' if it comes from
-- PATH.
if Ada.Environment_Variables.Exists ("PATH") then
Process_Path (Ada.Environment_Variables.Value ("PATH"), 'P', False);
end if;
if Extra_Dirs /= "" then
Process_Path (Extra_Dirs, 'E', Prepend_To_List => True);
end if;
Dir := First (Dirs);
while Has_Element (Dir) loop
declare
P : constant String := String_Lists.Element (Dir);
begin
Foreach_Compiler_In_Dir
(Iterator => Iterator,
Base => Base,
Directory => P (P'First + 1 .. P'Last),
From_Extra_Dir => P (P'First) = 'E',
Path_Order => Path_Order,
On_Target => On_Target,
Continue => Continue);
exit when not Continue;
end;
Path_Order := Path_Order + 1;
Next (Dir);
end loop;
end Foreach_Compiler_In_Path;
--------------------------
-- Known_Compiler_Names --
--------------------------
procedure Known_Compiler_Names
(Base : Knowledge_Base;
List : out Ada.Strings.Unbounded.Unbounded_String)
is
use CDM;
C : CDM.Cursor := First (Base.Compilers);
begin
List := Null_Unbounded_String;
while Has_Element (C) loop
if List /= Null_Unbounded_String then
Append (List, ",");
end if;
Append (List, Get_Name_String (Key (C)));
Next (C);
end loop;
end Known_Compiler_Names;
-----------
-- Match --
-----------
procedure Match
(Filter : Compilers_Filter;
Compilers : Compiler_Lists.List;
Matching_Compiler : out Compiler_Access;
Matched : out Boolean)
is
C : CFL.Cursor := First (Filter.Compiler);
M : Boolean;
begin
while Has_Element (C) loop
Match (CFL.Element (C), Compilers, Matching_Compiler, M);
if M then
Matched := not Filter.Negate;
return;
end if;
Next (C);
end loop;
Matched := Filter.Negate;
end Match;
------------------
-- Filter_Match --
------------------
function Filter_Match
(Base : Knowledge_Base;
Comp : Compiler;
Filter : Compiler) return Boolean is
begin
if Filter.Name /= No_Name
and then Comp.Name /= Filter.Name
and then Comp.Base_Name /= Filter.Name
then
if Current_Verbosity /= Default then
Put_Verbose ("Filter=" & To_String (Base, Filter, True)
& ": name does not match");
end if;
return False;
end if;
if Filter.Path /= No_Name and then Filter.Path /= Comp.Path then
if Current_Verbosity /= Default then
Put_Verbose ("Filter=" & To_String (Base, Filter, True)
& ": path does not match");
end if;
return False;
end if;
if Filter.Version /= No_Name and then Filter.Version /= Comp.Version then
if Current_Verbosity /= Default then
Put_Verbose ("Filter=" & To_String (Base, Filter, True)
& ": version does not match");
end if;
return False;
end if;
if Filter.Runtime /= No_Name and then
not Is_Absolute_Path (Get_Name_String (Filter.Runtime)) and then
Filter.Runtime /= Comp.Runtime and then
Filter.Runtime /= Comp.Alt_Runtime
then
if Current_Verbosity /= Default then
Put_Verbose ("Filter=" & To_String (Base, Filter, True)
& ": runtime does not match");
end if;
return False;
end if;
if Filter.Language_LC /= No_Name
and then Filter.Language_LC /= Comp.Language_LC
then
if Current_Verbosity /= Default then
Put_Verbose ("Filter=" & To_String (Base, Filter, True)
& ": language does not match");
end if;
return False;
end if;
return True;
end Filter_Match;
-----------
-- Match --
-----------
procedure Match
(Filter : Compiler_Filter;
Compilers : Compiler_Lists.List;
Matching_Compiler : out Compiler_Access;
Matched : out Boolean)
is
C : Compiler_Lists.Cursor := First (Compilers);
Comp : Compiler_Access;
begin
while Has_Element (C) loop
Comp := Compiler_Lists.Element (C);
if Comp.Selected
and then (Filter.Name = No_Name
or else Filter.Name = Comp.Name
or else Comp.Base_Name = Filter.Name)
and then
(Filter.Version_Re = null
or else
(Comp.Version /= No_Name
and then Match
(Filter.Version_Re.all, Get_Name_String (Comp.Version))))
and then (Filter.Runtime_Re = null
or else
(Comp.Runtime /= No_Name
and then Match
(Filter.Runtime_Re.all,
Get_Name_String (Comp.Runtime))))
and then (Filter.Language_LC = No_Name
or else Filter.Language_LC = Comp.Language_LC)
then
Matching_Compiler := Comp;
Matched := True;
return;
end if;
Next (C);
end loop;
Matched := False;
end Match;
-----------
-- Match --
-----------
procedure Match
(Filter : Compilers_Filter_Lists.List;
Compilers : Compiler_Lists.List;
Matching_Compiler : out Compiler_Access;
Matched : out Boolean)
is
C : Compilers_Filter_Lists.Cursor := First (Filter);
M : Boolean;
begin
while Has_Element (C) loop
Match (Compilers_Filter_Lists.Element (C),
Compilers, Matching_Compiler, M);
if not M then
Matched := False;
return;
end if;
Next (C);
end loop;
if Length (Filter) /= 1 then
Matching_Compiler := null;
end if;
Matched := True;
end Match;
-----------
-- Match --
-----------
function Match
(Target_Filter : String_Lists.List;
Negate : Boolean;
Compilers : Compiler_Lists.List) return Boolean
is
Target : String_Lists.Cursor := First (Target_Filter);
Comp : Compiler_Lists.Cursor;
begin
if Is_Empty (Target_Filter) then
return True;
else
while Has_Element (Target) loop
declare
Pattern : constant Pattern_Matcher :=
Compile
(String_Lists.Element (Target), Case_Insensitive);
begin
Comp := First (Compilers);
while Has_Element (Comp) loop
if Compiler_Lists.Element (Comp).Selected then
if Compiler_Lists.Element (Comp).Target = No_Name then
if Match (Pattern, "") then
return not Negate;
end if;
elsif Match
(Pattern,
Get_Name_String (Compiler_Lists.Element (Comp).Target))
then
return not Negate;
end if;
end if;
Next (Comp);
end loop;
end;
Next (Target);
end loop;
return Negate;
end if;
end Match;
-----------------
-- Skip_Spaces --
-----------------
procedure Skip_Spaces (Str : String; Index : in out Integer) is
begin
while Index <= Str'Last
and then (Str (Index) = ' ' or else Str (Index) = ASCII.LF)
loop
Index := Index + 1;
end loop;
end Skip_Spaces;
procedure Skip_Spaces_Backward (Str : String; Index : in out Integer) is
begin
while Index >= Str'First
and then (Str (Index) = ' ' or else Str (Index) = ASCII.LF)
loop
Index := Index - 1;
end loop;
end Skip_Spaces_Backward;
------------------
-- Merge_Config --
------------------
procedure Merge_Config
(Base : Knowledge_Base;
Packages : in out String_Maps.Map;
Compilers : Compiler_Lists.List;
Config : String)
is
procedure Add_Package
(Name : String; Chunk : String; Prefix : String := " ");
-- Add the chunk in the appropriate package
-----------------
-- Add_Package --
-----------------
procedure Add_Package
(Name : String; Chunk : String; Prefix : String := " ")
is
C : constant String_Maps.Cursor := Find (Packages, Name);
Replaced : constant String :=
Substitute_Variables_In_Configuration
(Base, Chunk, Compilers);
begin
if Replaced /= "" then
if Has_Element (C) then
Replace_Element
(Packages,
C,
String_Maps.Element (C) & ASCII.LF & Prefix & Replaced);
else
Insert
(Packages,
Name, Prefix & To_Unbounded_String (Replaced));
end if;
end if;
end Add_Package;
First : Integer := Config'First;
Pkg_Name_First, Pkg_Name_Last : Integer;
Pkg_Content_First : Integer;
Last : Integer;
begin
while First /= 0 and then First <= Config'Last loop
-- Do we have a toplevel attribute ?
Skip_Spaces (Config, First);
Pkg_Name_First := Index (Config (First .. Config'Last), "package ");
if Pkg_Name_First = 0 then
Pkg_Name_First := Config'Last + 1;
end if;
Last := Pkg_Name_First - 1;
Skip_Spaces_Backward (Config, Last);
Add_Package
(Name => "",
Chunk => Config (First .. Last),
Prefix => " ");
exit when Pkg_Name_First > Config'Last;
-- Parse the current package
Pkg_Name_First := Pkg_Name_First + 8; -- skip "package "
Skip_Spaces (Config, Pkg_Name_First);
Pkg_Name_Last := Pkg_Name_First + 1;
while Pkg_Name_Last <= Config'Last
and then Config (Pkg_Name_Last) /= ' '
and then Config (Pkg_Name_Last) /= ASCII.LF
loop
Pkg_Name_Last := Pkg_Name_Last + 1;
end loop;
Pkg_Content_First := Pkg_Name_Last + 1;
Skip_Spaces (Config, Pkg_Content_First);
Pkg_Content_First := Pkg_Content_First + 2; -- skip "is"
Skip_Spaces (Config, Pkg_Content_First);
Last := Index (Config (Pkg_Content_First .. Config'Last),
"end " & Config (Pkg_Name_First .. Pkg_Name_Last - 1));
if Last /= 0 then
First := Last - 1;
Skip_Spaces_Backward (Config, First);
Add_Package
(Name => Config (Pkg_Name_First .. Pkg_Name_Last - 1),
Chunk => Config (Pkg_Content_First .. First));
while Last <= Config'Last and then Config (Last) /= ';' loop
Last := Last + 1;
end loop;
Last := Last + 1;
end if;
First := Last;
end loop;
end Merge_Config;
-----------------
-- Put_Verbose --
-----------------
procedure Put_Verbose (Config : Configuration) is
C : Compilers_Filter_Lists.Cursor :=
First (Config.Compilers_Filters);
Comp_Filter : Compilers_Filter;
Comp : Compiler_Filter_Lists.Cursor;
Filter : Compiler_Filter;
begin
while Has_Element (C) loop
Comp_Filter := Compilers_Filter_Lists.Element (C);
Put_Verbose
("", 1);
Comp := First (Comp_Filter.Compiler);
while Has_Element (Comp) loop
Filter := Compiler_Filter_Lists.Element (Comp);
Put_Verbose
(" ", -1);
Next (C);
end loop;
Put_Verbose (",
-- this only impacts the batch mode. We still want to sort
-- the runtimes alphabetically in the interactive display.
case Compare (Comp1.Runtime, Comp2.Runtime) is
when Before =>
return True;
when After =>
return False;
when Equal =>
return Compare (Comp1.Version, Comp2.Version) = Before;
end case;
end if;
end case;
end Display_Before;
----------------------------
-- Parse_Config_Parameter --
----------------------------
procedure Parse_Config_Parameter
(Base : Knowledge_Base;
Config : String;
Compiler : out Compiler_Access;
Requires_Compiler : out Boolean)
is
Map : String_Lists.List;
C : String_Lists.Cursor;
begin
-- Only valid separator is ',', not spaces
Get_Words
(Config, Filter => No_Name,
Map => Map,
Separator1 => ',',
Separator2 => ',',
Allow_Empty_Elements => True);
Compiler := new GprConfig.Knowledge.Compiler;
C := First (Map);
declare
LC : constant String := To_Lower (String_Lists.Element (C));
begin
Compiler.Language_Case :=
Get_String_Or_No_Name (String_Lists.Element (C));
Compiler.Language_LC := Get_String_Or_No_Name (LC);
if Is_Language_With_No_Compiler (Base, LC) then
Put_Verbose ("Language " & LC & " requires no compiler");
Compiler.Complete := True;
Compiler.Selected := True;
Compiler.Targets_Set := All_Target_Sets;
Requires_Compiler := False;
else
Requires_Compiler := True;
Next (C);
if Has_Element (C) then
Compiler.Version :=
Get_String_Or_No_Name (String_Lists.Element (C));
Next (C);
if Has_Element (C) then
declare
Rts : constant String := String_Lists.Element (C);
begin
-- If the runtime is a full path, set Runtime and
-- Runtime_Dir to the same value.
if Rts'Length > 0 and then Is_Absolute_Path (Rts) then
Compiler.Runtime := Get_String_No_Adalib (Rts);
Compiler.Runtime_Dir := Compiler.Runtime;
else
Compiler.Runtime := Get_String_Or_No_Name (Rts);
end if;
end;
Next (C);
if Has_Element (C) then
Compiler.Path := Get_String_Or_No_Name
(Name_As_Directory
(Normalize_Pathname (String_Lists.Element (C),
Case_Sensitive => False)));
Next (C);
if Has_Element (C) then
-- the name could be either a name as defined in the
-- knowledge base, or the base name of the executable
-- we are looking for. It must not include the exec
-- suffix.
Compiler.Name := Get_String_Or_No_Name
(GNAT.Directory_Operations.Base_Name
(String_Lists.Element (C),
Suffix => Exec_Suffix.all));
end if;
end if;
end if;
end if;
Compiler.Complete := False;
-- Complete_Command_Line_Compilers will check that this is a valid
-- config
Put_Verbose ("Language " & LC & " requires a compiler");
end if;
end;
exception
when E : others =>
Put_Verbose ("Exception raised: " & Exception_Information (E));
raise Invalid_Config;
end Parse_Config_Parameter;
---------------------------
-- Filter_Compilers_List --
---------------------------
procedure Filter_Compilers_List
(Base : Knowledge_Base;
Compilers : in out Compiler_Lists.List;
For_Target_Set : Targets_Set_Id)
is
procedure Mark_As_Selectable (Comp : in out Compiler_Access);
procedure Mark_As_Unselectable (Comp : in out Compiler_Access);
------------------------
-- Mark_As_Selectable --
------------------------
procedure Mark_As_Selectable (Comp : in out Compiler_Access) is
begin
Comp.Selectable := True;
end Mark_As_Selectable;
--------------------------
-- Mark_As_Unselectable --
--------------------------
procedure Mark_As_Unselectable (Comp : in out Compiler_Access) is
begin
Comp.Selectable := False;
end Mark_As_Unselectable;
Comp, Comp2 : Compiler_Lists.Cursor;
Selectable : Boolean;
begin
Put_Verbose ("Filtering the list of compilers", 1);
Comp := First (Compilers);
while Has_Element (Comp) loop
if not Compiler_Lists.Element (Comp).Selected then
Selectable := True;
if For_Target_Set /= All_Target_Sets
and then Compiler_Lists.Element (Comp).Targets_Set /=
All_Target_Sets
and then Compiler_Lists.Element (Comp).Targets_Set /=
For_Target_Set
then
Selectable := False;
if Current_Verbosity /= Default then
Put_Verbose
("Incompatible target for: "
& To_String
(Base, Compiler_Lists.Element (Comp).all, False));
end if;
end if;
if Selectable then
Comp2 := First (Compilers);
while Has_Element (Comp2) loop
if Compiler_Lists.Element (Comp2).Selected
and then Compiler_Lists.Element (Comp2).Language_LC =
Compiler_Lists.Element (Comp).Language_LC
then
Selectable := False;
if Current_Verbosity /= Default then
Put_Verbose
("Already selected language for "
& To_String
(Base, Compiler_Lists.Element (Comp).all, False));
end if;
exit;
end if;
Next (Comp2);
end loop;
end if;
if Selectable then
-- Would adding this compiler to the current selection end
-- up with an unsupported config ?
Set_Selection (Compilers, Comp, True);
if not Is_Supported_Config (Base, Compilers) then
Selectable := False;
if Current_Verbosity /= Default then
Put_Verbose
("Unsupported config for: "
& To_String
(Base, Compiler_Lists.Element (Comp).all, False));
end if;
end if;
Set_Selection (Compilers, Comp, False);
end if;
if Selectable then
Update_Element (Compilers, Comp, Mark_As_Selectable'Access);
else
Update_Element (Compilers, Comp, Mark_As_Unselectable'Access);
end if;
end if;
Next (Comp);
end loop;
Put_Verbose ("", -1);
end Filter_Compilers_List;
-----------------
-- Is_Selected --
-----------------
function Is_Selected (Comp : Compiler) return Boolean is
begin
return Comp.Selected;
end Is_Selected;
------------
-- Target --
------------
function Target (Comp : Compiler) return Namet.Name_Id is
begin
return Comp.Target;
end Target;
--------------------
-- Runtime_Dir_Of --
--------------------
function Runtime_Dir_Of (Comp : Compiler_Access) return Namet.Name_Id is
begin
if Comp = null then
return Namet.No_Name;
else
return Comp.Runtime_Dir;
end if;
end Runtime_Dir_Of;
end GprConfig.Knowledge;
gprbuild-gpl-2014-src/src/gprclean-main.adb 0000644 0000767 0000145 00000072020 12323721731 020110 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R C L E A N . M A I N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2011-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- This package contains the implementation of gprclean.
-- See gprclean.adb
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Exceptions; use Ada.Exceptions;
with System.Case_Util; use System.Case_Util;
with GNAT.Command_Line; use GNAT.Command_Line;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.IO; use GNAT.IO;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Gprbuild.Compilation.Slave; use Gprbuild.Compilation.Slave;
with Csets;
with Gpr_Util; use Gpr_Util;
with GPR_Version; use GPR_Version;
with Hostparm;
with Makeutl; use Makeutl;
with Namet; use Namet;
with Opt; use Opt;
with Osint;
with Prj; use Prj;
with Prj.Conf; use Prj.Conf;
with Prj.Env;
with Prj.Err;
with Prj.Ext;
with Prj.Tree; use Prj.Tree;
with Snames;
with Stringt;
with Switch; use Switch;
procedure Gprclean.Main is
use Knowledge;
procedure Usage;
-- Display the usage.
-- If called several times, the usage is displayed only the first time.
procedure Parse_Cmd_Line;
-- Parse the command line
procedure Display_Copyright;
-- Display the Copyright notice. If called several times, display the
-- Copyright notice only the first time.
procedure Initialize;
-- Call the necessary package initializations
procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
-----------------------
-- Display_Copyright --
-----------------------
procedure Display_Copyright is
begin
if not Copyright_Displayed then
Copyright_Displayed := True;
Display_Version
("GPRCLEAN", "2006", Version_String => Gpr_Version_String);
end if;
end Display_Copyright;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
if not Initialized then
Initialized := True;
-- Initialize some packages
Csets.Initialize;
Namet.Initialize;
Snames.Initialize;
Stringt.Initialize;
Prj.Tree.Initialize (Root_Environment, Gprclean_Flags);
Prj.Tree.Initialize (Project_Node_Tree);
end if;
-- Reset global variables
Do_Nothing := False;
File_Deleted := False;
Copyright_Displayed := False;
Usage_Displayed := False;
Free (Project_File_Name);
Main_Project := Prj.No_Project;
All_Projects := False;
Mains.Delete;
end Initialize;
--------------------
-- Parse_Cmd_Line --
--------------------
procedure Parse_Cmd_Line is
Last : constant Natural := Argument_Count;
Index : Positive := 1;
begin
-- First deal with --version and --help
Check_Version_And_Help
("GPRCLEAN",
"2006",
Version_String => Gpr_Version_String);
-- Now deal with the other options
while Index <= Last loop
declare
Arg : constant String := Argument (Index);
procedure Bad_Argument;
-- Signal bad argument
------------------
-- Bad_Argument --
------------------
procedure Bad_Argument is
begin
Osint.Fail ("invalid argument """ & Arg & '"');
end Bad_Argument;
begin
if Db_Directory_Expected then
Db_Directory_Expected := False;
Parse_Knowledge_Base (Project_Tree, Arg);
Name_Len := 0;
Add_Str_To_Name_Buffer (Arg);
Db_Switch_Args.Append (Name_Find);
elsif Arg'Length /= 0 then
if Arg (1) = '-' then
if Arg'Length = 1 then
Bad_Argument;
end if;
case Arg (2) is
when '-' =>
if not Hostparm.OpenVMS and then Arg = "--db-" then
Load_Standard_Base := False;
elsif not Hostparm.OpenVMS and then Arg = "--db" then
Db_Directory_Expected := True;
elsif Arg'Length > Config_Project_Option'Length
and then Arg (1 .. Config_Project_Option'Length) =
Config_Project_Option
then
if Config_Project_File_Name /= null
and then
(Autoconf_Specified
or else Config_Project_File_Name.all /=
Arg (Config_Project_Option'Length + 1
.. Arg'Last))
then
Fail_Program
(Project_Tree,
"several configuration switches cannot "
& "be specified");
else
Autoconfiguration := False;
Config_Project_File_Name :=
new String'
(Arg (Config_Project_Option'Length + 1
.. Arg'Last));
end if;
elsif Arg (1 .. Distributed_Option'Length)
= Distributed_Option
then
Distributed_Mode := True;
Gprbuild.Compilation.Slave.Record_Slaves
(Arg (Distributed_Option'Length + 1 .. Arg'Last));
elsif Arg'Length >= Slave_Env_Option'Length
and then
Arg (1 .. Slave_Env_Option'Length)
= Slave_Env_Option
then
if Arg = Slave_Env_Option then
-- Just --slave-env, it is up to gprbuild to
-- build a sensible slave environment value.
Slave_Env_Auto := True;
else
Slave_Env := new String'
(Arg
(Slave_Env_Option'Length + 2 .. Arg'Last));
end if;
elsif not Hostparm.OpenVMS
and then
Arg'Length > Autoconf_Project_Option'Length
and then
Arg (1 .. Autoconf_Project_Option'Length) =
Autoconf_Project_Option
then
if Config_Project_File_Name /= null
and then
(not Autoconf_Specified
or else
Config_Project_File_Name.all /=
Arg (Autoconf_Project_Option'Length + 1
.. Arg'Last))
then
Fail_Program
(Project_Tree,
"several configuration switches cannot "
& "be specified");
else
Config_Project_File_Name :=
new String'
(Arg (Autoconf_Project_Option'Length + 1
.. Arg'Last));
Autoconf_Specified := True;
end if;
elsif not Hostparm.OpenVMS
and then
Arg'Length > Target_Project_Option'Length
and then
Arg (1 .. Target_Project_Option'Length) =
Target_Project_Option
then
if Target_Name /= null then
if Target_Name.all /=
Arg (Target_Project_Option'Length + 1
.. Arg'Last)
then
Fail_Program
(Project_Tree,
"several target switches "
& "cannot be specified");
end if;
else
Target_Name :=
new String'
(Arg (Target_Project_Option'Length + 1
.. Arg'Last));
end if;
elsif Arg'Length > RTS_Option'Length
and then Arg (1 .. RTS_Option'Length) = RTS_Option
then
declare
Set : constant Boolean :=
Runtime_Name_Set_For (Snames.Name_Ada);
Old : constant String :=
Runtime_Name_For (Snames.Name_Ada);
RTS : constant String :=
Arg (RTS_Option'Length + 1 .. Arg'Last);
begin
if Set and then Old /= RTS then
Fail_Program
(Project_Tree,
"several different run-times " &
"cannot be specified");
end if;
Set_Runtime_For (Snames.Name_Ada, RTS);
end;
elsif Arg'Length > RTS_Language_Option'Length
and then Arg (1 .. RTS_Language_Option'Length) =
RTS_Language_Option
then
declare
Language_Name : Name_Id := No_Name;
RTS_Start : Natural := Arg'Last + 1;
begin
for J in RTS_Language_Option'Length + 2 ..
Arg'Last
loop
if Arg (J) = '=' then
Name_Len := 0;
Add_Str_To_Name_Buffer
(Arg
(RTS_Language_Option'Length + 1 ..
J - 1));
To_Lower (Name_Buffer (1 .. Name_Len));
Language_Name := Name_Find;
RTS_Start := J + 1;
exit;
end if;
end loop;
if Language_Name = No_Name then
Fail_Program
(Project_Tree, "illegal switch: " & Arg);
else
declare
RTS : constant String :=
Arg (RTS_Start .. Arg'Last);
Set : constant Boolean :=
Runtime_Name_Set_For (Language_Name);
Old : constant String :=
Runtime_Name_For (Language_Name);
begin
if Set and then Old /= RTS then
Fail_Program
(Project_Tree,
"several different run-times cannot" &
" be specified for the same language");
else
Set_Runtime_For (Language_Name, RTS);
end if;
end;
end if;
end;
elsif Arg'Length > Subdirs_Option'Length
and then
Arg (1 .. Subdirs_Option'Length) = Subdirs_Option
then
Subdirs :=
new String'
(Arg (Subdirs_Option'Length + 1 .. Arg'Last));
elsif Arg = Makeutl.Unchecked_Shared_Lib_Imports then
Opt.Unchecked_Shared_Lib_Imports := True;
else
Bad_Argument;
end if;
when 'a' =>
if Arg'Length < 4 then
Bad_Argument;
end if;
if Arg (3) = 'P' then
Prj.Env.Add_Directories
(Root_Environment.Project_Path,
Arg (4 .. Arg'Last));
else
Bad_Argument;
end if;
when 'c' =>
Compile_Only := True;
when 'e' =>
if Arg = "-eL" then
Follow_Links_For_Files := True;
Follow_Links_For_Dirs := True;
else
Bad_Argument;
end if;
when 'f' =>
Force_Deletions := True;
Opt.Directories_Must_Exist_In_Projects := False;
when 'F' =>
Full_Path_Name_For_Brief_Errors := True;
when 'h' =>
Display_Copyright;
Usage;
when 'n' =>
Do_Nothing := True;
when 'P' =>
if Project_File_Name /= null then
Osint.Fail ("multiple -P switches");
end if;
if Arg'Length > 2 then
declare
Prj : constant String := Arg (3 .. Arg'Last);
begin
if Prj'Length > 1
and then Prj (Prj'First) = '='
then
Project_File_Name :=
new String'
(Prj (Prj'First + 1 .. Prj'Last));
else
Project_File_Name := new String'(Prj);
end if;
end;
else
if Index = Last then
Osint.Fail ("no project specified after -P");
end if;
Index := Index + 1;
Project_File_Name := new String'(Argument (Index));
end if;
when 'q' =>
Quiet_Output := True;
when 'r' =>
All_Projects := True;
when 'v' =>
if Arg = "-v" then
Verbose_Mode := True;
elsif Arg = "-vP0" then
Current_Verbosity := Prj.Default;
elsif Arg = "-vP1" then
Current_Verbosity := Prj.Medium;
elsif Arg = "-vP2" then
Current_Verbosity := Prj.High;
else
Bad_Argument;
end if;
when 'X' =>
if Arg'Length = 2 then
Bad_Argument;
end if;
declare
Ext_Asgn : constant String := Arg (3 .. Arg'Last);
Start : Positive := Ext_Asgn'First;
Stop : Natural := Ext_Asgn'Last;
OK : Boolean := True;
begin
if Ext_Asgn (Start) = '"' then
if Ext_Asgn (Stop) = '"' then
Start := Start + 1;
Stop := Stop - 1;
else
OK := False;
end if;
end if;
if not OK
or else not Prj.Ext.Check
(Root_Environment.External,
Declaration => Ext_Asgn (Start .. Stop))
then
Osint.Fail
("illegal external assignment '"
& Ext_Asgn & ''');
end if;
end;
when others =>
Bad_Argument;
end case;
else
-- The file name of a main or a project file
declare
File_Name : String := Arg;
begin
Osint.Canonical_Case_File_Name (File_Name);
if File_Name'Length > Project_File_Extension'Length
and then
File_Name
(File_Name'Last - Project_File_Extension'Length + 1
.. File_Name'Last) = Project_File_Extension
then
if Project_File_Name /= null then
Osint.Fail
("cannot have several project files specified");
else
Project_File_Name := new String'(File_Name);
end if;
else
-- Not a project file, then it is a main
Mains.Add_Main (Arg);
end if;
end;
end if;
end if;
end;
Index := Index + 1;
end loop;
end Parse_Cmd_Line;
-----------
-- Usage --
-----------
procedure Usage is
begin
if not Usage_Displayed then
Usage_Displayed := True;
Put_Line ("Usage: gprclean [switches] -P {name}");
New_Line;
Put_Line (" {name} is zero or more file names");
New_Line;
Display_Usage_Version_And_Help;
Put_Line (" --distributed=slave1[,slave2]");
Put_Line (" Activate the remote clean-up");
Put_Line (" --slave-env[=name]");
Put_Line (" Use a specific slave's environment");
Put_Line (" --config=file.cgpr");
Put_Line (" Specify the configuration project file name");
if not Hostparm.OpenVMS then
Put_Line (" --autoconf=file.cgpr");
Put_Line
(" Specify/create the main config project file name");
end if;
if not Hostparm.OpenVMS then
Put_Line (" --target=targetname");
Put_Line (" Specify a target for cross platforms");
end if;
if not Hostparm.OpenVMS then
Put_Line (" --db dir Parse dir as an additional knowledge base");
end if;
if not Hostparm.OpenVMS then
Put_Line (" --db- Do not load the standard knowledge base");
end if;
Put_Line (" --RTS=");
Put_Line (" Use runtime for language Ada");
Put_Line (" --RTS:=");
Put_Line (" Use runtime for language ");
Put_Line (" --subdirs=dir");
Put_Line (" Real obj/lib/exec dirs are subdirs");
Put_Line (" " & Makeutl.Unchecked_Shared_Lib_Imports);
Put_Line (" Shared lib projects may import any project");
New_Line;
Put_Line (" -aPdir Add directory dir to project search path");
Put_Line (" -c Only delete compiler generated files");
Put_Line (" -eL Follow symbolic links when processing "
& "project files");
Put_Line (" -f Force deletions of unwritable files");
Put_Line (" -F Full project path name "
& "in brief error messages");
Put_Line (" -h Display this message");
Put_Line (" -n Nothing to do: only list files to delete");
Put_Line (" -P Use Project File ");
Put_Line (" -q Be quiet/terse");
Put_Line (" -r Clean all projects recursively");
Put_Line (" -v Verbose mode");
Put_Line (" -vPx Specify verbosity when parsing Project Files");
Put_Line (" -Xnm=val Specify an external reference "
& "for Project Files");
New_Line;
end if;
end Usage;
User_Project_Node : Project_Node_Id;
begin
-- Do the necessary initializations
Initialize;
-- Parse the command line, getting the switches and the executable names
Parse_Cmd_Line;
-- Once we have parsed the command line, we might know the target, and
-- thus can initialize the default project path.
if Target_Name = null then
Prj.Env.Initialize_Default_Project_Path
(Root_Environment.Project_Path, Target_Name => "");
else
Prj.Env.Initialize_Default_Project_Path
(Root_Environment.Project_Path, Target_Name.all);
end if;
if Load_Standard_Base then
Parse_Knowledge_Base (Project_Tree);
end if;
-- If no project file was specified, look first for a default
if Project_File_Name = null then
Look_For_Default_Project;
end if;
-- Check that a project file was specified and get the configuration
if Project_File_Name = null then
Try_Help;
Fail_Program
(Project_Tree,
"no project file specified and no default project file");
end if;
if Verbose_Mode then
Display_Copyright;
end if;
if Opt.Verbose_Mode then
New_Line;
Put ("Parsing Project File """);
Put (Project_File_Name.all);
Put_Line (""".");
New_Line;
end if;
-- Makes the Ada RTS is absolute if it is not a base name
if Runtime_Name_Set_For (Snames.Name_Ada) then
Locate_Runtime (Project_Tree, Snames.Name_Ada);
end if;
-- Check command line arguments. These will be overridden when looking
-- for the configuration file
if Target_Name = null then
Target_Name := new String'("");
end if;
if Config_Project_File_Name = null then
Config_Project_File_Name := new String'("");
end if;
begin
Parse_Project_And_Apply_Config
(Main_Project => Main_Project,
User_Project_Node => User_Project_Node,
Config_File_Name => Config_Project_File_Name.all,
Autoconf_Specified => Autoconf_Specified,
Project_File_Name => Project_File_Name.all,
Project_Tree => Project_Tree,
Project_Node_Tree => Project_Node_Tree,
Packages_To_Check => Packages_To_Check,
Env => Root_Environment,
Allow_Automatic_Generation => Autoconfiguration,
Automatically_Generated => Delete_Autoconf_File,
Config_File_Path => Configuration_Project_Path,
Target_Name => Target_Name.all,
Normalized_Hostname => Normalized_Hostname,
Implicit_Project => No_Project_File_Found);
-- Print warnings that might have occurred while parsing the project
Prj.Err.Finalize;
-- But avoid duplicate warnings later on
Prj.Err.Initialize;
exception
when E : Prj.Conf.Invalid_Config =>
Osint.Fail (Exception_Message (E));
end;
if Main_Project = No_Project then
-- Don't flush messages in case of parsing error. This has already
-- been taken care when parsing the tree. Otherwise, it results in
-- the same message being displayed twice.
Fail_Program
(Project_Tree,
"""" & Project_File_Name.all & """ processing failed",
Flush_Messages => User_Project_Node /= Empty_Node);
end if;
-- Update info on all sources
declare
Iter : Source_Iterator;
begin
Iter := For_Each_Source (Project_Tree);
while Prj.Element (Iter) /= No_Source loop
Initialize_Source_Record (Prj.Element (Iter));
Next (Iter);
end loop;
end;
-- Even if the config project file has not been automatically
-- generated, gprclean will delete it if it was specified using
-- --autoconf=.
Delete_Autoconf_File := Delete_Autoconf_File or Autoconf_Specified;
if Configuration_Project_Path /= null then
Free (Config_Project_File_Name);
Config_Project_File_Name := new String'
(Base_Name (Configuration_Project_Path.all));
end if;
if Opt.Verbose_Mode then
New_Line;
Put ("Parsing of Project File """);
Put (Project_File_Name.all);
Put (""" is finished.");
New_Line;
end if;
Mains.Fill_From_Project (Main_Project, Project_Tree);
Mains.Complete_Mains
(Root_Environment.Flags, Main_Project, Project_Tree);
if Verbose_Mode then
New_Line;
end if;
Processed_Projects.Init;
if Slave_Env = null and then Distributed_Mode then
Slave_Env :=
new String'(Compute_Slave_Env (Project_Tree, Slave_Env_Auto));
if Slave_Env_Auto and not Opt.Quiet_Output then
Put_Line ("slave environment is " & Slave_Env.all);
end if;
end if;
-- Clean-up local build
declare
procedure Do_Clean (Prj : Project_Id; Tree : Project_Tree_Ref);
--------------
-- Do_Clean --
--------------
procedure Do_Clean (Prj : Project_Id; Tree : Project_Tree_Ref) is
begin
-- For the main project and all aggregated projects, remove the
-- binder and linker generated files.
Clean_Project
(Prj, Tree, Main => True, Remove_Executables => not Compile_Only);
-- Clean-up remote slaves
if Distributed_Mode then
Clean_Up_Remote_Slaves (Tree, Prj);
end if;
end Do_Clean;
procedure For_All is new For_Project_And_Aggregated (Do_Clean);
begin
-- For an aggregate project, we always cleanup all aggregated
-- projects, whether "-r" was specified or not. But for those
-- projects, we might not clean their imported projects.
For_All (Main_Project, Project_Tree);
end;
if Delete_Autoconf_File then
Delete ("", Configuration_Project_Path.all);
end if;
-- In verbose mode, if Delete has not been called, indicate that
-- no file needs to be deleted.
if Verbose_Mode and (not File_Deleted) then
New_Line;
if Do_Nothing then
Put_Line ("No file needs to be deleted");
else
Put_Line ("No file has been deleted");
end if;
end if;
end Gprclean.Main;
gprbuild-gpl-2014-src/src/gprinstall-uninstall.adb 0000644 0000767 0000145 00000021002 12323721731 021553 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R I N S T A L L . M A I N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Containers.Indefinite_Ordered_Sets; use Ada;
with Ada.Directories; use Ada.Directories;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.MD5; use GNAT.MD5;
with Gpr_Util; use Gpr_Util;
with Opt;
with Osint;
with Output; use Output;
package body Gprinstall.Uninstall is
package File_Set is new Containers.Indefinite_Ordered_Sets (String);
-------------
-- Process --
-------------
procedure Process (Install_Name : String) is
procedure Delete_File (Position : File_Set.Cursor);
-- Delete file pointed to by Position, do nothing if the file is not
-- found.
procedure Do_Delete (Filename : String);
-- Delete file or display a message if in dry-run mode
procedure Delete_Empty_Directory (Dir_Name : String);
-- Delete Dir_Name if empty, if removed try with parent directory
function Project_Dir return String;
-- Returns the full pathname to the project directory
----------------------------
-- Delete_Empty_Directory --
----------------------------
procedure Delete_Empty_Directory (Dir_Name : String) is
Prj_Dir_Len : constant Natural := Global_Prefix_Dir.V'Length - 1;
Search : Search_Type;
Element : Directory_Entry_Type;
Empty : Boolean := True;
begin
-- Do not try to remove a directory past the project dir
if Dir_Name'Length >= Prj_Dir_Len then
-- Check whether the directory is empty or not
Start_Search (Search, Dir_Name, Pattern => "");
Check_Entry : while More_Entries (Search) loop
Get_Next_Entry (Search, Element);
if Simple_Name (Element) /= "."
and then Simple_Name (Element) /= ".."
then
Empty := False;
exit Check_Entry;
end if;
end loop Check_Entry;
End_Search (Search);
-- If empty delete it
if Empty then
begin
Delete_Directory (Dir_Name);
exception
-- This can happen if there is still some sym links into
-- the directory.
when Text_IO.Use_Error =>
null;
end;
-- And then try recursively with parent directory
Delete_Empty_Directory (Containing_Directory (Dir_Name));
end if;
end if;
end Delete_Empty_Directory;
-----------------
-- Delete_File --
-----------------
procedure Delete_File (Position : File_Set.Cursor) is
Name : constant String := File_Set.Element (Position);
begin
Do_Delete (Global_Prefix_Dir.V.all & Name);
end Delete_File;
---------------
-- Do_Delete --
---------------
procedure Do_Delete (Filename : String) is
begin
if Dry_Run then
Write_Line ("delete " & Filename);
elsif Exists (Filename) then
Delete_File (Filename);
Delete_Empty_Directory (Containing_Directory (Filename));
end if;
end Do_Delete;
-----------------
-- Project_Dir --
-----------------
function Project_Dir return String is
begin
if Is_Absolute_Path (Global_Project_Subdir.V.all) then
return Global_Project_Subdir.V.all;
else
return Global_Prefix_Dir.V.all & Global_Project_Subdir.V.all;
end if;
end Project_Dir;
Dir : constant String := Project_Dir & "manifests";
Name : constant String := Dir & DS & Install_Name;
Man : File_Type;
Buffer : String (1 .. 4096);
Last : Natural;
Files : File_Set.Set;
Changed : File_Set.Set;
-- Ranges in Buffer above, we have the MD5 (32 chars) a space and then
-- the filename.
subtype MD5_Range is Positive range Message_Digest'Range;
subtype Name_Range is Positive range MD5_Range'Last + 2 .. Buffer'Last;
File_Digest : Message_Digest;
Expected_Digest : Message_Digest;
Removed : Boolean;
begin
-- Check if manifest for this project exists
if not Exists (Name) then
if not Opt.Quiet_Output then
Osint.Fail ("Project " & Name & " not found.");
end if;
Osint.Exit_Program (Osint.E_Errors);
end if;
if not Opt.Quiet_Output then
Write_Line ("Uninstall project " & Install_Name);
end if;
-- Check each file to be deleted
Open (Man, In_File, Name);
while not End_Of_File (Man) loop
Get_Line (Man, Buffer, Last);
-- Skip first line if it is the original project's signature
if Last > MD5_Range'Last
and then Buffer (1 .. 2) /= Sig_Line
then
declare
F_Name : constant String := Buffer (Name_Range'First .. Last);
begin
Expected_Digest := Buffer (MD5_Range);
if Exists (Global_Prefix_Dir.V.all & F_Name) then
File_Digest := File_MD5 (Global_Prefix_Dir.V.all & F_Name);
Removed := False;
else
Removed := True;
end if;
-- Unconditionnaly add a file to the remove list if digest is
-- ok, if we are running in force mode or the file has already
-- been removed.
if File_Digest = Expected_Digest
or else Force_Installations
or else Removed
then
-- Make sure we always destroy the symbolic links before the
-- files itself.
Files.Include (F_Name);
else
Changed.Include (F_Name);
end if;
end;
end if;
end loop;
Close (Man);
-- Delete files
if Changed.Is_Subset (Of_Set => Files) then
Files.Iterate (Delete_File'Access);
-- Then finally delete the manifest for this project
Do_Delete (Name);
else
if not Opt.Quiet_Output then
Write_Line ("Following files have been changed:");
declare
procedure Display (Position : File_Set.Cursor);
-- Display only if not part of Files set
-------------
-- Display --
-------------
procedure Display (Position : File_Set.Cursor) is
F_Name : constant String := File_Set.Element (Position);
begin
if not Files.Contains (F_Name) then
Write_Line (F_Name);
end if;
end Display;
begin
Changed.Iterate (Display'Access);
end;
Write_Line ("use option -f to force file deletion.");
end if;
end if;
end Process;
end Gprinstall.Uninstall;
gprbuild-gpl-2014-src/src/gprslave.adb 0000644 0000767 0000145 00000151530 12323721731 017222 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R S L A V E --
-- --
-- B o d y --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Containers.Indefinite_Ordered_Sets;
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Vectors;
with Ada.Directories; use Ada.Directories;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Streams.Stream_IO; use Ada.Streams;
with Ada.Strings.Equal_Case_Insensitive;
with Ada.Strings.Fixed; use Ada.Strings;
with Ada.Strings.Hash_Case_Insensitive;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
with Interfaces;
with System.Multiprocessors; use System;
with Csets; use Csets;
with Gnatvsn; use Gnatvsn;
with Namet; use Namet;
with Prj; use Prj;
with Prj.Env; use Prj.Env;
with Prj.Part; use Prj.Part;
with Prj.Proc; use Prj.Proc;
with Prj.Tree; use Prj.Tree;
with Snames; use Snames;
with Types;
with GNAT.Command_Line; use GNAT;
with GNAT.CRC32;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Sockets; use GNAT.Sockets;
with GNAT.String_Split; use GNAT.String_Split;
with GNAT.Strings;
with Gpr_Util; use Gpr_Util;
with Gprbuild.Compilation; use Gprbuild.Compilation;
with Gprbuild.Compilation.Process; use Gprbuild.Compilation.Process;
with Gprbuild.Compilation.Protocol; use Gprbuild.Compilation.Protocol;
with GprConfig.Knowledge; use GprConfig.Knowledge;
procedure Gprslave is
use Ada;
-- Data for a build master
type Build_Master is record
Channel : Communication_Channel; -- communication with build master
Socket : Socket_Type;
Project_Name : Unbounded_String;
Target : Unbounded_String;
Build_Env : Unbounded_String;
Sync : Sync_Kind;
end record;
function "<" (B1, B2 : Build_Master)
return Boolean is (To_C (B1.Socket) < To_C (B2.Socket));
function "="
(B1, B2 : Build_Master) return Boolean is (B1.Socket = B2.Socket);
package Builder_Set is new Containers.Ordered_Sets (Build_Master);
-- Representation of a job data
type Job_Data is record
Cmd : Command;
Id : Remote_Id; -- job id must be uniq across all slaves
Pid : Integer; -- the OS process id
Dep_Dir : Unbounded_String;
Dep_File : Unbounded_String;
Obj_File : Unbounded_String;
Output : Unbounded_String;
Build_Sock : Socket_Type; -- key used to get the corresponding builder
end record;
No_Job : constant Job_Data := (Id => -1, others => <>);
function "<" (J1, J2 : Job_Data) return Boolean is (J1.Pid < J2.Pid);
function "=" (J1, J2 : Job_Data) return Boolean is (J1.Pid = J2.Pid);
package Job_Data_Set is new Containers.Ordered_Sets (Job_Data);
package To_Run_Set is new Containers.Vectors (Positive, Job_Data);
function Get_Arg (Builder : Build_Master; Value : String) return String;
pragma Inline (Get_Arg);
-- Returns Value with possible translation of the local repositories
function Get_Args
(Builder : Build_Master; Slices : Slice_Set) return Argument_List;
-- Returns an Argument_List corresponding to the Slice_Set
procedure Wait_For_Master;
-- Wait for a build master to connect, initialize the globval communication
-- channel below. Send the slave config to the build master.
function Image (Value : Long_Integer) return String;
-- Return Value string representation without the leading space
function Work_Directory (Builder : Build_Master) return String;
-- Directory where compilation are to be done, this is the directory named
-- after the project under the Root_Directory.
procedure Parse_Command_Line;
-- Parse the command line options, set variables below accordingly
function Get_Slave_Id return Remote_Id;
task Wait_Completion;
-- Waiting for job completion and sending back the response to the build
-- masters.
task Protocol_Handler;
-- Waiting for incoming requests from the masters, take corresponding
-- actions.
task Run_Compilation;
-- Task running a maximum of Max_Process compilation simultaneously. These
-- jobs are taken from the To_Run protected object.
-- A mutex to avoid interweaved responses on the channel and keep the
-- working directory. Indeed the tasks are moving to some working directory
-- from where a compilation has to be run or where the builder environment
-- has to be created. We must ensure that all those actions are atomic.
protected Mutex is
entry Seize;
procedure Release;
private
Free : Boolean := True;
end Mutex;
-- Protected builders data set (used by environment task and the
-- Protocol_Handler).
protected Builders is
procedure Insert (Builder : Build_Master);
-- Add Builder into the set
procedure Remove (Builder : Build_Master);
-- Remove Builder from the set
function Get (Socket : Socket_Type) return Build_Master;
-- Get the builder using Socket
entry Get_Socket_Set (Socket_Set : out Socket_Set_Type);
-- Get a socket set for all builders
private
Builders : Builder_Set.Set;
end Builders;
-- Queue of Job to run, A FIFO list
protected To_Run is
procedure Push (Job : Job_Data);
entry Pop (Job : out Job_Data);
private
Set : To_Run_Set.Vector;
end To_Run;
-- Set of running jobs
protected Running is
procedure Register (Job : Job_Data);
-- Register a running Job
procedure Get (Job : out Job_Data; Pid : Process_Id);
-- Get Job having the given Pid
procedure Set_Max (Max : Positive);
-- Set the maximum running processes simultaneously
entry Wait_Slot;
-- Wait for a running slot to be available
entry Wait;
-- Wait for at least one running process
private
Set : Job_Data_Set.Set;
Count : Natural := 0;
Max : Natural := 0;
end Running;
Compiler_Path : constant OS_Lib.String_Access :=
Locate_Exec_On_Path ("gnatls");
Slave_Id : Remote_Id;
-- Host Id used to compose a unique job id across all running slaves
-- Command line parameters statuses
Port : aliased Integer;
Max_Processes : aliased Integer;
Help : aliased Boolean;
Verbose : aliased Boolean;
Debug : aliased Boolean;
Root_Directory : aliased GNAT.Strings.String_Access :=
new String'(Current_Directory);
-- Root directoty for the gprslave environment. All projects sources and
-- compilations are done under this directory.
-- Running instances statuses
Address : Sock_Addr_Type;
Server : Socket_Type;
Index : Long_Integer := 0;
-- Knowledge base
Base : Knowledge_Base;
Selected_Targets_Set : Targets_Set_Id;
--------------
-- Builders --
--------------
protected body Builders is
---------
-- Get --
---------
function Get (Socket : Socket_Type) return Build_Master is
Builder : Build_Master;
Pos : Builder_Set.Cursor;
begin
Builder.Socket := Socket;
Pos := Builders.Find (Builder);
if Builder_Set.Has_Element (Pos) then
Builder := Builder_Set.Element (Pos);
end if;
return Builder;
end Get;
--------------------
-- Get_Socket_Set --
--------------------
entry Get_Socket_Set (Socket_Set : out Socket_Set_Type)
when not Builders.Is_Empty is
begin
Empty (Socket_Set);
for B of Builders loop
Set (Socket_Set, B.Socket);
end loop;
end Get_Socket_Set;
------------
-- Insert --
------------
procedure Insert (Builder : Build_Master) is
begin
Builders.Insert (Builder);
end Insert;
------------
-- Remove --
------------
procedure Remove (Builder : Build_Master) is
begin
Builders.Delete (Builder);
end Remove;
end Builders;
-------------
-- Get_Arg --
-------------
function Get_Arg (Builder : Build_Master; Value : String) return String is
P : constant Natural := Fixed.Index (Value, WD_Path_Tag);
begin
if P = 0 then
return Value;
else
return Value (Value'First .. P - 1)
& Work_Directory (Builder)
& Directory_Separator
& Get_Arg (Builder, Value (P + WD_Path_Tag'Length .. Value'Last));
end if;
end Get_Arg;
--------------
-- Get_Args --
--------------
function Get_Args
(Builder : Build_Master; Slices : Slice_Set) return Argument_List
is
Args : Argument_List (1 .. Integer (Slice_Count (Slices)));
begin
for K in Args'Range loop
Args (K) := new String'
(Get_Arg (Builder, Slice (Slices, Slice_Number (K))));
end loop;
return Args;
end Get_Args;
-----------------
-- Get_Slave_Id --
-----------------
function Get_Slave_Id return Remote_Id is
use GNAT.CRC32;
use type Interfaces.Unsigned_32;
CRC : GNAT.CRC32.CRC32;
begin
Initialize (CRC);
Update (CRC, Host_Name);
-- Set the host id as the 32 higher bits
return Remote_Id (Get_Value (CRC)) * 2 ** 32;
end Get_Slave_Id;
-----------
-- Image --
-----------
function Image (Value : Long_Integer) return String is
I : constant String := Long_Integer'Image (Value);
begin
return (if I (I'First) = '-'
then I
else I (I'First + 1 .. I'Last));
end Image;
-----------
-- Mutex --
-----------
protected body Mutex is
-----------
-- Seize --
-----------
entry Seize when Free is
begin
Free := False;
end Seize;
-------------
-- Release --
-------------
procedure Release is
begin
Free := True;
end Release;
end Mutex;
------------------------
-- Parse_Command_Line --
------------------------
procedure Parse_Command_Line is
use GNAT.Command_Line;
Config : Command_Line_Configuration;
begin
Define_Switch
(Config, Help'Access,
"-h", Long_Switch => "--help",
Help => "display this help message");
Define_Switch
(Config, Max_Processes'Access,
"-j:", Long_Switch => "--jobs=",
Initial => Integer (Multiprocessors.Number_Of_CPUs),
Default => Integer (Multiprocessors.Number_Of_CPUs),
Help => "set the maximum simultaneous compilation");
Define_Switch
(Config, Root_Directory'Access,
"-d:", Long_Switch => "--directory=",
Help => "set the root directory");
Define_Switch
(Config, Port'Access,
"-p:", Long_Switch => "--port=",
Initial => Integer (Default_Port),
Default => Integer (Default_Port),
Help => "set the port the slave will listen to");
Define_Switch
(Config, Verbose'Access,
"-v", Long_Switch => "--verbose",
Help => "activate verbose mode, display extra information");
Define_Switch
(Config, Debug'Access,
"-vv", Long_Switch => "--debug",
Help => "activate debug mode, display lot of information (imply -v)");
Set_Usage (Config, Usage => "[switches]");
Getopt (Config);
if Help then
Display_Help (Config);
OS_Exit (1);
end if;
if Debug then
Verbose := True;
end if;
-- Ensure Root_Directory does not ends with a directory separator
if Root_Directory (Root_Directory'Last) in '/' | '\' then
Delete_Last : declare
RD : constant String := Root_Directory
(Root_Directory'First .. Root_Directory'Last - 1);
begin
Free (Root_Directory);
Root_Directory := new String'(RD);
end Delete_Last;
end if;
Running.Set_Max (Max_Processes);
exception
when Invalid_Switch =>
OS_Exit (1);
when Exit_From_Command_Line =>
OS_Exit (1);
end Parse_Command_Line;
----------------------
-- Protocol_Handler --
----------------------
task body Protocol_Handler is
type Job_Number is mod 2**32;
-- A 32bits integer which wrap around. This is no problem as we want
-- to be able to identify running process. There won't be 2**32 process
-- running at the same time. So it is safe restart numbering at 0.
Selector : Selector_Type;
R_Socket_Set : Socket_Set_Type;
Empty_Set : Socket_Set_Type;
Status : Selector_Status;
Builder : Build_Master;
Socket : Socket_Type;
Jid : Job_Number := 0;
begin
-- Create selector
Create_Selector (Selector);
Empty (Empty_Set);
-- For now do not check write status
Handle_Commands : loop
-- Wait for some commands from one of the build master
Builders.Get_Socket_Set (R_Socket_Set);
Wait_Incoming_Data : loop
begin
Check_Selector (Selector, R_Socket_Set, Empty_Set, Status);
exit Wait_Incoming_Data;
exception
when E : Socket_Error =>
if Resolve_Exception (E) /= Interrupted_System_Call then
raise;
end if;
end;
end loop Wait_Incoming_Data;
Get (R_Socket_Set, Socket);
if Socket /= No_Socket then
Builder := Builders.Get (Socket);
Mutex.Seize;
declare
Cmd : constant Command := Get_Command (Builder.Channel);
begin
if Debug then
Put ("# command: " & Command_Kind'Image (Kind (Cmd)));
declare
List : constant Argument_List_Access := Args (Cmd);
begin
if List /= null then
for K in List'Range loop
Put (", " & List (K).all);
end loop;
end if;
end;
New_Line;
end if;
if Kind (Cmd) = EX then
Record_Job : declare
Id : constant Remote_Id := Slave_Id + Remote_Id (Jid);
-- Note that the Id above should be unique across all
-- running slaves. This is not the process id, but an id
-- sent back to the build master to identify the actual
-- job.
begin
Jid := Jid + 1;
if Debug then
Put_Line ("# register compilation " & Image (Id));
end if;
To_Run.Push
(Job_Data'(Cmd,
Id, -1,
Null_Unbounded_String,
Null_Unbounded_String,
Null_Unbounded_String,
Null_Unbounded_String,
Builder.Socket));
Send_Ack (Builder.Channel, Id);
end Record_Job;
elsif Kind (Cmd) = FL then
null;
elsif Kind (Cmd) = CU then
Clean_Up_Request : begin
Builder.Project_Name :=
To_Unbounded_String (Args (Cmd)(1).all);
if Exists (Work_Directory (Builder)) then
if Verbose then
Put_Line ("Delete " & Work_Directory (Builder));
end if;
Delete_Tree (Work_Directory (Builder));
end if;
Send_Ok (Builder.Channel);
exception
when others =>
Send_Ko (Builder.Channel);
end Clean_Up_Request;
elsif Kind (Cmd) = EC then
-- No more compilation for this project
Close (Builder.Channel);
Builders.Remove (Builder);
if Verbose then
Put_Line
("End project : " & To_String (Builder.Project_Name));
end if;
else
raise Constraint_Error with "unexpected command "
& Command_Kind'Image (Kind (Cmd));
end if;
exception
when E : others =>
Put_Line ("Error: " & Exception_Information (E));
-- In case of an exception, communication endded
-- prematurately or some wrong command received, make sure
-- we clean the slave state and we listen to new commands.
-- Not doing that could make the slave unresponding.
Close (Builder.Channel);
end;
Mutex.Release;
end if;
end loop Handle_Commands;
exception
when E : others =>
Put_Line ("Unrecoverable error: Protocol_Handler.");
Put_Line (Exception_Information (E));
OS_Exit (1);
end Protocol_Handler;
---------------------
-- Run_Compilation --
---------------------
task body Run_Compilation is
function Get_Driver
(Builder : Build_Master; Language, Project : String) return String;
-- Returns the compiler driver for the given language and the current
-- target as retreived from the initial handshake context exchange.
function Get_Output_File (Builder : Build_Master) return String;
-- Returns a unique output file
procedure Output_Compilation (File : String);
-- Output compilation information
package Drivers_Cache is new Containers.Indefinite_Hashed_Maps
(String, String,
Ada.Strings.Hash_Case_Insensitive,
Ada.Strings.Equal_Case_Insensitive);
Cache : Drivers_Cache.Map;
----------------
-- Get_Driver --
----------------
function Get_Driver
(Builder : Build_Master; Language, Project : String) return String
is
procedure Look_Driver (Project_Name : String; Is_Config : Boolean);
-- Set Driver with the found driver for the Language
Key : constant String :=
To_String (Builder.Target) & '+' & Language;
Position : constant Drivers_Cache.Cursor :=
Cache.Find (Key);
Compilers, Filters : Compiler_Lists.List;
Requires_Comp : Boolean;
Comp : Compiler_Access;
Env : Environment;
Success : Boolean;
Driver : Unbounded_String := To_Unbounded_String (Key);
-----------------
-- Look_Driver --
-----------------
procedure Look_Driver (Project_Name : String; Is_Config : Boolean) is
Project_Node_Tree : Project_Node_Tree_Ref;
Project_Node : Project_Node_Id := Empty_Node;
Project_Tree : Project_Tree_Ref;
Project : Project_Id;
begin
Project_Node_Tree := new Project_Node_Tree_Data;
Prj.Tree.Initialize (Project_Node_Tree);
Prj.Part.Parse
(Project_Node_Tree, Project_Node,
Project_Name,
Errout_Handling => Prj.Part.Finalize_If_Error,
Packages_To_Check => null,
Is_Config_File => Is_Config,
Target_Name => To_String (Builder.Target),
Env => Env);
Project_Tree := new Project_Tree_Data;
Prj.Initialize (Project_Tree);
Proc.Process
(Project_Tree, Project, null, Success,
Project_Node, Project_Node_Tree, Env);
if not Success then
return;
end if;
declare
Pcks : Package_Table.Table_Ptr
renames Project_Tree.Shared.Packages.Table;
Pck : Package_Id := Project.Decl.Packages;
begin
Look_Compiler_Package : while Pck /= No_Package loop
if Pcks (Pck).Decl /= No_Declarations
and then Pcks (Pck).Name = Name_Compiler
then
-- Look for the Driver ("") attribute
declare
Id : Array_Id := Pcks (Pck).Decl.Arrays;
begin
while Id /= No_Array loop
declare
V : constant Array_Data :=
Project_Tree.Shared.Arrays.Table (Id);
begin
if V.Name = Name_Driver
and then V.Value /= No_Array_Element
then
-- Check if element is for the given
-- language, and if so return the
-- corresponding value.
declare
E : constant Array_Element :=
Project_Tree.Shared.
Array_Elements.Table (V.Value);
begin
if Get_Name_String (E.Index) =
To_Lower (Language)
then
Driver := To_Unbounded_String
(Get_Name_String (E.Value.Value));
exit Look_Compiler_Package;
end if;
end;
end if;
end;
Id := Project_Tree.Shared.Arrays.Table (Id).Next;
end loop;
end;
end if;
Pck := Pcks (Pck).Next;
end loop Look_Compiler_Package;
end;
exception
-- Never propagate an exception, the driver won't be set anyway
when others =>
null;
end Look_Driver;
begin
if Drivers_Cache.Has_Element (Position) then
return Drivers_Cache.Element (Position);
else
-- Generate the configuration project for this language and target
Parse_Config_Parameter
(Base => Base,
Config => Language,
Compiler => Comp,
Requires_Compiler => Requires_Comp);
if Requires_Comp then
Filters.Append (Comp);
else
Compilers.Append (Comp);
end if;
Complete_Command_Line_Compilers
(Base,
Selected_Targets_Set,
Filters,
Compilers);
-- Generate configuration project file
Generate_Configuration
(Base, Compilers, "slave_tmp.cgpr", To_String (Builder.Target));
Prj.Tree.Initialize (Env, Prj.Gprbuild_Flags);
Prj.Initialize (Prj.No_Project_Tree);
Prj.Env.Initialize_Default_Project_Path
(Env.Project_Path, Target_Name => To_String (Builder.Target));
-- Parse it to find the driver for this language
Look_Driver ("slave_tmp.cgpr", Is_Config => True);
Directories.Delete_File ("slave_tmp.cgpr");
-- Language is not found in the knowledge base, check the project
-- to see if there is a definition for the language.
if Driver = Key then
Look_Driver (Project, Is_Config => False);
-- Ensure that we have a full-path name
declare
Exe : OS_Lib.String_Access :=
Locate_Exec_On_Path (To_String (Driver));
begin
Driver := To_Unbounded_String (Exe.all);
Free (Exe);
end;
end if;
-- Record this driver for the language and target into the cache
Cache.Insert (Key, To_String (Driver));
-- Clean-up and free project structure
if Debug then
Put_Line
("# driver for " & Language & " is : " & To_String (Driver));
end if;
return To_String (Driver);
end if;
exception
when others =>
-- Be sure we never propagate an exception from this routine, in
-- case of problem we just return the key, this will be used as an
-- executable and will be reported to the master as a proper build
-- failure.
return Key;
end Get_Driver;
---------------------
-- Get_Output_File --
---------------------
function Get_Output_File (Builder : Build_Master) return String is
Filename : constant String := "output.slave." & Image (Index);
begin
Index := Index + 1;
return Compose (Work_Directory (Builder), Filename);
end Get_Output_File;
------------------------
-- Output_Compilation --
------------------------
procedure Output_Compilation (File : String) is
RDL : constant Natural := Root_Directory'Length;
begin
if Verbose then
if File'Length > RDL
and then File (File'First .. File'First + RDL - 1)
= Root_Directory.all
then
Text_IO.Put_Line
("Compiling: " & File (File'First + RDL + 1 .. File'Last));
else
Text_IO.Put_Line ("Compiling: " & File);
end if;
end if;
end Output_Compilation;
Job : Job_Data;
begin
loop
-- Launch a new compilation only if the maximum of simultaneous
-- process has not yet been reached.
Running.Wait_Slot;
To_Run.Pop (Job);
Process : declare
Builder : constant Build_Master := Builders.Get (Job.Build_Sock);
Dir : constant String := Args (Job.Cmd)(2).all;
List : Slice_Set;
Pid : Process_Id;
begin
-- Enter a critical section to:
-- - move to directory where the command is executed
-- - execute the compilation command
-- - register a new job and acknowledge
-- - move back to working directory
Mutex.Seize;
if Debug then
Put_Line
("# move to work directory " & Work_Directory (Builder));
end if;
Set_Directory (Work_Directory (Builder));
-- Create/Move to object dir if any, note that if we
-- have an absolute path name here it is because the
-- Build_Root is probably not properly set. Try to fail
-- gracefully to report a proper error message to the
-- build master.
--
-- If we have an absolute pathname, just start the
-- process into the to directory. The output file will
-- be created there and will be reported to the master.
--
-- Note that the following block should never fail otherwise the
-- process won't be started. Even if we know the compilation will
-- fail we need to move forward as the result for this compilation
-- is waited for by the build master.
begin
if Dir /= "" then
if not Is_Absolute_Path (Dir)
and then not Is_Directory (Dir)
then
Create_Directory (Dir);
end if;
if Debug then
Put_Line ("# move to directory " & Dir);
end if;
Set_Directory (Dir);
end if;
exception
when others =>
if Debug then
Put_Line ("# cannot move to object directory");
end if;
end;
Create (List, Args (Job.Cmd)(6).all, String'(1 => Opts_Sep));
Execute : declare
Project : constant String :=
Get_Arg (Builder, Args (Job.Cmd)(1).all);
Language : constant String := Args (Job.Cmd)(3).all;
Out_File : constant String :=
Get_Output_File (Builder);
Obj_File : constant String := Args (Job.Cmd)(4).all;
Dep_File : constant String := Args (Job.Cmd)(5).all;
Env : constant String :=
Get_Arg (Builder, Args (Job.Cmd) (7).all);
O : Argument_List := Get_Args (Builder, List);
begin
Output_Compilation (O (O'Last).all);
-- Set compiler environment
Set_Env (Env, Fail => False, Force => True);
Pid := Non_Blocking_Spawn
(Get_Driver (Builder, Language, Project), O, Out_File);
if Debug then
Put_Line
("# pid" & Integer'Image (Pid_To_Integer (Pid)));
Put_Line ("# dep_file " & Dep_File);
Put_Line ("# out_file " & Out_File);
Put_Line ("# obj_file " & Obj_File);
end if;
Job.Pid := Pid_To_Integer (Pid);
Job.Dep_File := To_Unbounded_String (Dep_File);
Job.Obj_File := To_Unbounded_String (Obj_File);
Job.Output := To_Unbounded_String (Out_File);
Job.Dep_Dir := To_Unbounded_String
((if Is_Absolute_Path (Dir) then "" else Dir));
Running.Register (Job);
Mutex.Release;
for K in O'Range loop
Free (O (K));
end loop;
end Execute;
exception
when E : others =>
Mutex.Release;
if Debug then
Put_Line
("# Error in Run_Compilation: "
& Exception_Information (E));
end if;
end Process;
end loop;
exception
when E : others =>
Put_Line ("Unrecoverable error: Run_Compilation.");
Put_Line (Exception_Information (E));
OS_Exit (1);
end Run_Compilation;
-------------
-- Running --
-------------
protected body Running is
--------------
-- Register --
--------------
procedure Register (Job : Job_Data) is
begin
Set.Insert (Job);
Count := Count + 1;
end Register;
---------
-- Get --
---------
procedure Get (Job : out Job_Data; Pid : Process_Id) is
Pos : Job_Data_Set.Cursor;
begin
Job.Pid := Pid_To_Integer (Pid);
Pos := Set.Find (Job);
-- Not that a job could be not found here because the Pid is one of
-- gprconfig runned to generate a configuration file for a specific
-- language.
if Job_Data_Set.Has_Element (Pos) then
Job := Job_Data_Set.Element (Pos);
Set.Delete (Job);
Count := Count - 1;
else
Job := No_Job;
end if;
end Get;
-------------
-- Set_Max --
-------------
procedure Set_Max (Max : Positive) is
begin
Running.Max := Max;
end Set_Max;
----------
-- Wait --
----------
entry Wait when Count > 0 is
begin
null;
end Wait;
---------------
-- Wait_Slot --
---------------
entry Wait_Slot when Count < Max is
begin
null;
end Wait_Slot;
end Running;
------------
-- To_Run --
------------
protected body To_Run is
----------
-- Push --
----------
procedure Push (Job : Job_Data) is
begin
Set.Append (Job);
end Push;
---------
-- Pop --
---------
entry Pop (Job : out Job_Data) when not Set.Is_Empty is
begin
Job := Set.First_Element;
Set.Delete_First;
end Pop;
end To_Run;
---------------------
-- Wait_Completion --
---------------------
task body Wait_Completion is
Pid : Process_Id;
Success : Boolean;
Job : Job_Data;
Builder : Build_Master;
begin
loop
-- Wait for a job to complete only if there is job running
Running.Wait;
Wait_Process (Pid, Success);
Mutex.Seize;
Running.Get (Job, Pid);
-- Note that if there is not such element it could be because the
-- build master has been killed before the end of the compilation.
-- In this case an EC message is received by the slave and the
-- Job_Set is clear. See Main_Loop in gprslave's body.
if Job /= No_Job then
declare
A : Argument_List_Access := Args (Job.Cmd);
begin
-- Free args
for K in A'Range loop
Free (A (K));
end loop;
Free (A);
end;
-- Now get the corresponding build master
Builder := Builders.Get (Job.Build_Sock);
-- ???What to do if the builder is not found???
-- Enter a critical section to:
-- - send atomic response to build master
-- - make sure the current directory is the work directory
begin
if Debug then
Put_Line ("# job " & Image (Job.Id) & " terminated");
end if;
declare
DS : Character renames Directory_Separator;
Dep_Dir : constant String := To_String (Job.Dep_Dir);
Dep_File : constant String := To_String (Job.Dep_File);
Obj_File : constant String := To_String (Job.Obj_File);
Out_File : constant String := To_String (Job.Output);
S : Boolean;
begin
Send_Output (Builder.Channel, Out_File);
OS_Lib.Delete_File (Out_File, S);
if Success then
-- No Dep_File to send back if the compilation was not
-- successful.
declare
D_File : constant String :=
Work_Directory (Builder)
& (if Dep_Dir /= "" then DS & Dep_Dir else "")
& DS & Dep_File;
begin
if Exists (D_File)
and then Kind (D_File) = Ordinary_File
then
Send_File
(Builder.Channel, D_File, Rewrite => True);
end if;
end;
declare
O_File : constant String :=
Work_Directory (Builder)
& (if Dep_Dir /= "" then DS & Dep_Dir else "")
& DS & Obj_File;
begin
if Builder.Sync = Protocol.Gpr
and then Exists (O_File)
then
Send_File
(Builder.Channel, O_File, Rewrite => False);
end if;
end;
end if;
end;
if Debug then
Put_Line ("# compilation status " & Boolean'Image (Success));
end if;
if Success then
Send_Ok (Builder.Channel, Job.Id);
else
Send_Ko (Builder.Channel, Job.Id);
end if;
exception
when E : others =>
-- An exception can be raised if the builder master has been
-- terminated. In this case the comminication won't succeed.
if Debug then
Put_Line
("# cannot send response to build master "
& Exception_Information (E));
end if;
end;
else
-- This is not necessarily an error as we could get a Pid of a a
-- gprconfig run launched to generate a configuration file for a
-- specific language. So we do not want to fail in this case.
if Debug then
Put_Line ("# unknown job data for pid");
end if;
end if;
Mutex.Release;
end loop;
exception
when E : others =>
Put_Line ("Unrecoverable error: Wait_Completion.");
Put_Line (Exception_Information (E));
OS_Exit (1);
end Wait_Completion;
---------------------
-- Wait_For_Master --
---------------------
procedure Wait_For_Master is
use Types;
procedure Sync_Gpr (Builder : Build_Master);
--------------
-- Sync_Gpr --
--------------
procedure Sync_Gpr (Builder : Build_Master) is
use type Containers.Count_Type;
procedure Set_Stamp
(Path_Name : String; Time_Stamp : Time_Stamp_Type)
with Inline;
-- Set modification time stamp to the given file
package Files is new Containers.Indefinite_Ordered_Sets (String);
procedure Delete_Files (Except : Files.Set);
-- Delete all files in the current working tree except those in
-- Except set.
---------------
-- Set_Stamp --
---------------
procedure Set_Stamp
(Path_Name : String; Time_Stamp : Time_Stamp_Type)
is
TS : constant String := String (Time_Stamp);
begin
Set_File_Last_Modify_Time_Stamp
(Path_Name,
GM_Time_Of
(Year => Year_Type'Value (TS (1 .. 4)),
Month => Month_Type'Value (TS (5 .. 6)),
Day => Day_Type'Value (TS (7 .. 8)),
Hour => Hour_Type'Value (TS (9 .. 10)),
Minute => Minute_Type'Value (TS (11 .. 12)),
Second => Second_Type'Value (TS (13 .. 14))));
end Set_Stamp;
------------------
-- Delete_Files --
------------------
procedure Delete_Files (Except : Files.Set) is
procedure Process (Path : String);
-- Search recursively the Path
procedure Process (Path : String) is
procedure Check (File : Directory_Entry_Type);
-- Remove this file if not part of Except set
-----------
-- Check --
-----------
procedure Check (File : Directory_Entry_Type) is
S_Name : constant String := Simple_Name (File);
Entry_Name : constant String :=
Path & Directory_Separator & S_Name;
begin
if Kind (File) = Directory then
if S_Name not in "." | ".."
and then not Is_Symbolic_Link (Entry_Name)
then
Process (Entry_Name);
end if;
else
declare
R_Name : constant String :=
(if Path = "."
then ""
else Path (Path'First + 2 .. Path'Last)
& Directory_Separator) & S_Name;
begin
if not Except.Contains (R_Name) then
if Debug then
Put_Line
("# detele excluded '" & R_Name & ''');
end if;
Delete_File (R_Name);
end if;
end;
end if;
end Check;
begin
Search
(Directory => Path,
Pattern => "*",
Filter => (Special_File => False, others => True),
Process => Check'Access);
end Process;
begin
Process (".");
end Delete_Files;
Total_File : Natural := 0;
Total_Transferred : Natural := 0;
In_Master : Files.Set;
begin
Set_Directory (To_String (Builder.Project_Name));
Check_Time_Stamps : loop
declare
To_Sync : File_Data_Set.Vector;
Cmd : Command;
K : Positive := 1;
begin
Cmd := Get_Command (Builder.Channel);
if Debug then
Put ("# command: " & Command_Kind'Image (Kind (Cmd)));
if Args (Cmd) /= null then
for K in Args (Cmd)'Range loop
Put (", " & Args (Cmd) (K).all);
end loop;
end if;
New_Line;
end if;
if Kind (Cmd) = TS then
-- Check all files in the argument of the command. This is a
-- list of couple (filename and time stamp).
Check_All_Files : loop
Total_File := Total_File + 1;
declare
Path_Name : constant String := Args (Cmd) (K).all;
TS : constant Time_Stamp_Type :=
Time_Stamp_Type
(Args (Cmd) (K + 1).all);
File_Stamp : Time_Stamp_Type;
Exists : Boolean;
begin
if Directories.Exists (Path_Name) then
File_Stamp :=
To_Time_Stamp (Modification_Time (Path_Name));
Exists := True;
else
Exists := False;
end if;
In_Master.Insert (Path_Name);
if not Exists or else File_Stamp < TS then
To_Sync.Append
(File_Data'
(To_Unbounded_String (Path_Name),
TS, File_Stamp));
end if;
end;
K := K + 2;
exit Check_All_Files when K > Args (Cmd)'Length;
end loop Check_All_Files;
-- If all files are up-to-data
if To_Sync.Length = 0 then
Send_Ok (Builder.Channel);
else
-- Some files are to be synchronized, send the list of
-- names back to the master.
Send_Ko (Builder.Channel, To_Sync);
-- We then receive the files contents in the same order
for W of To_Sync loop
declare
File : Stream_IO.File_Type;
begin
Create_Path
(Containing_Directory (To_String (W.Path_Name)));
Stream_IO.Create
(File, Stream_IO.Out_File,
To_String (W.Path_Name));
loop
declare
Data : constant Stream_Element_Array :=
Get_Raw_Data (Builder.Channel);
begin
exit when Data'Length = 0;
Stream_IO.Write (File, Data);
end;
end loop;
Stream_IO.Close (File);
-- Set file time stamp
Set_Stamp (To_String (W.Path_Name), W.Timestamp);
end;
end loop;
Total_Transferred :=
Total_Transferred + Natural (To_Sync.Length);
end if;
elsif Kind (Cmd) = ES then
-- Delete all files not part of the list sent by the master.
-- This is needed to remove files in previous build removed
-- since then on the master. Again we need to do that as we
-- can't let around unnedded specs or bodies.
Delete_Files (Except => In_Master);
exit Check_Time_Stamps;
end if;
end;
end loop Check_Time_Stamps;
if Verbose then
Put_Line ("Files total:" & Natural'Image (Total_File));
Put_Line (" transferred :" & Natural'Image (Total_Transferred));
end if;
end Sync_Gpr;
Builder : Build_Master;
Clock_Status : Boolean;
begin
-- Wait for a connection
Wait_Incoming_Master : loop
begin
Accept_Socket (Server, Builder.Socket, Address);
exit Wait_Incoming_Master;
exception
when E : Socket_Error =>
if Resolve_Exception (E) /= Interrupted_System_Call then
raise;
end if;
end;
end loop Wait_Incoming_Master;
Builder.Channel := Create (Builder.Socket);
-- Initial handshake
declare
Master_Timestamp : Time_Stamp_Type;
Version : Unbounded_String;
begin
Get_Context
(Builder.Channel, Builder.Target,
Builder.Project_Name, Builder.Build_Env, Builder.Sync,
Master_Timestamp, Version);
Clock_Status := Check_Diff (Master_Timestamp, UTC_Time);
if To_String (Version) /= Gnat_Static_Version_String then
if Verbose then
Put_Line
("Reject non compatible build for "
& To_String (Builder.Project_Name));
end if;
Send_Ko (Builder.Channel);
return;
end if;
exception
when E : others =>
if Verbose then
Put_Line (Exception_Information (E));
end if;
-- Do not try to go further
Send_Ko (Builder.Channel);
return;
end;
Get_Targets_Set
(Base, To_String (Builder.Target), Selected_Targets_Set);
if Verbose then
Put_Line ("Handling project : " & To_String (Builder.Project_Name));
Put_Line ("Compiling for : " & To_String (Builder.Target));
end if;
Mutex.Seize;
-- Move to root directory before creating a new project environment
Set_Directory (Root_Directory.all);
if not Exists (To_String (Builder.Build_Env)) then
if Debug then
Put_Line
("# create build environment directory '"
& To_String (Builder.Build_Env)
& "' in " & Current_Directory);
end if;
Create_Directory (To_String (Builder.Build_Env));
end if;
Set_Directory (To_String (Builder.Build_Env));
if not Exists (To_String (Builder.Project_Name)) then
if Debug then
Put_Line
("# create project directory '"
& To_String (Builder.Project_Name)
& "' in " & Current_Directory);
end if;
Create_Directory (To_String (Builder.Project_Name));
end if;
-- Configure slave, note that this does not need to be into the critical
-- section has the builder is not yet known in the system. At this point
-- no compilation can be received for this slave anyway.
Set_Rewrite_WD
(Builder.Channel, Path => Work_Directory (Builder));
-- For Ada compilers, rewrite the root directory
if Debug then
if Compiler_Path = null then
Put_Line ("# compiler path is null.");
else
Put_Line
("# compiler path is : "
& Containing_Directory
(Containing_Directory (Compiler_Path.all)));
end if;
end if;
if Compiler_Path /= null then
Set_Rewrite_CD
(Builder.Channel,
Path => Containing_Directory
(Containing_Directory (Compiler_Path.all)));
end if;
Send_Slave_Config
(Builder.Channel, Max_Processes,
Compose (Root_Directory.all, To_String (Builder.Build_Env)),
Clock_Status);
-- If we are using the Gpr synchronisation, it is time to do it here.
-- Note that we want to avoid the rewriting rules below that are
-- requiring some CPU cycles not needed at this stage.
if Builder.Sync = Protocol.Gpr then
-- Move to projet directory
Sync_Gpr (Builder);
end if;
Mutex.Release;
-- Register the new builder
Builders.Insert (Builder);
exception
when E : others =>
Put_Line ("Unrecoverable error: Wait_For_Master.");
Put_Line (Exception_Information (E));
OS_Exit (1);
end Wait_For_Master;
--------------------
-- Work_Directory --
--------------------
function Work_Directory (Builder : Build_Master) return String is
begin
return Compose
(Compose (Root_Directory.all, To_String (Builder.Build_Env)),
To_String (Builder.Project_Name));
end Work_Directory;
begin
Parse_Command_Line;
-- Initialize the project support
Namet.Initialize;
Csets.Initialize;
Snames.Initialize;
Parse_Knowledge_Base (Base, Default_Knowledge_Base_Directory);
-- Wait for a gprbuild connection on any addresses
Address.Addr := Any_Inet_Addr;
Address.Port := Port_Type (Port);
Create_Socket (Server);
Set_Socket_Option (Server, Socket_Level, (Reuse_Address, True));
Bind_Socket (Server, Address);
if Port = 0 then
Address := Get_Socket_Name (Server);
end if;
-- If verbose
if Verbose then
Put_Line
("gprslave on " & Host_Name
& ":" & Image (Long_Integer (Address.Port)));
Put_Line (" max processes :" & Integer'Image (Max_Processes));
Flush;
end if;
-- Initialize the host key used to create unique pid
Slave_Id := Get_Slave_Id;
if Debug then
Put_Line ("# slave id " & Image (Slave_Id));
end if;
Listen_Socket (Server);
Main_Loop : loop
Wait_For_Master;
end loop Main_Loop;
exception
when E : others =>
Put_Line ("Unrecoverable error: GprSlave.");
Put_Line (Exception_Information (E));
OS_Exit (1);
end Gprslave;
gprbuild-gpl-2014-src/src/gprbuild-main.adb 0000644 0000767 0000145 00000205305 12323721731 020131 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . M A I N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2011-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Directories;
with Ada.Exceptions; use Ada.Exceptions;
with System;
with System.Case_Util; use System.Case_Util;
with System.Multiprocessors; use System.Multiprocessors;
with GNAT.Command_Line; use GNAT.Command_Line;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Atree; use Atree;
with Csets;
with Debug; use Debug;
with Gpr_Util; use Gpr_Util;
with GPR_Version; use GPR_Version;
with Hostparm;
with Makeutl; use Makeutl;
with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
with Prj.Conf; use Prj.Conf;
with Prj.Env;
with Prj.Err;
with Prj.Tree; use Prj.Tree;
with Snames; use Snames;
with Stringt;
with Switch; use Switch;
with Tempdir; use Tempdir;
with Gprbuild.Compile;
with Gprbuild.Link;
with Gprbuild.Post_Compile;
with Gprbuild.Compilation.Slave;
procedure Gprbuild.Main is
use Gpr_Util.Knowledge;
There_Are_Restricted_Languages : Boolean := False;
procedure Initialize;
-- Do the necessary package intialization and process the command line
-- arguments.
procedure Usage;
-- Display the usage
function Add_Global_Switches
(Switch : String;
For_Lang : Name_Id;
For_Builder : Boolean;
Has_Global_Compilation_Switches : Boolean) return Boolean;
-- Take into account a global switch (builder or global compilation switch)
-- read from the project file.
procedure Add_Mains_To_Queue;
-- Check that each main is a single file name and that it is a source
-- of a project from the tree.
procedure Scan_Arg
(Arg : String;
Command_Line : Boolean;
Language : Name_Id;
Success : out Boolean);
-- Process one gprbuild argument Arg. Command_Line is True if the argument
-- is specified on the command line. Optional parameter Additional gives
-- additional information about the origin of the argument if it is found
-- illegal.
procedure Add_Option (Arg : String; Command_Line : Boolean);
-- Add a switch for a compiler or all compilers, or for the binder or for
-- the linker. The table where this option is stored depends on the value
-- of Current_Processor and other global variables.
procedure Copyright;
-- Output the Copyright notice
type Sigint_Handler is access procedure;
pragma Convention (C, Sigint_Handler);
procedure Install_Int_Handler (Handler : Sigint_Handler);
pragma Import (C, Install_Int_Handler, "__gnat_install_int_handler");
-- Called by Gnatmake to install the SIGINT handler below
procedure Sigint_Intercepted;
pragma Convention (C, Sigint_Intercepted);
-- Called when the program is interrupted by Ctrl-C to delete the
-- temporary mapping files and configuration pragmas files.
No_Object_Check_Switch : constant String := "--no-object-check";
Direct_Import_Only_Switch : constant String := "--direct-import-only";
Indirect_Imports_Switch : constant String := "--indirect-imports";
No_Indirect_Imports_Switch : constant String := "--no-indirect-imports";
Current_Working_Dir : constant String := Get_Current_Dir;
-- The current working directory
type Processor is (None, Linker, Binder, Compiler);
Current_Processor : Processor := None;
-- This variable changes when switches -*args are used
Current_Builder_Comp_Option_Table : Builder_Comp_Option_Table_Ref :=
No_Builder_Comp_Option_Table;
-------------------------------------------
-- Options specified on the command line --
-------------------------------------------
package Options is
type Option_Type is
(Force_Compilations_Option,
Keep_Going_Option,
Maximum_Processes_Option,
Quiet_Output_Option,
Check_Switches_Option,
Verbose_Mode_Option,
Verbose_Low_Mode_Option,
Verbose_Medium_Mode_Option,
Warnings_Treat_As_Error,
Warnings_Normal,
Warnings_Suppress,
Indirect_Imports);
procedure Register_Command_Line_Option
(Option : Option_Type; Value : Natural := 0);
-- Record a command line option
procedure Process_Command_Line_Options;
-- Reprocess the recorded command line options that have priority over
-- the options in package Builder of the main project.
end Options;
use Options;
------------------------
-- Add_Mains_To_Queue --
------------------------
procedure Add_Mains_To_Queue is
Main_Id : Main_Info;
begin
Mains.Reset;
loop
Main_Id := Mains.Next_Main;
exit when Main_Id = No_Main_Info;
if Main_Id.Source /= No_Source then
-- Fail if any main is declared as an excluded source file
if Main_Id.Source.Locally_Removed then
Fail_Program
(Project_Tree,
"main """ &
Get_Name_String (Main_Id.Source.File) &
""" cannot also be an excluded file");
end if;
if Is_Allowed_Language (Main_Id.Source.Language.Name) then
Queue.Insert
(Source => (Format => Format_Gprbuild,
Tree => Main_Id.Tree,
Id => Main_Id.Source),
With_Roots => Builder_Data (Main_Id.Tree).Closure_Needed);
-- If a non Ada main has no roots, then all sources need to be
-- compiled, so no need to check for closure.
if Main_Id.Source.Language.Config.Kind /= Unit_Based
and then Main_Id.Source.Roots = null
then
Builder_Data (Main_Id.Tree).Closure_Needed := False;
end if;
end if;
end if;
end loop;
if Total_Errors_Detected /= 0 then
Fail_Program (Project_Tree, "cannot continue");
end if;
Queue.Insert_Project_Sources
(Project => Main_Project,
Project_Tree => Project_Tree,
Unique_Compile => Unique_Compile,
All_Projects =>
not Unique_Compile
or else (Unique_Compile_All_Projects or Recursive));
end Add_Mains_To_Queue;
-------------------------
-- Add_Global_Switches --
-------------------------
function Add_Global_Switches
(Switch : String;
For_Lang : Name_Id;
For_Builder : Boolean;
Has_Global_Compilation_Switches : Boolean) return Boolean
is
Success : Boolean;
begin
if For_Builder then
if Has_Global_Compilation_Switches then
Builder_Switches_Lang := No_Name;
else
Builder_Switches_Lang := For_Lang;
end if;
Scan_Arg
(Switch,
Command_Line => False,
Language => For_Lang,
Success => Success);
return Success;
else
Current_Processor := Compiler;
Current_Builder_Comp_Option_Table :=
Builder_Compiling_Options_HTable.Get (For_Lang);
if Current_Builder_Comp_Option_Table =
No_Builder_Comp_Option_Table
then
Current_Builder_Comp_Option_Table :=
new Builder_Compiling_Options.Instance;
Builder_Compiling_Options_HTable.Set
(For_Lang, Current_Builder_Comp_Option_Table);
Builder_Compiling_Options.Init
(Current_Builder_Comp_Option_Table.all);
end if;
Add_Option (Switch, Command_Line => False);
Current_Processor := None;
return True;
end if;
end Add_Global_Switches;
----------------
-- Add_Option --
----------------
procedure Add_Option (Arg : String; Command_Line : Boolean) is
Option : String_Access := new String'(Arg);
begin
case Current_Processor is
when None =>
null;
when Linker =>
-- Add option to the linker table
if Command_Line then
Test_If_Relative_Path
(Switch => Option,
Parent => Current_Working_Dir,
Including_Switch => Dash_L);
else
Test_If_Relative_Path
(Switch => Option,
Parent => Main_Project_Dir.all,
Including_Switch => Dash_L);
end if;
Command_Line_Linker_Options.Append (Option);
when Binder =>
if Command_Line then
Test_If_Relative_Path
(Switch => Option,
Parent => Current_Working_Dir,
Including_Switch => No_Name);
else
Test_If_Relative_Path
(Switch => Option,
Parent => Main_Project_Dir.all,
Including_Switch => No_Name);
end if;
if Current_Bind_Option_Table = No_Bind_Option_Table then
-- Option for all binder
All_Language_Binder_Options.Append (Option);
else
-- Option for a single binder
Binder_Options.Append
(Current_Bind_Option_Table.all, Option);
end if;
when Compiler =>
if Command_Line then
if Current_Comp_Option_Table = No_Comp_Option_Table then
-- Option for all compilers
All_Language_Compiling_Options.Append (Option);
else
-- Option for a single compiler
Compiling_Options.Append
(Current_Comp_Option_Table.all, Option);
end if;
else
if Current_Builder_Comp_Option_Table =
No_Builder_Comp_Option_Table
then
-- Option for all compilers
All_Language_Builder_Compiling_Options.Append (Option);
else
-- Option for a single compiler
Builder_Compiling_Options.Append
(Current_Builder_Comp_Option_Table.all, Option);
end if;
end if;
end case;
end Add_Option;
---------------
-- Copyright --
---------------
procedure Copyright is
begin
-- Only output the Copyright notice once
if not Copyright_Output then
Copyright_Output := True;
Display_Version
("GPRBUILD", "2004", Version_String => Gpr_Version_String);
end if;
end Copyright;
-------------
-- Options --
-------------
package body Options is
type Option_Data is record
Option : Option_Type;
Value : Natural := 0;
end record;
package Command_Line_Options is new Table.Table
(Table_Component_Type => Option_Data,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Makegpr.Opt.Command_Line_Options");
-- Table to store the command line options
----------------------------------
-- Process_Command_Line_Options --
----------------------------------
procedure Process_Command_Line_Options is
begin
for Index in 1 .. Command_Line_Options.Last loop
case Command_Line_Options.Table (Index).Option is
when Force_Compilations_Option =>
Opt.Force_Compilations := True;
when Keep_Going_Option =>
Opt.Keep_Going := True;
when Maximum_Processes_Option =>
Opt.Maximum_Processes :=
Command_Line_Options.Table (Index).Value;
when Quiet_Output_Option =>
Opt.Quiet_Output := True;
Opt.Verbose_Mode := False;
when Check_Switches_Option =>
Opt.Check_Switches := True;
when Verbose_Mode_Option =>
Opt.Verbose_Mode := True;
Opt.Verbosity_Level := Opt.High;
Opt.Quiet_Output := False;
when Verbose_Low_Mode_Option =>
Opt.Verbose_Mode := True;
Opt.Verbosity_Level := Opt.Low;
Opt.Quiet_Output := False;
when Verbose_Medium_Mode_Option =>
Opt.Verbose_Mode := True;
Opt.Verbosity_Level := Opt.Medium;
Opt.Quiet_Output := False;
when Warnings_Treat_As_Error =>
Opt.Warning_Mode := Opt.Treat_As_Error;
when Warnings_Normal =>
Opt.Warning_Mode := Opt.Normal;
when Warnings_Suppress =>
Opt.Warning_Mode := Opt.Suppress;
when Indirect_Imports =>
Gprbuild.Indirect_Imports :=
Command_Line_Options.Table (Index).Value /= 0;
end case;
end loop;
end Process_Command_Line_Options;
----------------------------------
-- Register_Command_Line_Option --
----------------------------------
procedure Register_Command_Line_Option
(Option : Option_Type; Value : Natural := 0)
is
begin
Command_Line_Options.Increment_Last;
Command_Line_Options.Table (Command_Line_Options.Last) :=
(Option => Option, Value => Value);
end Register_Command_Line_Option;
end Options;
--------------
-- Scan_Arg --
--------------
procedure Scan_Arg
(Arg : String;
Command_Line : Boolean;
Language : Name_Id;
Success : out Boolean)
is
Processed : Boolean := True;
procedure Forbidden_In_Package_Builder;
-- Fail if switch Arg is found in package Builder
----------------------------------
-- Forbidden_In_Package_Builder --
----------------------------------
procedure Forbidden_In_Package_Builder is
begin
if not Command_Line then
Fail_Program
(Project_Tree,
Arg & " can only be used on the command line");
end if;
end Forbidden_In_Package_Builder;
begin
pragma Assert (Arg'First = 1);
Success := True;
if Arg'Length = 0 then
return;
end if;
-- 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
Fail_Program
(Project_Tree, "project file name missing after -P");
else
Project_File_Name_Expected := False;
Project_File_Name := new String'(Arg);
end if;
-- 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
Fail_Program
(Project_Tree, "output file name missing after -o");
else
Output_File_Name_Expected := False;
Output_File_Name := new String'(Arg);
end if;
elsif Search_Project_Dir_Expected then
if Arg (1) = '-' then
Fail_Program
(Project_Tree, "directory name missing after -aP");
else
Search_Project_Dir_Expected := False;
Prj.Env.Add_Directories (Root_Environment.Project_Path, Arg);
end if;
elsif Db_Directory_Expected then
Db_Directory_Expected := False;
Parse_Knowledge_Base (Project_Tree, Arg);
Name_Len := 0;
Add_Str_To_Name_Buffer (Arg);
Db_Switch_Args.Append (Name_Find);
-- Set the processor/language for the following switches
-- -cargs all compiler arguments
elsif Arg = "-cargs" then
Current_Processor := Compiler;
if Command_Line then
Current_Comp_Option_Table := No_Comp_Option_Table;
else
Current_Builder_Comp_Option_Table := No_Builder_Comp_Option_Table;
end if;
-- -cargs:lang arguments for compiler of language lang
elsif Arg'Length > 7 and then Arg (1 .. 7) = "-cargs:" then
Current_Processor := Compiler;
Name_Len := 0;
Add_Str_To_Name_Buffer (Arg (8 .. Arg'Last));
To_Lower (Name_Buffer (1 .. Name_Len));
declare
Lang : constant Name_Id := Name_Find;
begin
if Command_Line then
Current_Comp_Option_Table :=
Compiling_Options_HTable.Get (Lang);
if Current_Comp_Option_Table = No_Comp_Option_Table then
Current_Comp_Option_Table := new Compiling_Options.Instance;
Compiling_Options_HTable.Set
(Lang, Current_Comp_Option_Table);
Compiling_Options.Init (Current_Comp_Option_Table.all);
end if;
else
Current_Builder_Comp_Option_Table :=
Builder_Compiling_Options_HTable.Get (Lang);
if Current_Builder_Comp_Option_Table =
No_Builder_Comp_Option_Table
then
Current_Builder_Comp_Option_Table :=
new Builder_Compiling_Options.Instance;
Builder_Compiling_Options_HTable.Set
(Lang, Current_Builder_Comp_Option_Table);
Builder_Compiling_Options.Init
(Current_Builder_Comp_Option_Table.all);
end if;
end if;
end;
-- -bargs all binder arguments
elsif Arg = "-bargs" then
Current_Processor := Binder;
Current_Bind_Option_Table := No_Bind_Option_Table;
-- -bargs:lang arguments for binder of language lang
elsif Arg'Length > 7 and then Arg (1 .. 7) = "-bargs:" then
Current_Processor := Binder;
Name_Len := 0;
Add_Str_To_Name_Buffer (Arg (8 .. Arg'Last));
To_Lower (Name_Buffer (1 .. Name_Len));
declare
Lang : constant Name_Id := Name_Find;
begin
Current_Bind_Option_Table :=
Binder_Options_HTable.Get (Lang);
if Current_Bind_Option_Table = No_Bind_Option_Table then
Current_Bind_Option_Table := new Binder_Options.Instance;
Binder_Options_HTable.Set
(Lang, Current_Bind_Option_Table);
Binder_Options.Init (Current_Bind_Option_Table.all);
end if;
end;
-- -largs linker arguments
elsif Arg = "-largs" then
Current_Processor := Linker;
-- -gargs/margs options directly for gprbuild
-- support -margs for compatibility with gnatmake
elsif Arg = "-gargs"
or else Arg = "-margs"
then
Current_Processor := None;
-- A special test is needed for the -o switch within a -largs since
-- that is another way to specify the name of the final executable.
elsif Command_Line
and then Current_Processor = Linker
and then Arg = "-o"
then
Fail_Program
(Project_Tree,
"switch -o not allowed within a -largs. Use -o directly.");
-- If current processor is not gprbuild directly, store the option
-- in the appropriate table.
elsif Current_Processor /= None then
Add_Option (Arg, Command_Line);
-- Switches start with '-'
elsif Arg (1) = '-' then
if Arg'Length > Distributed_Option'Length
and then
Arg (1 .. Distributed_Option'Length) = Distributed_Option
then
Distributed_Mode := True;
-- In distributed mode we do not want to use temp directories
Use_Temp_Dir (Status => False);
Compilation.Slave.Record_Slaves
(Arg (Distributed_Option'Length + 1 .. Arg'Last));
elsif Arg'Length >= Slave_Env_Option'Length
and then
Arg (1 .. Slave_Env_Option'Length) = Slave_Env_Option
then
if Arg = Slave_Env_Option then
-- Just --slave-env, it is up to gprbuild to build a sensible
-- slave environment value.
Slave_Env_Auto := True;
else
Slave_Env :=
new String'(Arg (Slave_Env_Option'Length + 2 .. Arg'Last));
end if;
elsif Arg = "--db-" then
if Hostparm.OpenVMS then
Fail_Program
(Project_Tree,
"--db- cannot be used on VMS");
end if;
Forbidden_In_Package_Builder;
Load_Standard_Base := False;
elsif Arg = "--db" then
if Hostparm.OpenVMS then
Fail_Program
(Project_Tree,
"--db cannot be used on VMS");
end if;
Forbidden_In_Package_Builder;
Db_Directory_Expected := True;
elsif Arg = "--display-paths" then
Forbidden_In_Package_Builder;
Display_Paths := True;
elsif Arg = "--no-split-units" then
Opt.No_Split_Units := True;
elsif Arg = Single_Compile_Per_Obj_Dir_Switch then
Opt.One_Compilation_Per_Obj_Dir := True;
elsif Arg'Length > Source_Info_Option'Length
and then Arg (1 .. Source_Info_Option'Length) = Source_Info_Option
then
Forbidden_In_Package_Builder;
Project_Tree.Source_Info_File_Name :=
new String'(Arg (Source_Info_Option'Length + 1 .. Arg'Last));
elsif Arg'Length > Config_Project_Option'Length
and then
Arg (1 .. Config_Project_Option'Length) = Config_Project_Option
then
if Config_Project_File_Name /= null
and then (Autoconf_Specified
or else Config_Project_File_Name.all /=
Arg (Config_Project_Option'Length + 1 .. Arg'Last))
then
Fail_Program
(Project_Tree,
"several different configuration switches " &
"cannot be specified");
else
Autoconfiguration := False;
Autoconf_Specified := False;
Config_Project_File_Name :=
new String'
(Arg (Config_Project_Option'Length + 1 .. Arg'Last));
end if;
elsif Arg'Length > Autoconf_Project_Option'Length
and then
Arg (1 .. Autoconf_Project_Option'Length) =
Autoconf_Project_Option
then
if Hostparm.OpenVMS then
Fail_Program
(Project_Tree,
Autoconf_Project_Option & " cannot be used on VMS");
end if;
Forbidden_In_Package_Builder;
if Config_Project_File_Name /= null
and then (not Autoconf_Specified
or else Config_Project_File_Name.all /=
Arg (Autoconf_Project_Option'Length + 1 .. Arg'Last))
then
Fail_Program
(Project_Tree,
"several different configuration switches " &
"cannot be specified");
else
Config_Project_File_Name :=
new String'
(Arg (Autoconf_Project_Option'Length + 1 .. Arg'Last));
Autoconf_Specified := True;
end if;
elsif Arg'Length > Target_Project_Option'Length
and then
Arg (1 .. Target_Project_Option'Length) = Target_Project_Option
then
if Hostparm.OpenVMS then
Fail_Program
(Project_Tree,
Target_Project_Option & " cannot be used on VMS");
end if;
Forbidden_In_Package_Builder;
if Target_Name /= null then
if Target_Name.all /=
Arg (Target_Project_Option'Length + 1 .. Arg'Last)
then
Fail_Program
(Project_Tree,
"several different target switches cannot be specified");
end if;
else
Target_Name :=
new String'
(Arg (Target_Project_Option'Length + 1 .. Arg'Last));
end if;
elsif Arg'Length > RTS_Option'Length
and then Arg (1 .. RTS_Option'Length) = RTS_Option
then
declare
Set : constant Boolean := Runtime_Name_Set_For (Name_Ada);
Old : constant String := Runtime_Name_For (Name_Ada);
RTS : constant String :=
Arg (RTS_Option'Length + 1 .. Arg'Last);
begin
if Command_Line then
if Set and then Old /= RTS then
Fail_Program
(Project_Tree,
"several different run-times cannot be specified");
end if;
Set_Runtime_For (Name_Ada, RTS);
end if;
-- Ignore any --RTS= switch in package Builder. These are only
-- taken into account to create the config file in
-- auto-configuration.
end;
elsif Arg'Length > RTS_Language_Option'Length
and then Arg (1 .. RTS_Language_Option'Length) = RTS_Language_Option
then
declare
Language_Name : Name_Id := No_Name;
RTS_Start : Natural := Arg'Last + 1;
begin
for J in RTS_Language_Option'Length + 2 .. Arg'Last loop
if Arg (J) = '=' then
Name_Len := 0;
Add_Str_To_Name_Buffer
(Arg (RTS_Language_Option'Length + 1 .. J - 1));
To_Lower (Name_Buffer (1 .. Name_Len));
Language_Name := Name_Find;
RTS_Start := J + 1;
exit;
end if;
end loop;
if Language_Name = No_Name then
Fail_Program (Project_Tree, "illegal switch: " & Arg);
elsif Command_Line then
-- Ignore any --RTS:= switch in package Builder. These
-- are only taken into account to create the config file in
-- auto-configuration.
declare
RTS : constant String := Arg (RTS_Start .. Arg'Last);
Set : constant Boolean :=
Runtime_Name_Set_For (Language_Name);
Old : constant String := Runtime_Name_For (Language_Name);
begin
if Set and then Old /= RTS then
Fail_Program
(Project_Tree,
"several different run-times cannot be specified" &
" for the same language");
else
Set_Runtime_For (Language_Name, RTS);
end if;
end;
end if;
end;
elsif Arg'Length > Subdirs_Option'Length
and then Arg (1 .. Subdirs_Option'Length) = Subdirs_Option
then
Forbidden_In_Package_Builder;
Subdirs :=
new String'(Arg (Subdirs_Option'Length + 1 .. Arg'Last));
elsif Command_Line
and then Arg'Length > Restricted_To_Languages_Option'Length
and then Arg (1 .. Restricted_To_Languages_Option'Length) =
Restricted_To_Languages_Option
then
declare
Start : Positive := Restricted_To_Languages_Option'Length + 1;
Finish : Positive;
begin
Processed := False;
while Start <= Arg'Last loop
Finish := Start;
loop
exit when Finish > Arg'Last or else Arg (Finish) = ',';
Finish := Finish + 1;
end loop;
if Finish > Start then
Add_Restricted_Language (Arg (Start .. Finish - 1));
Processed := True;
There_Are_Restricted_Languages := True;
end if;
Start := Finish + 1;
end loop;
end;
elsif Arg = Indirect_Imports_Switch then
Indirect_Imports := True;
if Command_Line then
Register_Command_Line_Option (Options.Indirect_Imports, 1);
end if;
elsif Arg = No_Indirect_Imports_Switch
or else
Arg = Direct_Import_Only_Switch
then
Indirect_Imports := False;
if Command_Line then
Register_Command_Line_Option (Options.Indirect_Imports, 0);
end if;
elsif Arg = Makeutl.Unchecked_Shared_Lib_Imports then
Forbidden_In_Package_Builder;
Opt.Unchecked_Shared_Lib_Imports := True;
elsif Arg = No_Object_Check_Switch then
Object_Checked := False;
elsif Arg = "--codepeer" then
Forbidden_In_Package_Builder;
if not CodePeer_Mode then
CodePeer_Mode := True;
Object_Checked := False;
Target_Name := new String'("codepeer");
if Subdirs = null then
Subdirs := new String'("codepeer");
end if;
end if;
elsif Arg = Create_Map_File_Switch then
Map_File := new String'("");
elsif Arg'Length > Create_Map_File_Switch'Length + 1
and then
Arg (1 .. Create_Map_File_Switch'Length) = Create_Map_File_Switch
and then
Arg (Create_Map_File_Switch'Length + 1) = '='
then
Map_File :=
new String'(Arg (Create_Map_File_Switch'Length + 2 .. Arg'Last));
elsif Arg'Length >= 3 and then Arg (1 .. 3) = "-aP" then
Forbidden_In_Package_Builder;
if Arg'Length = 3 then
Search_Project_Dir_Expected := True;
else
Prj.Env.Add_Directories
(Root_Environment.Project_Path, Arg (4 .. Arg'Last));
end if;
elsif Arg = "-b" then
Opt.Bind_Only := True;
elsif Arg = "-c" then
Opt.Compile_Only := True;
if Opt.Link_Only then
Opt.Bind_Only := True;
end if;
elsif Arg = "-C" then
-- This switch is only for upward compatibility
null;
elsif Arg = "-d" then
Opt.Display_Compilation_Progress := True;
elsif Arg'Length = 3 and then Arg (2) = 'd' then
if Arg (3) in '1' .. '9'
or else Arg (3) in 'a' .. 'z'
or else Arg (3) in 'A' .. 'Z'
then
Set_Debug_Flag (Arg (3));
else
Fail_Program
(Project_Tree, "illegal debug switch " & Arg);
end if;
elsif Arg'Length > 3 and then Arg (1 .. 3) = "-eI" then
Forbidden_In_Package_Builder;
begin
Main_Index := Int'Value (Arg (4 .. Arg'Last));
exception
when Constraint_Error =>
Fail_Program (Project_Tree, "invalid switch " & Arg);
end;
elsif Arg = "-eL" then
Forbidden_In_Package_Builder;
Opt.Follow_Links_For_Files := True;
Opt.Follow_Links_For_Dirs := True;
elsif Arg = "-eS" then
Forbidden_In_Package_Builder;
-- Accept switch for compatibility with gnatmake
Opt.Commands_To_Stdout := True;
elsif Arg = "-f" then
Opt.Force_Compilations := True;
if Command_Line then
Register_Command_Line_Option (Force_Compilations_Option);
end if;
elsif Arg = "-F" then
Forbidden_In_Package_Builder;
Opt.Full_Path_Name_For_Brief_Errors := True;
elsif Arg = "-h" then
Forbidden_In_Package_Builder;
Usage_Needed := True;
elsif Arg'Length > 2 and then Arg (2) = 'j' then
declare
Max_Proc : Natural := 0;
begin
for J in 3 .. Arg'Length loop
if Arg (J) in '0' .. '9' then
Max_Proc := (Max_Proc * 10) +
Character'Pos (Arg (J)) -
Character'Pos ('0');
else
Processed := False;
end if;
end loop;
if Processed then
if Max_Proc = 0 then
Max_Proc := Natural (Number_Of_CPUs);
end if;
if Max_Proc = 0 then
Max_Proc := 1;
end if;
Opt.Maximum_Processes := Max_Proc;
end if;
end;
if Processed and then Command_Line then
Register_Command_Line_Option
(Maximum_Processes_Option, Opt.Maximum_Processes);
end if;
elsif Arg = "-k" then
Opt.Keep_Going := True;
if Command_Line then
Register_Command_Line_Option (Keep_Going_Option);
end if;
elsif Arg = "-l" then
Opt.Link_Only := True;
if Opt.Compile_Only then
Opt.Bind_Only := True;
end if;
elsif Arg = "-m" then
Opt.Minimal_Recompilation := True;
elsif Arg = "-o" then
Forbidden_In_Package_Builder;
if Output_File_Name /= null then
Fail_Program
(Project_Tree, "cannot specify several -o switches");
else
Output_File_Name_Expected := True;
end if;
elsif Arg = "-p" or else Arg = "--create-missing-dirs" then
Forbidden_In_Package_Builder;
Opt.Setup_Projects := True;
elsif Arg'Length >= 2 and then Arg (2) = 'P' then
Forbidden_In_Package_Builder;
if Project_File_Name /= null then
Fail_Program
(Project_Tree,
"cannot have several project files specified");
elsif Arg'Length = 2 then
Project_File_Name_Expected := True;
else
Project_File_Name := new String'(Arg (3 .. Arg'Last));
end if;
elsif Arg = "-q" then
Opt.Quiet_Output := True;
Opt.Verbose_Mode := False;
if Command_Line then
Register_Command_Line_Option (Quiet_Output_Option);
end if;
elsif Arg = "-r" then
Forbidden_In_Package_Builder;
Recursive := True;
elsif Arg = "-R" then
Opt.Run_Path_Option := False;
elsif Arg = "-s" then
Opt.Check_Switches := True;
if Command_Line then
Register_Command_Line_Option (Check_Switches_Option);
end if;
elsif Arg = "-u" then
Forbidden_In_Package_Builder;
Unique_Compile := True;
elsif Arg = "-U" then
Forbidden_In_Package_Builder;
Unique_Compile_All_Projects := True;
Unique_Compile := True;
elsif Arg = "-v" or else Arg = "-vh" then
Opt.Verbose_Mode := True;
Opt.Verbosity_Level := Opt.High;
Opt.Quiet_Output := False;
if Command_Line then
Register_Command_Line_Option (Verbose_Mode_Option);
end if;
elsif Arg = "-vl" then
Opt.Verbose_Mode := True;
Opt.Verbosity_Level := Opt.Low;
Opt.Quiet_Output := False;
if Command_Line then
Register_Command_Line_Option (Verbose_Low_Mode_Option);
end if;
elsif Arg = "-vm" then
Opt.Verbose_Mode := True;
Opt.Verbosity_Level := Opt.Medium;
Opt.Quiet_Output := False;
if Command_Line then
Register_Command_Line_Option (Verbose_Medium_Mode_Option);
end if;
elsif Arg'Length >= 3 and then Arg (1 .. 3) = "-vP" then
Forbidden_In_Package_Builder;
if Arg'Length = 4 and then Arg (4) in '0' .. '2' then
case Arg (4) is
when '0' =>
Current_Verbosity := Prj.Default;
when '1' =>
Current_Verbosity := Prj.Medium;
when '2' =>
Current_Verbosity := Prj.High;
when others =>
null;
end case;
else
Fail_Program
(Project_Tree,
"invalid verbosity level " & Arg (4 .. Arg'Last));
end if;
elsif Arg = "-we" then
Opt.Warning_Mode := Opt.Treat_As_Error;
if Command_Line then
Register_Command_Line_Option (Warnings_Treat_As_Error);
end if;
elsif Arg = "-wn" then
Opt.Warning_Mode := Opt.Normal;
if Command_Line then
Register_Command_Line_Option (Warnings_Normal);
end if;
elsif Arg = "-ws" then
Opt.Warning_Mode := Opt.Suppress;
if Command_Line then
Register_Command_Line_Option (Warnings_Suppress);
end if;
elsif Arg = "-x" then
Opt.Use_Include_Path_File := True;
elsif Arg'Length >= 3
and then Arg (2) = 'X'
and then Is_External_Assignment (Root_Environment, Arg)
then
Forbidden_In_Package_Builder;
-- Is_External_Assignment has side effects when it returns True
null;
elsif (Language = No_Name or else Language = Name_Ada)
and then (not Command_Line)
and then Arg = "-x"
then
-- For compatibility with gnatmake, ignore -x if found in the
-- Builder switches.
null;
elsif (Language = No_Name or else Language = Name_Ada)
and then
(Arg = "-fstack-check"
or else Arg = "-fno-inline"
or else
(Arg'Length >= 2
and then (Arg (2) = 'O' or else Arg (2) = 'g')))
then
-- For compatibility with gnatmake, use switch to compile Ada
-- code.
if Command_Line then
Current_Comp_Option_Table :=
Compiling_Options_HTable.Get (Name_Ada);
if Current_Comp_Option_Table = No_Comp_Option_Table then
Current_Comp_Option_Table := new Compiling_Options.Instance;
Compiling_Options_HTable.Set
(Name_Ada, Current_Comp_Option_Table);
Compiling_Options.Init (Current_Comp_Option_Table.all);
end if;
else
Current_Builder_Comp_Option_Table :=
Builder_Compiling_Options_HTable.Get (Name_Ada);
if Current_Builder_Comp_Option_Table =
No_Builder_Comp_Option_Table
then
Current_Builder_Comp_Option_Table :=
new Builder_Compiling_Options.Instance;
Builder_Compiling_Options_HTable.Set
(Name_Ada, Current_Builder_Comp_Option_Table);
Builder_Compiling_Options.Init
(Current_Builder_Comp_Option_Table.all);
end if;
end if;
Current_Processor := Compiler;
Add_Option (Arg, Command_Line);
Current_Processor := None;
elsif (Language = No_Name or else Language = Name_Ada)
and then
(Arg = "-nostdlib" or else Arg = "-nostdinc")
then
-- For compatibility with gnatmake, use switch to bind Ada code
-- code and for -nostdlib to link.
Current_Bind_Option_Table :=
Binder_Options_HTable.Get (Name_Ada);
if Current_Bind_Option_Table = No_Bind_Option_Table then
Current_Bind_Option_Table := new Binder_Options.Instance;
Binder_Options_HTable.Set
(Name_Ada, Current_Bind_Option_Table);
Binder_Options.Init (Current_Bind_Option_Table.all);
end if;
Current_Processor := Binder;
Add_Option (Arg, Command_Line);
-- For -nostdlib, use the switch to link too
if Arg = "-nostdlib" then
Current_Processor := Linker;
Add_Option (Arg, Command_Line);
end if;
Current_Processor := None;
else
Processed := False;
end if;
elsif Command_Line then
-- The file name of a main or a project file
declare
File_Name : String := Arg;
begin
Canonical_Case_File_Name (File_Name);
if File_Name'Length > Project_File_Extension'Length
and then File_Name
(File_Name'Last - Project_File_Extension'Length + 1
.. File_Name'Last) = Project_File_Extension
then
if Project_File_Name /= null then
Fail_Program
(Project_Tree,
"cannot have several project files specified");
else
Project_File_Name := new String'(File_Name);
end if;
else
-- Not a project file, then it is a main
Mains.Add_Main (Arg);
Always_Compile := True;
end if;
end;
else
Processed := False;
end if;
if not Processed then
if Command_Line then
Fail_Program
(Project_Tree,
"illegal option """ & Arg & """ on the command line");
else
-- If we have a switch and there is a Builder Switches language
-- set, pass this switch to the compiler of the language.
if Arg (1) = '-' and then Builder_Switches_Lang /= No_Name then
Current_Builder_Comp_Option_Table :=
Builder_Compiling_Options_HTable.Get (Builder_Switches_Lang);
if Current_Builder_Comp_Option_Table =
No_Builder_Comp_Option_Table
then
Current_Builder_Comp_Option_Table :=
new Builder_Compiling_Options.Instance;
Builder_Compiling_Options_HTable.Set
(Builder_Switches_Lang, Current_Builder_Comp_Option_Table);
Builder_Compiling_Options.Init
(Current_Builder_Comp_Option_Table.all);
end if;
Current_Processor := Compiler;
Add_Option (Arg, False);
Current_Processor := None;
else
Success := False;
end if;
end if;
end if;
end Scan_Arg;
------------------------
-- Sigint_Intercepted --
------------------------
procedure Sigint_Intercepted is
begin
Write_Line ("*** Interrupted ***");
Delete_All_Temp_Files (Project_Tree.Shared);
if Distributed_Mode then
Compilation.Slave.Unregister_Remote_Slaves;
end if;
OS_Exit (1);
end Sigint_Intercepted;
----------------
-- Initialize --
----------------
procedure Initialize is
procedure Check_Version_And_Help is new
Check_Version_And_Help_G (Usage);
begin
-- Do some necessary package initializations
Csets.Initialize;
Namet.Initialize;
Snames.Initialize;
Stringt.Initialize;
Prj.Tree.Initialize (Root_Environment, Gprbuild_Flags);
Prj.Tree.Initialize (Project_Node_Tree);
Prj.Initialize (Project_Tree);
Mains.Delete;
-- Get the name id for "-L";
Name_Len := 0;
Add_Str_To_Name_Buffer ("-L");
Dash_L := Name_Find;
-- Get the command line arguments, starting with --version and --help
Check_Version_And_Help
("GPRBUILD",
"2004",
Version_String => Gpr_Version_String);
-- Now process the other options
Autoconfiguration := True;
declare
Do_Not_Care : Boolean;
begin
Scan_Args : for Next_Arg in 1 .. Argument_Count loop
Scan_Arg
(Argument (Next_Arg),
Command_Line => True,
Language => No_Name,
Success => Do_Not_Care);
end loop Scan_Args;
end;
if CodePeer_Mode then
if There_Are_Restricted_Languages then
Remove_All_Restricted_Languages;
end if;
Add_Restricted_Language ("ada");
Opt.Link_Only := False;
if not Opt.Compile_Only and not Opt.Bind_Only then
Opt.Compile_Only := True;
Opt.Bind_Only := True;
end if;
elsif There_Are_Restricted_Languages then
Opt.Compile_Only := True;
Opt.Bind_Only := False;
Opt.Link_Only := False;
end if;
Mains.Set_Multi_Unit_Index (Project_Tree, Main_Index);
Current_Processor := None;
-- Target_Name has potentially been set when calling Scan_Arg, so we can
-- only initialize the project path after parsing the command line
-- arguments.
if Target_Name = null then
Prj.Env.Initialize_Default_Project_Path
(Root_Environment.Project_Path, Target_Name => "");
else
Prj.Env.Initialize_Default_Project_Path
(Root_Environment.Project_Path, Target_Name.all);
end if;
-- If --display-paths was specified, display the config and the user
-- project paths and exit.
if Display_Paths then
Write_Char ('.');
declare
Prefix_Path : constant String := Executable_Prefix_Path;
P : String_Access;
begin
if Prefix_Path'Length /= 0 then
Write_Char (Path_Separator);
Write_Str (Prefix_Path);
Write_Str ("share");
Write_Char (Directory_Separator);
Write_Str ("gpr");
end if;
Write_Eol;
Prj.Env.Get_Path (Root_Environment.Project_Path, Path => P);
Write_Line (P.all);
Exit_Program (E_Success);
end;
end if;
if Opt.Verbose_Mode then
Copyright;
end if;
if Usage_Needed then
Usage;
Usage_Needed := False;
end if;
-- Fail if command line ended with "-P"
if Project_File_Name_Expected then
Fail_Program
(Project_Tree, "project file name missing after -P");
-- Or if it ended with "-o"
elsif Output_File_Name_Expected then
Fail_Program
(Project_Tree, "output file name missing after -o");
-- Or if it ended with "-aP"
elsif Search_Project_Dir_Expected then
Fail_Program
(Project_Tree, "directory name missing after -aP");
elsif Db_Directory_Expected then
Fail_Program
(Project_Tree, "directory name missing after --db");
elsif Slave_Env /= null and then not Distributed_Mode then
Fail_Program
(Project_Tree, "cannot use --slave-env in non distributed mode");
end if;
-- Makes the Ada RTS is absolute if it is not a base name
if Runtime_Name_Set_For (Name_Ada) then
Locate_Runtime (Project_Tree, Name_Ada);
end if;
if Load_Standard_Base then
-- We need to parse the knowledge base so that we are able to
-- normalize the target names. Unfortunately, if we have to spawn
-- gprconfig, it will also have to parse that knowledge base on
-- its own.
Parse_Knowledge_Base (Project_Tree);
end if;
-- If no project file is specified, look for a default
if Project_File_Name = null then
Look_For_Default_Project;
else
No_Project_File_Found := False;
end if;
if Project_File_Name = null then
Try_Help;
Fail_Program
(Project_Tree,
"no project file specified and no default project file");
end if;
end Initialize;
-----------
-- Usage --
-----------
procedure Usage is
begin
if not Usage_Output then
Usage_Output := True;
Write_Str ("Usage: ");
Osint.Write_Program_Name;
Write_Str (" [-P] [.gpr] [opts] [name]");
Write_Eol;
Write_Str (" {[-cargs opts] [-cargs:lang opts] [-largs opts]" &
" [-gargs opts]}");
Write_Eol;
Write_Eol;
Write_Str (" name is zero or more file names");
Write_Eol;
Write_Eol;
-- GPRBUILD switches
Write_Str ("gprbuild switches:");
Write_Eol;
Display_Usage_Version_And_Help;
-- Line for --distributed
Write_Str (" --distributed=slave1[,slave2]");
Write_Eol;
Write_Str (" Activate the remote/distributed compilations");
Write_Eol;
-- Line for --slave-env
Write_Str (" --slave-env[=name]");
Write_Eol;
Write_Str (" Use a specific slave's environment");
Write_Eol;
-- Line for Config_Project_Option
Write_Str (" ");
Write_Str (Config_Project_Option);
Write_Str ("file.cgpr");
Write_Eol;
Write_Str (" Specify the main config project file name");
Write_Eol;
-- Line for Autoconf_Project_Option
if not Hostparm.OpenVMS then
Write_Str (" ");
Write_Str (Autoconf_Project_Option);
Write_Str ("file.cgpr");
Write_Eol;
Write_Str
(" Specify/create the main config project file name");
Write_Eol;
end if;
-- Line for Target_Project_Option
if not Hostparm.OpenVMS then
Write_Str (" ");
Write_Str (Target_Project_Option);
Write_Str ("targetname");
Write_Eol;
Write_Str
(" Specify a target for cross platforms");
Write_Eol;
end if;
-- Line for --db
if not Hostparm.OpenVMS then
Write_Str (" --db dir Parse dir as an additional knowledge base");
Write_Eol;
end if;
-- Line for --db-
if not Hostparm.OpenVMS then
Write_Str (" --db- Do not load the standard knowledge base");
Write_Eol;
end if;
-- Line for --subdirs=
Write_Str (" --subdirs=dir");
Write_Eol;
Write_Str (" Real obj/lib/exec dirs are subdirs");
Write_Eol;
-- Line for --single-compile-per-obj-dir
Write_Str (" ");
Write_Str (Single_Compile_Per_Obj_Dir_Switch);
Write_Eol;
Write_Str
(" No simultaneous compilations for the same obj dir");
Write_Eol;
Write_Str (" ");
Write_Str (No_Indirect_Imports_Switch);
Write_Eol;
Write_Str
(" Sources can import only from directly imported " &
"projects");
Write_Eol;
Write_Str (" ");
Write_Str (Indirect_Imports_Switch);
Write_Eol;
Write_Str
(" Sources can import from directly and indirectly " &
"imported projects");
Write_Eol;
Write_Str (" --RTS=");
Write_Eol;
Write_Str (" Use runtime for language Ada");
Write_Eol;
Write_Str (" --RTS:=");
Write_Eol;
Write_Str (" Use runtime for language ");
Write_Eol;
Write_Str (" ");
Write_Str (Makeutl.Unchecked_Shared_Lib_Imports);
Write_Eol;
Write_Str (" Shared lib projects may import any project");
Write_Eol;
Write_Str (" ");
Write_Str (No_Object_Check_Switch);
Write_Eol;
Write_Str (" Do not check object files");
Write_Eol;
Write_Str (" ");
Write_Str (Restricted_To_Languages_Option);
Write_Str ("");
Write_Eol;
Write_Str (" Restrict the languages of the sources");
Write_Eol;
Write_Eol;
Write_Str (" ");
Write_Str (Create_Map_File_Switch);
Write_Eol;
Write_Str (" Create map file mainprog.map");
Write_Eol;
Write_Str (" ");
Write_Str (Create_Map_File_Switch);
Write_Str ("=mapfile");
Write_Eol;
Write_Str (" Create map file mapfile");
Write_Eol;
Write_Eol;
-- Line for -aP
Write_Str (" -aP dir Add directory dir to project search path");
Write_Eol;
-- Line for -b
Write_Str (" -b Bind only");
Write_Eol;
-- Line for -c
Write_Str (" -c Compile only");
Write_Eol;
-- Line for -d
Write_Str (" -d Display compilation progress");
Write_Eol;
-- Line for -eInn
Write_Str (" -eInn Index of main unit in multi-unit source file");
Write_Eol;
-- Line for -eL
Write_Str (" -eL " &
"Follow symbolic links when processing project files");
Write_Eol;
-- Line for -eS
Write_Str (" -eS " &
"(no action, for compatibility with gnatmake only)");
Write_Eol;
-- Line for -f
Write_Str (" -f Force recompilations");
Write_Eol;
-- Line for -F
Write_Str
(" -F Full project path name in brief error messages");
Write_Eol;
-- Line for -jnnn
Write_Str (" -jnum Use num processes to compile");
Write_Eol;
-- Line for -k
Write_Str (" -k Keep going after compilation errors");
Write_Eol;
-- Line for -l
Write_Str (" -l Link only");
Write_Eol;
-- Line for -m
Write_Str (" -m Minimum Ada recompilation");
Write_Eol;
-- Line for -o
Write_Str (" -o name Choose an alternate executable name");
Write_Eol;
-- Line for -p
Write_Str (" -p Create missing obj, lib and exec dirs");
Write_Eol;
-- Line for -P
Write_Str (" -P proj Use Project File proj");
Write_Eol;
-- Line for -q
Write_Str (" -q Be quiet/terse");
Write_Eol;
-- Line for -r
Write_Str (" -r Recursive (default except when using -c)");
Write_Eol;
-- Line for -R
Write_Str (" -R Do not use run path option");
Write_Eol;
-- Line for -s
Write_Str (" -s Recompile if compiler switches have changed");
Write_Eol;
-- Line for -u
Write_Str
(" -u Unique compilation, only compile the given files");
Write_Eol;
-- Line for -U
Write_Str
(" -U Unique compilation for all sources of all projects");
Write_Eol;
-- Line for -v
Write_Str (" -v Verbose output");
Write_Eol;
-- Line for -vl
Write_Str (" -vl Verbose output (low verbosity)");
Write_Eol;
-- Line for -vm
Write_Str (" -vm Verbose output (medium verbosity)");
Write_Eol;
-- Line for -vh
Write_Str (" -vh Verbose output (high verbosity)");
Write_Eol;
-- Line for -vPx
Write_Str (" -vPx Specify verbosity when parsing Project Files" &
" (x = 0/1/2)");
Write_Eol;
-- Line for -we
Write_Str (" -we Treat all warnings as errors");
Write_Eol;
-- Line for -wn
Write_Str (" -wn Treat warnings as warnings");
Write_Eol;
-- Line for -ws
Write_Str (" -ws Suppress all warnings");
Write_Eol;
-- Line for -x
Write_Str (" -x Always create include path file");
Write_Eol;
-- Line for -X
Write_Str (" -Xnm=val Specify an external reference for " &
"Project Files");
Write_Eol;
Write_Eol;
-- Line for -cargs
Write_Line (" -cargs opts opts are passed to all compilers");
-- Line for -cargs:lang
Write_Line (" -cargs: opts");
Write_Line (" opts are passed to the compiler " &
"for language ");
-- Line for -bargs
Write_Line (" -bargs opts opts are passed to all binders");
-- Line for -cargs:lang
Write_Line (" -bargs: opts");
Write_Line (" opts are passed to the binder " &
"for language ");
-- Line for -largs
Write_Str (" -largs opts opts are passed to the linker");
Write_Eol;
-- Line for -gargs
Write_Str (" -gargs opts opts directly interpreted by gprbuild");
Write_Eol;
-- Line for -margs
Write_Str (" -margs opts equivalent to -gargs opts");
Write_Eol;
Write_Eol;
Write_Str
("For compatibility with gnatmake, these switches are passed " &
"to the Ada compiler:");
Write_Eol;
Write_Str (" -nostdlib");
Write_Eol;
Write_Str (" -nostdinc");
Write_Eol;
Write_Str (" -fstack-check");
Write_Eol;
Write_Str (" -fno-inline");
Write_Eol;
Write_Str (" -gxxx");
Write_Eol;
Write_Str (" -Oxx");
Write_Eol;
Write_Eol;
end if;
end Usage;
User_Project_Node : Project_Node_Id;
procedure Do_Compute_Builder_Switches is
new Compute_Builder_Switches (Add_Global_Switches);
begin
-- First initialize and read the command line arguments
Initialize;
-- And install Ctrl-C handler
Install_Int_Handler (Sigint_Intercepted'Unrestricted_Access);
-- Check command line arguments. These will be overridden when looking
-- for the configuration file
if Target_Name = null then
Target_Name := new String'("");
end if;
if Config_Project_File_Name = null then
Config_Project_File_Name := new String'("");
elsif Autoconf_Specified then
-- Check if path needs to be created
declare
Config_Path : constant String :=
Ada.Directories.Containing_Directory
(Config_Project_File_Name.all);
begin
if not Ada.Directories.Exists (Config_Path) then
Ada.Directories.Create_Path (Config_Path);
end if;
end;
end if;
-- Then, parse the user's project and the configuration file. Apply the
-- configuration file to the project so that its settings are
-- automatically inherited by the project.
-- If either the project or the configuration file contains errors, the
-- following call with call Osint.Fail and never return
begin
Parse_Project_And_Apply_Config
(Main_Project => Main_Project,
User_Project_Node => User_Project_Node,
Config_File_Name => Config_Project_File_Name.all,
Autoconf_Specified => Autoconf_Specified,
Project_File_Name => Project_File_Name.all,
Project_Tree => Project_Tree,
Env => Root_Environment,
Project_Node_Tree => Project_Node_Tree,
Packages_To_Check => Packages_To_Check,
Allow_Automatic_Generation => Autoconfiguration,
Automatically_Generated => Delete_Autoconf_File,
Config_File_Path => Configuration_Project_Path,
Target_Name => Target_Name.all,
Normalized_Hostname => Normalized_Hostname,
Implicit_Project => No_Project_File_Found);
exception
when E : Prj.Conf.Invalid_Config =>
Osint.Fail (Exception_Message (E));
end;
if Main_Project = No_Project then
-- Don't flush messages in case of parsing error. This has already
-- been taken care when parsing the tree. Otherwise, it results in
-- the same message being displayed twice.
Fail_Program
(Project_Tree,
"""" & Project_File_Name.all & """ processing failed",
Flush_Messages => User_Project_Node /= Empty_Node);
end if;
if Configuration_Project_Path /= null then
Free (Config_Project_File_Name);
Config_Project_File_Name := new String'
(Base_Name (Configuration_Project_Path.all));
end if;
if Total_Errors_Detected > 0 then
Prj.Err.Finalize;
Fail_Program
(Project_Tree,
"problems while getting the configuration",
Flush_Messages => False);
end if;
Main_Project_Dir :=
new String'(Get_Name_String (Main_Project.Directory.Display_Name));
if Warnings_Detected > 0 then
Prj.Err.Finalize;
Prj.Err.Initialize;
end if;
Compute_All_Imported_Projects (Main_Project, Project_Tree);
if Mains.Number_Of_Mains (Project_Tree) = 0
and then not Unique_Compile
then
-- Register the Main units from the projects.
-- No need to waste time when we are going to compile all files
-- anyway (Unique_Compile).
Mains.Fill_From_Project (Main_Project, Project_Tree);
end if;
Mains.Complete_Mains
(Root_Environment.Flags, Main_Project, Project_Tree);
if not Unique_Compile
and then Output_File_Name /= null
and then Mains.Number_Of_Mains (null) > 1
then
Fail_Program
(Project_Tree, "cannot specify -o when there are several mains");
end if;
Do_Compute_Builder_Switches
(Project_Tree => Project_Tree,
Env => Root_Environment,
Main_Project => Main_Project);
Queue.Initialize (Opt.One_Compilation_Per_Obj_Dir);
Compute_Compilation_Phases
(Project_Tree,
Main_Project,
Option_Unique_Compile => Unique_Compile,
Option_Compile_Only => Opt.Compile_Only,
Option_Bind_Only => Opt.Bind_Only,
Option_Link_Only => Opt.Link_Only);
if Mains.Number_Of_Mains (Project_Tree) > 0
and then Main_Project.Library
and then Builder_Data (Project_Tree).Need_Binding
then
Fail_Program
(Project_Tree,
"cannot specify a main program " &
"on the command line for a library project file");
end if;
Add_Mains_To_Queue;
-- If no sources to compile, then there is nothing to do
if Queue.Size = 0 then
if not Opt.Quiet_Output
and then not Main_Project.Externally_Built
then
Osint.Write_Program_Name;
Write_Line (": no sources to compile");
end if;
Finish_Program (Project_Tree, E_Success);
end if;
Always_Compile :=
Always_Compile
and then Opt.Force_Compilations
and then Unique_Compile
and then not Unique_Compile_All_Projects;
-- Reprocess recorded command line options that have priority over
-- those in the main project file.
Options.Process_Command_Line_Options;
if Debug.Debug_Flag_M then
Write_Line ("Maximum number of simultaneous compilations =" &
Opt.Maximum_Processes'Img);
end if;
-- Warn if --create-map-file is not supported
if Map_File /= null
and then Main_Project.Config.Map_File_Option = No_Name
then
Write_Str ("warning: option ");
Write_Str (Create_Map_File_Switch);
Write_Str (" is not supported in this configuration");
Write_Eol;
end if;
-- Source file lookups should be cached for efficiency.
-- Source files are not supposed to change.
Osint.Source_File_Data (Cache => True);
-- If switch --no-object-check is used, then there is no check for the
-- switches.
if not Object_Checked then
Opt.Check_Switches := False;
end if;
-- Set slave-env
if Slave_Env = null and then Distributed_Mode then
Slave_Env :=
new String'(Compute_Slave_Env (Project_Tree, Slave_Env_Auto));
if Slave_Env_Auto and not Opt.Quiet_Output then
Write_Str ("slave environment is ");
Write_Str (Slave_Env.all);
Write_Eol;
end if;
end if;
Compile.Run;
Post_Compile.Run;
Link.Run;
if Warnings_Detected /= 0 then
Prj.Err.Finalize;
end if;
Namet.Finalize;
Finish_Program (Project_Tree, E_Success);
exception
when E : others =>
Osint.Fail (Exception_Information (E));
end Gprbuild.Main;
gprbuild-gpl-2014-src/src/gprclean.adb 0000644 0000767 0000145 00000115602 12323721731 017172 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R C L E A N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Text_IO;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.IO; use GNAT.IO;
with GNAT.Regexp; use GNAT.Regexp;
with Gpr_Util; use Gpr_Util;
with Gprexch; use Gprexch;
with MLib; use MLib;
with Makeutl; use Makeutl;
with Namet; use Namet;
with Opt; use Opt;
with Osint;
with Prj.Util; use Prj.Util;
with Snames;
with Types; use Types;
package body Gprclean is
use Knowledge;
-----------------------------
-- Other local subprograms --
-----------------------------
function Object_Artifact
(Object_File_Name : File_Name_Type;
Artifact_Extension : Name_Id)
return String;
procedure Clean_Archive (Project : Project_Id);
-- Delete a global archive and its dependency file, if they exist
procedure Clean_Interface_Copy_Directory
(Project : Project_Id; Project_Tree : Project_Tree_Ref);
-- Delete files in an interface copy directory: any file that is a copy of
-- a source of the project.
procedure Clean_Library_Directory
(Project : Project_Id;
Project_Tree : Project_Tree_Ref);
-- Delete the library file in a library directory and any ALI file
-- of a source of the project in a library ALI directory.
procedure Delete_Binder_Generated_Files
(Main_Project : Project_Id;
Project_Tree : Project_Tree_Ref;
Dir : String;
Source : Source_Id);
-- Delete the binder generated file in directory Dir for Source
function Ultimate_Extension_Of (Project : Project_Id) return Project_Id;
-- Returns either Project, if it is not extended by another project, or
-- the project that extends Project, directly or indirectly, and that is
-- not itself extended. Returns No_Project if Project is No_Project.
function Object_Artifact
(Object_File_Name : File_Name_Type;
Artifact_Extension : Name_Id)
return String
is
Object : constant String := Get_Name_String (Object_File_Name);
Last : Natural := Object'Last;
begin
while Last > 0 and then Object (Last) /= '.' loop
Last := Last - 1;
end loop;
if Last = 0 then
Last := Object'Last + 1;
end if;
return Object (1 .. Last - 1) & Get_Name_String (Artifact_Extension);
end Object_Artifact;
-------------------
-- Clean_Archive --
-------------------
procedure Clean_Archive (Project : Project_Id) is
Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
Archive_Name : constant String :=
"lib" & Get_Name_String (Project.Name)
& Get_Name_String (Project.Config.Archive_Suffix);
-- The name of the archive file for this project
Archive_Dep_Name : constant String :=
"lib" & Get_Name_String (Project.Name) & ".deps";
-- The name of the archive dependency file for this project
Obj_Dir : constant String :=
Get_Name_String (Project.Object_Directory.Display_Name);
begin
if Is_Directory (Obj_Dir) then
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 if;
end Clean_Archive;
------------------------------------
-- Clean_Interface_Copy_Directory --
------------------------------------
procedure Clean_Interface_Copy_Directory
(Project : Project_Id; Project_Tree : Project_Tree_Ref)
is
Current : constant String := Get_Current_Dir;
Direc : Dir_Type;
Name : String (1 .. 200);
Last : Natural;
Delete_File : Boolean;
Source : Prj.Source_Id;
File_Name : File_Name_Type;
begin
if Project.Library
and then Project.Library_Src_Dir /= No_Path_Information
then
declare
Directory : constant String :=
Get_Name_String (Project.Library_Src_Dir.Name);
Iter : Source_Iterator;
begin
if Is_Directory (Directory) then
Change_Dir (Directory);
Open (Direc, ".");
-- For each regular file in the directory, if switch -n has not
-- been specified, make it writable and delete the file if it
-- is a copy of a source of the project.
loop
Read (Direc, Name, Last);
exit when Last = 0;
if Is_Regular_File (Name (1 .. Last)) then
Osint.Canonical_Case_File_Name (Name (1 .. Last));
Name_Len := Last;
Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
File_Name := Name_Find;
Delete_File := False;
Iter := For_Each_Source (Project_Tree);
loop
Source := Prj.Element (Iter);
exit when Source = No_Source;
if Ultimate_Extension_Of (Source.Project) = Project
and then Source.File = File_Name
then
Delete_File := True;
exit;
end if;
Next (Iter);
end loop;
if Delete_File then
if not Do_Nothing then
Set_Writable (Name (1 .. Last));
end if;
Delete (Directory, Name (1 .. Last));
end if;
end if;
end loop;
Close (Direc);
-- Restore the initial working directory
Change_Dir (Current);
end if;
end;
end if;
end Clean_Interface_Copy_Directory;
-----------------------------
-- Clean_Library_Directory --
-----------------------------
procedure Clean_Library_Directory
(Project : Project_Id;
Project_Tree : Project_Tree_Ref)
is
Current : constant String := Get_Current_Dir;
Lib_Filename : constant String :=
Get_Name_String (Project.Library_Name);
DLL_Name : String :=
Get_Name_String
(Project.Config.Shared_Lib_Prefix)
& Lib_Filename
& Get_Name_String
(Project.Config.Shared_Lib_Suffix);
Archive_Name : String :=
"lib" & Lib_Filename
& Get_Name_String
(Project.Config.Archive_Suffix);
Library_Exchange_File_Name : constant String :=
Lib_Filename & Library_Exchange_Suffix;
Direc : Dir_Type;
Name : String (1 .. 200);
Last : Natural;
Delete_File : Boolean;
begin
if Project.Library then
Osint.Canonical_Case_File_Name (DLL_Name);
Osint.Canonical_Case_File_Name (Archive_Name);
declare
Obj_Directory : String_Access := null;
Lib_Directory : constant String :=
Get_Name_String
(Project.Library_Dir.Display_Name);
Lib_ALI_Directory : constant String :=
Get_Name_String
(Project.Library_ALI_Dir.Display_Name);
Exchange_File : Ada.Text_IO.File_Type;
In_Generated : Boolean;
begin
if Project.Object_Directory.Display_Name /= No_Path then
Obj_Directory :=
new String'
(Get_Name_String (Project.Object_Directory.Display_Name));
if Is_Directory (Obj_Directory.all) then
Change_Dir (Obj_Directory.all);
Open (Direc, ".");
-- Look for the library exchange file in the object
-- directory.
loop
Read (Direc, Name, Last);
exit when Last = 0;
if Is_Regular_File (Name (1 .. Last)) then
Osint.Canonical_Case_File_Name (Name (1 .. Last));
exit when
Name (1 .. Last) = Library_Exchange_File_Name;
end if;
end loop;
Close (Direc);
-- If there is a library exchange file then get the
-- generated file names and delete them, then delete
-- the library exchange file.
if Last > 0 then
Ada.Text_IO.Open
(Exchange_File,
Ada.Text_IO.In_File,
Library_Exchange_File_Name);
In_Generated := False;
while not Ada.Text_IO.End_Of_File (Exchange_File) loop
Ada.Text_IO.Get_Line (Exchange_File, Name, Last);
if Last > 0 then
if Name (1) = '[' then
In_Generated :=
Name (1 .. Last) =
Library_Label (Generated_Object_Files)
or else
Name (1 .. Last) =
Library_Label (Generated_Source_Files);
elsif In_Generated then
if Is_Regular_File (Name (1 .. Last)) then
if not Do_Nothing then
Set_Writable (Name (1 .. Last));
end if;
Delete (Obj_Directory.all, Name (1 .. Last));
end if;
end if;
end if;
end loop;
Ada.Text_IO.Close (Exchange_File);
if not Do_Nothing then
Set_Writable (Library_Exchange_File_Name);
end if;
Delete (Obj_Directory.all, Library_Exchange_File_Name);
end if;
Change_Dir (Current);
end if;
end if;
if Is_Directory (Lib_Directory) then
Change_Dir (Lib_Directory);
Open (Direc, ".");
-- For each regular file in the directory, if switch -n has not
-- been specified, make it writable and delete the file if it
-- is the library file.
loop
Read (Direc, Name, Last);
exit when Last = 0;
if Is_Regular_File (Name (1 .. Last))
or else Is_Symbolic_Link (Name (1 .. Last))
then
Osint.Canonical_Case_File_Name (Name (1 .. Last));
if (Project.Library_Kind = Static
and then Name (1 .. Last) = Archive_Name)
or else
((Project.Library_Kind = Dynamic
or else Project.Library_Kind = Relocatable)
and then Name (1 .. Last) = DLL_Name)
then
if not Do_Nothing then
Set_Writable (Name (1 .. Last));
end if;
Delete (Lib_Directory, Name (1 .. Last));
end if;
end if;
end loop;
Close (Direc);
if Project.Config.Symbolic_Link_Supported then
if (Project.Library_Kind = Dynamic
or else Project.Library_Kind = Relocatable)
and then Project.Lib_Internal_Name /= No_Name
then
declare
Lib_Version : String :=
Get_Name_String (Project.Lib_Internal_Name);
begin
Osint.Canonical_Case_File_Name (Lib_Version);
if Project.Config.Lib_Maj_Min_Id_Supported then
declare
Maj_Version : String :=
Major_Id_Name (DLL_Name, Lib_Version);
begin
if Maj_Version /= "" then
Osint.Canonical_Case_File_Name (Maj_Version);
Open (Direc, ".");
-- For each regular file in the directory, if
-- switch -n has not been specified, make it
-- writable and delete the file if it is the
-- library major version file.
loop
Read (Direc, Name, Last);
exit when Last = 0;
if (Is_Regular_File (Name (1 .. Last))
or else
Is_Symbolic_Link (Name (1 .. Last)))
and then Name (1 .. Last) = Maj_Version
then
if not Do_Nothing then
Set_Writable (Name (1 .. Last));
end if;
Delete
(Lib_Directory, Name (1 .. Last));
end if;
end loop;
Close (Direc);
end if;
end;
end if;
Open (Direc, ".");
-- For each regular file in the directory, if switch
-- -n has not been specified, make it writable and
-- delete the file if it is the library version file.
loop
Read (Direc, Name, Last);
exit when Last = 0;
if Is_Regular_File (Name (1 .. Last))
and then Name (1 .. Last) = Lib_Version
then
if not Do_Nothing then
Set_Writable (Name (1 .. Last));
end if;
Delete (Lib_Directory, Name (1 .. Last));
end if;
end loop;
Close (Direc);
end;
end if;
end if;
Change_Dir (Current);
end if;
if Is_Directory (Lib_ALI_Directory) then
Change_Dir (Lib_ALI_Directory);
Open (Direc, ".");
-- For each regular file in the directory, if switch -n has not
-- been specified, make it writable and delete the file if it
-- is any dependency file of a source of the project.
loop
Read (Direc, Name, Last);
exit when Last = 0;
if Is_Regular_File (Name (1 .. Last)) then
Osint.Canonical_Case_File_Name (Name (1 .. Last));
Delete_File := False;
if Last > 4 and then Name (Last - 3 .. Last) = ".ali" then
declare
Source : Prj.Source_Id;
Iter : Source_Iterator;
Proj : Project_Id := Project;
begin
Project_Loop : loop
Iter := For_Each_Source (Project_Tree, Proj);
loop
Source := Prj.Element (Iter);
exit when Source = No_Source;
if Source.Dep_Name /= No_File
and then
Get_Name_String (Source.Dep_Name) =
Name (1 .. Last)
then
Delete_File := True;
exit Project_Loop;
end if;
Next (Iter);
end loop;
exit Project_Loop when Proj.Extends = No_Project;
Proj := Proj.Extends;
end loop Project_Loop;
end;
end if;
if Delete_File then
if not Do_Nothing then
Set_Writable (Name (1 .. Last));
end if;
Delete (Lib_ALI_Directory, Name (1 .. Last));
end if;
end if;
end loop;
Close (Direc);
-- Restore the initial working directory
Change_Dir (Current);
end if;
end;
end if;
end Clean_Library_Directory;
-- Artifacts
type Artifact_Array_Type is array (Positive range <>) of GNAT.Regexp.Regexp;
type Artifact_Array_Ptr is access Artifact_Array_Type;
Artifacts : Artifact_Array_Ptr := new Artifact_Array_Type (1 .. 4);
-- List of regular expression file names to be deleted in procedure
-- Clean_Artifacts below. Size 4 is arbitrary.
Artifact_Last : Natural := 0;
-- Last index of the valid artifacts in array Artifacts.
-------------------
-- Clean_Project --
-------------------
procedure Clean_Project
(Project : Project_Id;
Project_Tree : Project_Tree_Ref;
Main : Boolean;
Remove_Executables : Boolean)
is
Executable : File_Name_Type;
-- Name of the executable file
Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
Project2 : Project_Id;
Source_Id : Prj.Source_Id;
Partial_Number : Natural;
List : Name_List_Index := No_Name_List;
Node : Name_Node;
procedure Clean_Artifacts (Dir : String; List : Name_List_Index);
-- Clean the artifacts specified by List in directory Dir.
-- The current directory is Dir.
function Is_Regexp (Name : String) return Boolean;
-- Return True iff Name is a glob regexp.
---------------------
-- Clean_Artifacts --
---------------------
procedure Clean_Artifacts (Dir : String; List : Name_List_Index) is
Lst : Name_List_Index := List;
Nod : Name_Node;
begin
Artifact_Last := 0;
while Lst /= No_Name_List loop
Nod := Project_Tree.Shared.Name_Lists.Table (Lst);
declare
Name : constant String := Get_Name_String (Nod.Name);
begin
if Is_Regexp (Name) then
if Artifact_Last = Artifacts'Length then
declare
New_Artifacts : constant Artifact_Array_Ptr :=
new Artifact_Array_Type (1 .. 2 * Artifact_Last);
begin
New_Artifacts (1 .. Artifact_Last) :=
Artifacts (1 .. Artifact_Last);
Artifacts := New_Artifacts;
end;
end if;
Artifact_Last := Artifact_Last + 1;
Artifacts (Artifact_Last) :=
Compile (Name, Glob => True);
elsif Is_Regular_File (Name) then
Delete (Dir, Name);
end if;
end;
Lst := Nod.Next;
end loop;
if Artifact_Last > 0 then
declare
Directory : Dir_Type;
File_Name : Dir_Name_Str (1 .. 1_000);
Last : Natural;
begin
Open (Directory, Dir);
Directory_Loop :
loop
Read (Directory, File_Name, Last);
exit Directory_Loop when Last = 0;
if Is_Regular_File (File_Name (1 .. Last)) then
Artifact_Loop :
for J in 1 .. Artifact_Last loop
if Match
(File_Name (1 .. Last), Artifacts (J))
then
Delete (Dir, File_Name (1 .. Last));
exit Artifact_Loop;
end if;
end loop Artifact_Loop;
end if;
end loop Directory_Loop;
Close (Directory);
end;
end if;
end Clean_Artifacts;
---------------
-- Is_Regexp --
---------------
function Is_Regexp (Name : String) return Boolean is
begin
for J in Name'Range loop
case Name (J) is
when '?' | '*' | '[' | '{' =>
return True;
when others =>
null;
end case;
end loop;
return False;
end Is_Regexp;
begin
-- Check that we don't specify executable on the command line for
-- a main library project.
if Project = Main_Project
and then Mains.Number_Of_Mains (null) /= 0
and then Project.Library
then
Osint.Fail
("Cannot specify executable(s) for a Library Project File");
end if;
-- Add project to the list of processed projects
Processed_Projects.Increment_Last;
Processed_Projects.Table (Processed_Projects.Last) := Project;
-- Nothing to clean in an externally built project
if Project.Externally_Built then
if Verbose_Mode then
Put ("Nothing to do to clean externally built project """);
Put (Get_Name_String (Project.Name));
Put_Line ("""");
end if;
else
if Verbose_Mode then
Put ("Cleaning project """);
Put (Get_Name_String (Project.Name));
Put_Line ("""");
end if;
if Project.Object_Directory /= No_Path_Information
and then Is_Directory
(Get_Name_String (Project.Object_Directory.Display_Name))
then
declare
Obj_Dir : constant String :=
Get_Name_String (Project.Object_Directory.Display_Name);
Iter : Source_Iterator;
begin
Change_Dir (Obj_Dir);
-- For non library project, clean the global archive and its
-- dependency file if they exist.
if not Project.Library then
Clean_Archive (Project);
end if;
-- For a library project, clean the partially link objects, if
-- there are some.
if Project.Library then
Partial_Number := 0;
loop
declare
Partial : constant String :=
Partial_Name
(Get_Name_String (Project.Library_Name),
Partial_Number,
Object_Suffix);
begin
if Is_Regular_File (Partial) then
Delete (Obj_Dir, Partial);
Partial_Number := Partial_Number + 1;
else
exit;
end if;
end;
end loop;
end if;
-- Check all the object file for the sources of the current
-- project and all the projects it extends.
Project2 := Project;
while Project2 /= No_Project loop
-- Delete the object files, the dependency files, the
-- switches files if they exist. Also additional artifacts
-- if they are any.
Iter := For_Each_Source (Project_Tree, Project2);
loop
Source_Id := Prj.Element (Iter);
exit when Source_Id = No_Source;
if Source_Id.Object /= No_File
and then Is_Regular_File
(Get_Name_String (Source_Id.Object))
then
Delete (Obj_Dir, Get_Name_String (Source_Id.Object));
-- Clean object artifacts, if any
List :=
Source_Id.Language.Config.Clean_Object_Artifacts;
while List /= No_Name_List loop
Node := Project_Tree.Shared.Name_Lists.Table (List);
declare
Artifact : constant String :=
Object_Artifact (Source_Id.Object, Node.Name);
begin
if Is_Regular_File (Artifact) then
Delete (Obj_Dir, Artifact);
end if;
end;
List := Node.Next;
end loop;
end if;
if Source_Id.Dep_Name /= No_File
and then Is_Regular_File
(Get_Name_String (Source_Id.Dep_Name))
then
Delete (Obj_Dir, Get_Name_String (Source_Id.Dep_Name));
end if;
if Source_Id.Switches /= No_File
and then Is_Regular_File
(Get_Name_String (Source_Id.Switches))
then
Delete (Obj_Dir, Get_Name_String (Source_Id.Switches));
end if;
-- Clean source artifacts, if any
List := Source_Id.Language.Config.Clean_Source_Artifacts;
while List /= No_Name_List loop
Node := Project_Tree.Shared.Name_Lists.Table (List);
declare
Artifact : constant String :=
Get_Name_String (Source_Id.File) &
Get_Name_String (Node.Name);
begin
if Is_Regular_File (Artifact) then
Delete (Obj_Dir, Artifact);
end if;
end;
List := Node.Next;
end loop;
Next (Iter);
end loop;
Project2 := Project2.Extends;
end loop;
-- Clean the artifacts in object directory, if any. Do this
-- after cleaning the object files, to avoid checking every
-- object file when the artifacts are given as a regexp.
Clean_Artifacts
(Obj_Dir, Project.Config.Artifacts_In_Object_Dir);
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 Project.Library then
if not Compile_Only then
Clean_Library_Directory (Project, Project_Tree);
if Project.Library_Src_Dir /= No_Path_Information then
Clean_Interface_Copy_Directory (Project, Project_Tree);
end if;
end if;
end if;
if Verbose_Mode then
New_Line;
end if;
end if;
-- If switch -r is specified, call Clean_Project recursively for the
-- imported projects and the project being extended.
if All_Projects then
declare
Imported : Project_List := Project.Imported_Projects;
Process : Boolean;
begin
-- For each imported project, call Clean_Project if the project
-- has not been processed already.
while Imported /= null loop
Process := True;
for
J in Processed_Projects.First .. Processed_Projects.Last
loop
if Imported.Project = Processed_Projects.Table (J) then
Process := False;
exit;
end if;
end loop;
if Process then
Clean_Project (Imported.Project, Project_Tree, False, False);
end if;
Imported := Imported.Next;
end loop;
-- If this project extends another project, call Clean_Project for
-- the project being extended. It is guaranteed that it has not
-- called before, because no other project may import or extend
-- this project.
if Project.Extends /= No_Project then
Clean_Project (Project.Extends, Project_Tree, False, False);
end if;
end;
end if;
-- For the main project, delete the executables and the binder generated
-- files.
-- The executables are deleted only if switch -c is not specified
if Main
and then Project.Exec_Directory /= No_Path_Information
and then Is_Directory
(Get_Name_String (Project.Exec_Directory.Display_Name))
then
declare
Exec_Dir : constant String :=
Get_Name_String
(Project.Exec_Directory.Display_Name);
Main_File : Main_Info;
begin
Change_Dir (Exec_Dir);
-- Clean the artifacts in the exec dir, if any
Clean_Artifacts (Exec_Dir, Project.Config.Artifacts_In_Exec_Dir);
Mains.Reset;
loop
Main_File := Mains.Next_Main;
exit when Main_File = No_Main_Info;
if Main_File.Tree = Project_Tree then
if Remove_Executables
and then Main_File.Source /= No_Source
then
Executable :=
Executable_Of
(Project => Project,
Shared => Project_Tree.Shared,
Main => Main_File.File,
Index => Main_File.Index,
Ada_Main =>
Main_File.Source.Language.Name = Snames.Name_Ada);
declare
Exec_File_Name : constant String :=
Get_Name_String (Executable);
begin
if Is_Absolute_Path (Name => Exec_File_Name) then
if Is_Regular_File (Exec_File_Name) then
Delete ("", Exec_File_Name);
end if;
else
if Is_Regular_File (Exec_File_Name) then
Delete (Exec_Dir, Exec_File_Name);
end if;
end if;
end;
end if;
-- Delete the binder generated files only if the main source
-- has been found and if there is an object directory.
if Main_File.Source /= No_Source
and then Project.Object_Directory /= No_Path_Information
and then Is_Directory
(Get_Name_String
(Project.Object_Directory.Display_Name))
then
Delete_Binder_Generated_Files
(Project, Project_Tree,
Get_Name_String
(Project.Object_Directory.Display_Name),
Main_File.Source);
end if;
end if;
end loop;
end;
end if;
-- Change back to previous directory
Change_Dir (Current_Dir);
end Clean_Project;
------------
-- Delete --
------------
procedure Delete (In_Directory : String; File : String) is
Full_Name : String (1 .. In_Directory'Length + File'Length + 1);
Last : Natural := 0;
Success : Boolean;
begin
-- Indicate that at least one file is deleted or is to be deleted
File_Deleted := True;
-- Build the path name of the file to delete
Last := In_Directory'Length;
Full_Name (1 .. Last) := In_Directory;
if Last > 0 and then Full_Name (Last) /= Directory_Separator then
Last := Last + 1;
Full_Name (Last) := Directory_Separator;
end if;
Full_Name (Last + 1 .. Last + File'Length) := File;
Last := Last + File'Length;
-- If switch -n was used, simply output the path name
if Do_Nothing then
Put_Line (Full_Name (1 .. Last));
-- Otherwise, delete the file if it is writable
else
if Force_Deletions
or else Is_Writable_File (Full_Name (1 .. Last))
then
Delete_File (Full_Name (1 .. Last), Success);
else
Success := False;
end if;
if Verbose_Mode or else not Quiet_Output then
if not Success then
Put ("Warning: """);
Put (Full_Name (1 .. Last));
Put_Line (""" could not be deleted");
else
Put ("""");
Put (Full_Name (1 .. Last));
Put_Line (""" has been deleted");
end if;
end if;
end if;
end Delete;
-----------------------------------
-- Delete_Binder_Generated_Files --
-----------------------------------
procedure Delete_Binder_Generated_Files
(Main_Project : Project_Id;
Project_Tree : Project_Tree_Ref;
Dir : String;
Source : Source_Id)
is
Data : constant Builder_Data_Access := Builder_Data (Project_Tree);
Current : constant String := Get_Current_Dir;
B_Data : Binding_Data;
Base_Name : File_Name_Type;
begin
Find_Binding_Languages (Project_Tree, Main_Project);
if Data.There_Are_Binder_Drivers then
-- Get the main base name
Base_Name := Base_Name_Index_For
(Get_Name_String (Source.File), Source.Index, '~');
-- Work in the object directory
Change_Dir (Dir);
B_Data := Data.Binding;
while B_Data /= null loop
declare
File_Name : constant String :=
Binder_Exchange_File_Name
(Base_Name, B_Data.Binder_Prefix).all;
File : Ada.Text_IO.File_Type;
Line : String (1 .. 1_000);
Last : Natural;
Section : Binding_Section := No_Binding_Section;
begin
if Is_Regular_File (File_Name) then
Ada.Text_IO.Open (File, Ada.Text_IO.In_File, File_Name);
while not Ada.Text_IO.End_Of_File (File) loop
Ada.Text_IO.Get_Line (File, Line, Last);
if Last > 0 then
if Line (1) = '[' then
Section :=
Get_Binding_Section (Line (1 .. Last));
else
case Section is
when Generated_Object_File |
Generated_Source_Files =>
if Is_Regular_File (Line (1 .. Last)) then
Delete (Dir, Line (1 .. Last));
end if;
when others =>
null;
end case;
end if;
end if;
end loop;
Ada.Text_IO.Close (File);
Delete (Dir, File_Name);
end if;
end;
B_Data := B_Data.Next;
end loop;
-- Change back to previous directory
Change_Dir (Current);
end if;
end Delete_Binder_Generated_Files;
---------------------------
-- Ultimate_Extension_Of --
---------------------------
function Ultimate_Extension_Of (Project : Project_Id) return Project_Id is
Result : Project_Id := Project;
begin
if Project /= No_Project then
loop
exit when Result.Extended_By = No_Project;
Result := Result.Extended_By;
end loop;
end if;
return Result;
end Ultimate_Extension_Of;
end Gprclean;
gprbuild-gpl-2014-src/src/gprinstall.ads 0000644 0000767 0000145 00000013113 12323721731 017571 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R I N S T A L L . M A I N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
private with GNAT.OS_Lib;
private with Prj;
package Gprinstall is
private
use Prj;
use GNAT.OS_Lib;
DS : constant Character := GNAT.OS_Lib.Directory_Separator;
Display_Paths : Boolean := False;
-- Set by switch --display-paths: config project path and user project path
-- will be displayed after all command lines witches have been scanned.
Project_File_Name_Expected : Boolean := False;
-- True when last switch was -P
Main_Project_Dir : String_Access;
-- The absolute path of the project directory of the main project,
-- initialized in procedure Initialize.
Force_Installations : Boolean := False;
-- True if gprinstall is allowed to overwrite existing files
-- A Param, track if it is set on the command line or if it is the default
-- value.
type Param is record
V : String_Access;
Default : Boolean := False;
end record;
function Dup (P : Param) return Param;
-- Return a copy of P
procedure Free (P : in out Param);
-- Free P
Global_Prefix_Dir : Param := (null, True);
-- Root installation directory
Global_Exec_Subdir : Param := (new String'("bin" & DS), True);
-- Subdirectory for executable
Global_Lib_Subdir : Param := (new String'("lib" & DS), True);
-- Subdirectory for libraries
Global_Link_Lib_Subdir : Param := (new String'("lib" & DS), True);
-- Subdirectory for libraries sym links (on UNIX)
Global_Sources_Subdir : Param := (new String'("include" & DS), True);
-- Subdirectory for sources
Global_Project_Subdir : Param :=
(new String'("share" & DS & "gpr" & DS), True);
-- Subdirectory used for the installed generated project file
Build_Var : String_Access;
-- Name of the build variable for installed project file
Build_Name : String_Access := new String'("default");
-- Name of the current build
Install_Name : String_Access;
-- The installation name
Install_Name_Default : Boolean := True;
-- Wether the Install_Name has been specified on the command line. If
-- specified then Install_Name_Default will be false.
For_Dev : Boolean := True;
-- True if the installation is for developers (source of the libraries
-- are also installed). If set to False (for usage) only the shared
-- libraries are installed and/or the main executables.
Search_Project_Dir_Expected : Boolean := False;
-- True when last switch was -aP
Project_Tree : constant Project_Tree_Ref :=
new Project_Tree_Data (Is_Root_Tree => True);
-- The project tree
Copyright_Output : Boolean := False;
Usage_Output : Boolean := False;
-- Flags to avoid multiple displays of Copyright notice and of Usage
Usage_Needed : Boolean := False;
-- Set by swith -h: usage will be displayed after all command line
-- switches have been scanned.
Recursive : Boolean := False;
-- Installation will recurse into all imported projects
Dry_Run : Boolean := False;
-- Whether the actual installation takes place or not. If Dry_Run is set to
-- True then the action will be displayed on the console but actually not
-- performed.
type Usage_Kind is (Install_Mode, Uninstall_Mode, List_Mode);
Usage_Mode : Usage_Kind := Install_Mode;
-- Set to true if project is to be uninstalled
Output_Stats : Boolean := False;
-- Wether the stats are to be displayed when listing installed packages
All_Sources : Boolean := False;
-- By default install only the sources needed to use the project (the
-- interface for a SAL). If All_Sources is set to True all the sources are
-- copied.
Add_Lib_Link : Boolean := True;
-- Wether to copy the shared library into the executable directory on
-- Windows or create a link into the lib directory on UNIX.
Create_Dest_Dir : Boolean := False;
-- Wether to create the missing directories in the destination point
Sig_Line : constant String := "S ";
-- The prefix of the line containing the original project's signature
end Gprinstall;
gprbuild-gpl-2014-src/src/gprbuild-compilation-slave.ads 0000644 0000767 0000145 00000006674 12323721731 022664 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . C O M P I L A T I O N . S L A V E --
-- --
-- S p e c --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with GNAT.OS_Lib;
with Gprbuild.Compilation.Process; use Gprbuild.Compilation.Process;
package Gprbuild.Compilation.Slave is
procedure Record_Slaves (Option : String);
-- Record the slaves as passed on the command line
procedure Register_Remote_Slaves
(Tree : Project_Tree_Ref;
Project : Project_Id);
-- Register the slaves describes in Build_Slaves attribute of project's
-- Remote package. This routine also initialize the slaves sources. This
-- routine must be called before any other in this unit.
procedure Clean_Up_Remote_Slaves
(Tree : Project_Tree_Ref;
Project : Project_Id);
-- Send a clean-up request to all remote slaves. The slaves are then asked
-- to remove all the sources and build artifacts for the given project.
function Run
(Project : Project_Id;
Language : String;
Options : GNAT.OS_Lib.Argument_List;
Obj_Name : String;
Dep_Name : String := "";
Env : String := "") return Id;
-- Send a compilation job to one slave that has still some free slot. There
-- is also free slot when this routine is called (gprbuild ensure this).
procedure Unregister_Remote_Slaves;
-- Unregister all slaves, send them notification about the end of the
-- current build. This routine also synchronize back the object code from
-- each slave to the build master. This routine must be called after the
-- compilation phase and before the bind and link ones. It is safe to call
-- this routine multiple times, the first call will do the clean-up, next
-- calls are just no-op.
function Get_Max_Processes return Natural;
-- Returns the maximum number of processes supported by the compilation
-- engine. This is the sum of the parallel local builds as specified by
-- the -j option and all the sum of the processes supported by each slaves.
end Gprbuild.Compilation.Slave;
gprbuild-gpl-2014-src/src/gprconfig.ads 0000644 0000767 0000145 00000003141 12323721731 017370 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R C O N F I G --
-- --
-- S p e c --
-- --
-- Copyright (C) 2006-2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
package GprConfig is
pragma Pure;
end GprConfig;
gprbuild-gpl-2014-src/src/gprinstall-db.adb 0000644 0000767 0000145 00000013306 12323721731 020137 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R I N S T A L L . D B --
-- --
-- B o d y --
-- --
-- Copyright (C) 2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Directories; use Ada.Directories;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.MD5; use GNAT.MD5;
package body Gprinstall.DB is
use Ada;
----------
-- List --
----------
procedure List is
type Stats is record
N_Files : Natural := 0;
N_Files_Not_Found : Natural := 0;
Bytes : File_Size := 0;
end record;
function Project_Dir return String;
-- Returns the install project directory
function Get_Stat (Manifest : String) return Stats;
-- Compute the stats for the given manifest file
procedure Process (D_Entry : Directory_Entry_Type);
-- Process a directory entry, this is a specific manifest file
--------------
-- Get_Stat --
--------------
function Get_Stat (Manifest : String) return Stats is
File : File_Type;
Line : String (1 .. 2048);
Last : Natural;
Result : Stats;
subtype MD5_Range is Positive range Message_Digest'Range;
subtype Name_Range
is Positive range MD5_Range'Last + 2 .. Line'Last;
begin
Open (File, In_File, Manifest);
while not End_Of_File (File) loop
Get_Line (File, Line, Last);
if Line (1 .. 2) /= Sig_Line then
declare
Filename : constant String :=
Global_Prefix_Dir.V.all
& Line (Name_Range'First .. Last);
begin
if Exists (Filename) then
Result.N_Files := Result.N_Files + 1;
Result.Bytes := Result.Bytes + Size (Filename);
else
Result.N_Files_Not_Found := Result.N_Files_Not_Found + 1;
end if;
end;
end if;
end loop;
Close (File);
return Result;
end Get_Stat;
-----------------
-- Project_Dir --
-----------------
function Project_Dir return String is
begin
if Is_Absolute_Path (Global_Project_Subdir.V.all) then
return Global_Project_Subdir.V.all;
else
return Global_Prefix_Dir.V.all & Global_Project_Subdir.V.all;
end if;
end Project_Dir;
package File_Size_IO is new Text_IO.Integer_IO (File_Size);
use File_Size_IO;
-------------
-- Process --
-------------
procedure Process (D_Entry : Directory_Entry_Type) is
S : Stats;
Unit : String (1 .. 2) := "b ";
Size : File_Size;
begin
Put (" " & Simple_Name (D_Entry));
Set_Col (25);
if Output_Stats then
-- Get stats
S := Get_Stat (Full_Name (D_Entry));
-- Number of files
Put (S.N_Files, Width => 5);
if S.N_Files > 1 then
Put (" files, ");
else
Put (" file, ");
end if;
-- Sizes
Size := S.Bytes;
if Size > 1024 then
Size := Size / 1024;
Unit := "Kb";
end if;
if Size > 1024 then
Size := Size / 1024;
Unit := "Mb";
end if;
if Size > 1024 then
Size := Size / 1024;
Unit := "Gb";
end if;
Put (Size, Width => 5);
Put (' ' & Unit);
-- Files not found if any
if S.N_Files_Not_Found > 0 then
Put (S.N_Files_Not_Found, Width => 0);
Put (" files missing.");
end if;
end if;
New_Line;
end Process;
Dir : constant String := Project_Dir & "manifests";
begin
New_Line;
if Exists (Dir) then
Put_Line ("List of installed packages");
New_Line;
Search
(Dir, "*",
(Ordinary_File => True, others => False),
Process'Access);
else
Put_Line ("No package installed");
New_Line;
end if;
end List;
end Gprinstall.DB;
gprbuild-gpl-2014-src/src/gprexch.adb 0000644 0000767 0000145 00000010472 12323721731 017036 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R E X C H --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006-2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
package body Gprexch is
type String_Ptr is access String;
Binding_Labels : array (Binding_Section) of String_Ptr;
-- The list of labels of the different section in a binder exchange file.
-- Populated in the package body.
Library_Labels : array (Library_Section) of String_Ptr;
-- The list of labels of the different section in a library exchange file.
-- Populated in the package body.
-------------------
-- Binding_Label --
-------------------
function Binding_Label (Section : Binding_Section) return String is
begin
if Binding_Labels (Section) = null then
return "";
else
return Binding_Labels (Section).all;
end if;
end Binding_Label;
-------------------------
-- Get_Binding_Section --
-------------------------
function Get_Binding_Section (Label : String) return Binding_Section is
begin
for Section in Binding_Section loop
if Binding_Labels (Section) /= null and then
Binding_Labels (Section).all = Label
then
return Section;
end if;
end loop;
return No_Binding_Section;
end Get_Binding_Section;
-------------------------
-- Get_Library_Section --
-------------------------
function Get_Library_Section (Label : String) return Library_Section is
begin
for Section in Library_Section loop
if Library_Labels (Section) /= null and then
Library_Labels (Section).all = Label
then
return Section;
end if;
end loop;
return No_Library_Section;
end Get_Library_Section;
-------------------
-- Library_Label --
-------------------
function Library_Label (Section : Library_Section) return String is
begin
if Library_Labels (Section) = null then
return "";
else
return Library_Labels (Section).all;
end if;
end Library_Label;
-- Package elaboration code (build the lists of section labels)
begin
for J in Binding_Labels'Range loop
if J /= No_Binding_Section then
Binding_Labels (J) := new String'('[' & J'Img & ']');
for K in Binding_Labels (J)'Range loop
if Binding_Labels (J) (K) = '_' then
Binding_Labels (J) (K) := ' ';
end if;
end loop;
end if;
end loop;
Binding_Labels (No_Binding_Section) := null;
for J in Library_Labels'Range loop
if J /= No_Library_Section then
Library_Labels (J) := new String'('[' & J'Img & ']');
for K in Library_Labels (J)'Range loop
if Library_Labels (J) (K) = '_' then
Library_Labels (J) (K) := ' ';
end if;
end loop;
end if;
end loop;
Library_Labels (No_Library_Section) := null;
end Gprexch;
gprbuild-gpl-2014-src/src/gprbuild-compile.ads 0000644 0000767 0000145 00000003541 12323721731 020654 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . C O M P I L E --
-- --
-- S p e c --
-- --
-- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
package Gprbuild.Compile is
procedure Run;
-- The first version compilations for a specific project tree. This needs
-- to be called one for each aggregated projects, too.
-- The second version will process all the main root project and all
-- aggregated projects.
end Gprbuild.Compile;
gprbuild-gpl-2014-src/src/gpr_util.adb 0000644 0000767 0000145 00000232103 12323721731 017220 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R _ U T I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 2007-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Containers.Indefinite_Ordered_Sets;
with Ada.Calendar.Time_Zones; use Ada.Calendar; use Ada.Calendar.Time_Zones;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Directories; use Ada.Directories;
with Ada.Streams.Stream_IO; use Ada.Streams;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Maps; use Ada.Strings.Maps;
with Interfaces.C.Strings;
with System;
with GNAT.Calendar.Time_IO; use GNAT.Calendar.Time_IO;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
with GNAT.Sockets;
with ALI; use ALI;
with Debug;
with Makeutl; use Makeutl;
with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
with Prj.Conf;
with Prj.Env;
with Prj.Util; use Prj.Util;
with Scans;
with Scng;
with Sinput.C;
with Sinput.P;
with Snames; use Snames;
with Styleg;
with Table;
with Tempdir;
with Types; use Types;
with GprConfig.Sdefault;
package body Gpr_Util is
-- Empty procedures needed to instantiate Scng. Error procedures are
-- empty, because we don't want to report any errors when computing
-- a source checksum.
procedure Post_Scan;
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
procedure Error_Msg_S (Msg : String);
procedure Error_Msg_SC (Msg : String);
procedure Error_Msg_SP (Msg : String);
-- Instantiation of Styleg, needed to instantiate Scng
package Style is new Styleg
(Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP);
-- A Scanner is needed to get checksum of a source (procedure
-- Get_File_Checksum).
package Scanner is new Scng
(Post_Scan, Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP, Style);
Libgcc_Subdir_Ptr : Interfaces.C.Strings.chars_ptr;
pragma Import (C, Libgcc_Subdir_Ptr, "__gnat_default_libgcc_subdir");
-- Pointer to string indicating the installation subdirectory where a
-- default shared libgcc might be found.
GNU_Header : aliased constant String := "INPUT (";
GNU_Opening : aliased constant String := """";
GNU_Closing : aliased constant String := '"' & ASCII.LF;
GNU_Footer : aliased constant String := ')' & ASCII.LF;
package Project_Name_Boolean_Htable is new Simple_HTable
(Header_Num => Header_Num,
Element => Boolean,
No_Element => False,
Key => Name_Id,
Hash => Hash,
Equal => "=");
Project_Failure : Project_Name_Boolean_Htable.Instance :=
Project_Name_Boolean_Htable.Nil;
-- Record a boolean for project having failed to compile cleanly
-------------------------------
-- Binder_Exchange_File_Name --
-------------------------------
function Binder_Exchange_File_Name
(Main_Base_Name : File_Name_Type; Prefix : Name_Id) return String_Access
is
File_Name : constant String := Get_Name_String (Main_Base_Name);
begin
Get_Name_String (Prefix);
Add_Str_To_Name_Buffer (File_Name);
Add_Str_To_Name_Buffer (Binder_Exchange_Suffix);
return new String'(Name_Buffer (1 .. Name_Len));
end Binder_Exchange_File_Name;
-----------------------
-- Compute_Slave_Env --
-----------------------
function Compute_Slave_Env
(Project : Project_Tree_Ref; Auto : Boolean) return String
is
User : String_Access := Getenv ("USER");
User_Name : String_Access := Getenv ("USERNAME");
Default : constant String :=
(if User = null
then (if User_Name = null
then "unknown" else User_Name.all)
else User.all)
& '@' & GNAT.Sockets.Host_Name;
package S_Set is new Containers.Indefinite_Ordered_Sets (String);
Set : S_Set.Set;
Ctx : Context;
begin
Free (User);
Free (User_Name);
if Auto then
-- In this mode the slave environment is computed based on
-- the project variable value and the command line arguments.
-- First adds all command line arguments
for K in 1 .. Argument_Count loop
-- Skip arguments that are not changing the actual compilation and
-- this will ensure that the same environment will be created for
-- gprclean.
if Argument (K) not in "-p" | "-d" | "-c" | "-q"
and then
(Argument (K)'Length < 2
or else Argument (K) (1 .. 2) /= "-j")
then
Set.Insert (Argument (K));
end if;
end loop;
-- Then all the global variables for the project tree
for K in
1 .. Variable_Element_Table.Last (Project.Shared.Variable_Elements)
loop
declare
V : constant Variable :=
Project.Shared.Variable_Elements.Table (K);
begin
if V.Value.Kind = Single then
Set.Include
(Get_Name_String (V.Name)
& "=" & Get_Name_String (V.Value.Value));
end if;
end;
end loop;
-- Compute the MD5 sum of the sorted elements in the set
for S of Set loop
Update (Ctx, S);
end loop;
return Default & "-" & Digest (Ctx);
else
-- Otherwise use the default & '@' &
return Default;
end if;
end Compute_Slave_Env;
--------------------------
-- Create_Response_File --
--------------------------
procedure Create_Response_File
(Format : Response_File_Format;
Objects : String_List;
Other_Arguments : String_List;
Resp_File_Options : String_List;
Name_1 : out Path_Name_Type;
Name_2 : out Path_Name_Type)
is
Resp_File : File_Descriptor;
Status : Integer;
pragma Warnings (Off, Status);
Closing_Status : Boolean;
pragma Warnings (Off, Closing_Status);
function Modified_Argument (Arg : String) return String;
-- If the argument includes a space, a backslash, or a double quote,
-- escape the character with a preceding backsash.
-----------------------
-- Modified_Argument --
-----------------------
function Modified_Argument (Arg : String) return String is
Result : String (1 .. 2 * Arg'Length);
Last : Natural := 0;
procedure Add (C : Character);
---------
-- Add --
---------
procedure Add (C : Character) is
begin
Last := Last + 1;
Result (Last) := C;
end Add;
begin
for J in Arg'Range loop
if Arg (J) = '\' or else Arg (J) = ' ' or else Arg (J) = '"' then
Add ('\');
end if;
Add (Arg (J));
end loop;
return Result (1 .. Last);
end Modified_Argument;
begin
Name_2 := No_Path;
Tempdir.Create_Temp_File (Resp_File, Name => Name_1);
if Format = GNU or else Format = GCC_GNU then
Status := Write (Resp_File, GNU_Header'Address, GNU_Header'Length);
end if;
for J in Objects'Range loop
if Format = GNU or else Format = GCC_GNU then
Status :=
Write (Resp_File, GNU_Opening'Address, GNU_Opening'Length);
end if;
Status :=
Write (Resp_File, Objects (J).all'Address, Objects (J)'Length);
if Format = GNU or else Format = GCC_GNU then
Status :=
Write (Resp_File, GNU_Closing'Address, GNU_Closing'Length);
else
Status :=
Write (Resp_File, ASCII.LF'Address, 1);
end if;
end loop;
if Format = GNU or else Format = GCC_GNU then
Status := Write (Resp_File, GNU_Footer'Address, GNU_Footer'Length);
end if;
case Format is
when GCC_GNU | GCC_Object_List | GCC_Option_List =>
Close (Resp_File, Closing_Status);
Name_2 := Name_1;
Tempdir.Create_Temp_File (Resp_File, Name => Name_1);
declare
Arg : constant String :=
Modified_Argument (Get_Name_String (Name_2));
begin
for J in Resp_File_Options'Range loop
Status :=
Write
(Resp_File,
Resp_File_Options (J) (1)'Address,
Resp_File_Options (J)'Length);
if J < Resp_File_Options'Last then
Status := Write (Resp_File, ASCII.LF'Address, 1);
end if;
end loop;
Status := Write (Resp_File, Arg (1)'Address, Arg'Length);
end;
Status := Write (Resp_File, ASCII.LF'Address, 1);
when GCC =>
null;
when others =>
Close (Resp_File, Closing_Status);
end case;
if Format = GCC
or else Format = GCC_GNU
or else Format = GCC_Object_List
or else Format = GCC_Option_List
then
for J in Other_Arguments'Range loop
declare
Arg : constant String :=
Modified_Argument (Other_Arguments (J).all);
begin
Status := Write (Resp_File, Arg (1)'Address, Arg'Length);
end;
Status := Write (Resp_File, ASCII.LF'Address, 1);
end loop;
Close (Resp_File, Closing_Status);
end if;
end Create_Response_File;
---------------------
-- Create_Sym_Link --
---------------------
procedure Create_Sym_Link (From, To : String) is
function Symlink
(Oldpath : System.Address;
Newpath : System.Address) return Integer;
pragma Import (C, Symlink, "__gnat_symlink");
C_From : constant String := From & ASCII.NUL;
C_To : constant String :=
Relative_Path
(Containing_Directory (To), Containing_Directory (From)) &
Ada.Directories.Simple_Name (To) & ASCII.NUL;
Result : Integer;
pragma Unreferenced (Result);
begin
Result := Symlink (C_To'Address, C_From'Address);
end Create_Sym_Link;
----------------------
-- Ensure_Directory --
----------------------
function Ensure_Directory (Path : String) return String is
begin
if Path'Length = 0
or else Path (Path'Last) = Directory_Separator
or else Path (Path'Last) = '/' -- on Windows check also for /
then
return Path;
else
return Path & Directory_Separator;
end if;
end Ensure_Directory;
---------------
-- Error_Msg --
---------------
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
pragma Warnings (Off, Msg);
pragma Warnings (Off, Flag_Location);
begin
null;
end Error_Msg;
-----------------
-- Error_Msg_S --
-----------------
procedure Error_Msg_S (Msg : String) is
pragma Warnings (Off, Msg);
begin
null;
end Error_Msg_S;
------------------
-- Error_Msg_SC --
------------------
procedure Error_Msg_SC (Msg : String) is
pragma Warnings (Off, Msg);
begin
null;
end Error_Msg_SC;
------------------
-- Error_Msg_SP --
------------------
procedure Error_Msg_SP (Msg : String) is
pragma Warnings (Off, Msg);
begin
null;
end Error_Msg_SP;
--------------
-- File_MD5 --
--------------
function File_MD5 (Pathname : String) return Message_Digest is
use Stream_IO;
C : Context;
S : Stream_IO.File_Type;
B : Stream_Element_Array (1 .. 100 * 1024);
-- Buffer to read chunk of data
L : Stream_Element_Offset;
begin
Open (S, In_File, Pathname);
while not End_Of_File (S) loop
Read (S, B, L);
Update (C, B (1 .. L));
end loop;
Close (S);
return Digest (C);
end File_MD5;
------------------------------
-- Get_Compiler_Driver_Path --
------------------------------
function Get_Compiler_Driver_Path
(Project_Tree : Project_Tree_Ref;
Lang : Language_Ptr) return String_Access is
begin
if Lang.Config.Compiler_Driver_Path = null then
declare
Compiler_Name : constant String :=
Get_Name_String (Lang.Config.Compiler_Driver);
begin
if Compiler_Name = "" then
return null;
end if;
Lang.Config.Compiler_Driver_Path :=
Locate_Exec_On_Path (Compiler_Name);
if Lang.Config.Compiler_Driver_Path = null then
Fail_Program
(Project_Tree, "unable to locate """ & Compiler_Name & '"');
end if;
end;
end if;
return Lang.Config.Compiler_Driver_Path;
end Get_Compiler_Driver_Path;
----------------------------
-- Find_Binding_Languages --
----------------------------
procedure Find_Binding_Languages
(Tree : Project_Tree_Ref;
Root_Project : Project_Id)
is
Data : constant Builder_Data_Access := Builder_Data (Tree);
B_Index : Binding_Data;
Language_Name : Name_Id;
Binder_Driver_Name : File_Name_Type := No_File;
Binder_Driver_Path : String_Access;
Binder_Prefix : Name_Id;
Language : Language_Ptr;
Config : Language_Config;
Project : Project_List;
begin
-- Have we already processed this tree ?
if Data.There_Are_Binder_Drivers
and then Data.Binding /= null
then
return;
end if;
if Current_Verbosity = High then
Debug_Output ("Find_Binding_Languages for", Debug_Name (Tree));
end if;
Data.There_Are_Binder_Drivers := False;
Project := Tree.Projects;
while Project /= null loop
Language := Project.Project.Languages;
while Language /= No_Language_Index loop
Config := Language.Config;
Binder_Driver_Name := Config.Binder_Driver;
if Language.First_Source /= No_Source
and then Binder_Driver_Name /= No_File
then
Data.There_Are_Binder_Drivers := True;
Language_Name := Language.Name;
B_Index := Data.Binding;
while B_Index /= null
and then B_Index.Language_Name /= Language_Name
loop
B_Index := B_Index.Next;
end loop;
if B_Index = null then
Get_Name_String (Binder_Driver_Name);
Binder_Driver_Path :=
Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
if Binder_Driver_Path = null then
Fail_Program
(Tree,
"unable to find binder driver " &
Name_Buffer (1 .. Name_Len));
end if;
if Current_Verbosity = High then
Debug_Output
("Binder_Driver=" & Binder_Driver_Path.all
& " for Lang", Language_Name);
end if;
if Config.Binder_Prefix = No_Name then
Binder_Prefix := Empty_String;
else
Binder_Prefix := Config.Binder_Prefix;
end if;
B_Index := Data.Binding;
while B_Index /= null loop
if Binder_Prefix = B_Index.Binder_Prefix then
Fail_Program
(Tree,
"binding prefix cannot be the same for"
& " two languages");
end if;
B_Index := B_Index.Next;
end loop;
Data.Binding := new Binding_Data_Record'
(Language => Language,
Language_Name => Language_Name,
Binder_Driver_Name => Binder_Driver_Name,
Binder_Driver_Path => Binder_Driver_Path,
Binder_Prefix => Binder_Prefix,
Next => Data.Binding);
end if;
end if;
Language := Language.Next;
end loop;
Project := Project.Next;
end loop;
if Root_Project.Qualifier = Aggregate then
declare
Agg : Aggregated_Project_List := Root_Project.Aggregated_Projects;
begin
while Agg /= null loop
Find_Binding_Languages (Agg.Tree, Agg.Project);
Agg := Agg.Next;
end loop;
end;
end if;
end Find_Binding_Languages;
----------------
-- Get_Target --
----------------
function Get_Target return String is
begin
if Target_Name = null or else Target_Name.all = "" then
return GprConfig.Sdefault.Hostname;
else
return Target_Name.all;
end if;
end Get_Target;
--------------------
-- Locate_Runtime --
--------------------
procedure Locate_Runtime
(Project_Tree : Project_Tree_Ref;
Language : Name_Id)
is
function Is_Base_Name (Path : String) return Boolean;
-- Returns True if Path has no directory separator
------------------
-- Is_Base_Name --
------------------
function Is_Base_Name (Path : String) return Boolean is
begin
for I in Path'Range loop
if Path (I) = Directory_Separator or else Path (I) = '/' then
return False;
end if;
end loop;
return True;
end Is_Base_Name;
function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path
(Check_Filename => Is_Directory);
RTS_Name : constant String := Prj.Conf.Runtime_Name_For (Language);
Full_Path : String_Access;
begin
if not Is_Base_Name (RTS_Name) then
Full_Path := Find_Rts_In_Path (Root_Environment.Project_Path,
RTS_Name);
if Full_Path = null then
Fail_Program (Project_Tree, "cannot find RTS " & RTS_Name);
end if;
Prj.Conf.Set_Runtime_For
(Language, Normalize_Pathname (Full_Path.all));
Free (Full_Path);
end if;
end Locate_Runtime;
------------------------------
-- Look_For_Default_Project --
------------------------------
procedure Look_For_Default_Project is
begin
No_Project_File_Found := False;
if Is_Regular_File (Default_Project_File_Name) then
Project_File_Name := new String'(Default_Project_File_Name);
else
-- Check if there is a single project file in the current
-- directory. If there is one and only one, use it.
declare
Dir : Dir_Type;
Str : String (1 .. 255);
Last : Natural;
Single : String_Access := null;
begin
No_Project_File_Found := True;
Open (Dir, ".");
loop
Read (Dir, Str, Last);
exit when Last = 0;
if Last > Project_File_Extension'Length
and then Is_Regular_File (Str (1 .. Last))
then
Canonical_Case_File_Name (Str (1 .. Last));
if Str (Last - Project_File_Extension'Length + 1 .. Last)
= Project_File_Extension
then
No_Project_File_Found := False;
if Single = null then
Single := new String'(Str (1 .. Last));
else
-- There are several project files in the current
-- directory. Reset Single to null and exit.
Single := null;
exit;
end if;
end if;
end if;
end loop;
Close (Dir);
Project_File_Name := Single;
end;
if No_Project_File_Found then
Project_File_Name :=
new String'(Executable_Prefix_Path & Implicit_Project_File_Path);
if not Is_Regular_File (Project_File_Name.all) then
Project_File_Name := null;
end if;
end if;
end if;
if (not Quiet_Output) and then Project_File_Name /= null then
Write_Str ("using project file ");
Write_Line (Project_File_Name.all);
end if;
end Look_For_Default_Project;
------------------
-- Partial_Name --
------------------
function Partial_Name
(Lib_Name : String;
Number : Natural;
Object_Suffix : String) return String
is
Img : constant String := Number'Img;
begin
return
Partial_Prefix & Lib_Name &
'_' & Img (Img'First + 1 .. Img'Last)
& Object_Suffix;
end Partial_Name;
--------------------------------
-- Project_Compilation_Failed --
--------------------------------
function Project_Compilation_Failed
(Prj : Project_Id;
Recursive : Boolean := True) return Boolean
is
use Project_Name_Boolean_Htable;
begin
if Get (Project_Failure, Prj.Name) then
return True;
elsif not Recursive then
return False;
else
-- Check all imported projects directly or indirectly
declare
Plist : Project_List := Prj.All_Imported_Projects;
begin
while Plist /= null loop
if Get (Project_Failure, Plist.Project.Name) then
return True;
else
Plist := Plist.Next;
end if;
end loop;
return False;
end;
end if;
end Project_Compilation_Failed;
-----------------------------------
-- Set_Failed_Compilation_Status --
-----------------------------------
procedure Set_Failed_Compilation_Status (Prj : Project_Id) is
begin
Project_Name_Boolean_Htable.Set (Project_Failure, Prj.Name, True);
end Set_Failed_Compilation_Status;
-----------------------
-- Shared_Libgcc_Dir --
-----------------------
function Shared_Libgcc_Dir (Run_Time_Dir : String) return String is
Path : String (1 .. Run_Time_Dir'Length + 15);
Path_Last : constant Natural := Run_Time_Dir'Length;
GCC_Index : Natural := 0;
begin
Path (1 .. Path_Last) := Run_Time_Dir;
GCC_Index := Index (Path (1 .. Path_Last), "gcc-lib");
if GCC_Index /= 0 then
-- This is gcc 2.8.2: the shared version of libgcc is
-- located in the parent directory of "gcc-lib".
GCC_Index := GCC_Index - 1;
else
GCC_Index := Index (Path (1 .. Path_Last), "/lib/");
if GCC_Index = 0 then
GCC_Index :=
Index
(Path (1 .. Path_Last),
Directory_Separator & "lib" & Directory_Separator);
end if;
if GCC_Index /= 0 then
-- We have found "lib" as a subdirectory in the runtime dir path.
-- The
declare
Subdir : constant String :=
Interfaces.C.Strings.Value (Libgcc_Subdir_Ptr);
begin
Path
(GCC_Index + 1 ..
GCC_Index + Subdir'Length) :=
Subdir;
GCC_Index :=
GCC_Index + Subdir'Length;
end;
end if;
end if;
return Path (1 .. GCC_Index);
end Shared_Libgcc_Dir;
---------------------
-- Need_To_Compile --
---------------------
procedure Need_To_Compile
(Source : Prj.Source_Id;
Tree : Project_Tree_Ref;
In_Project : Project_Id;
Must_Compile : out Boolean;
The_ALI : out ALI.ALI_Id;
Object_Check : Boolean;
Always_Compile : Boolean)
is
Source_Path : constant String :=
Get_Name_String (Source.Path.Display_Name);
C_Source_Path : constant String :=
Get_Name_String (Source.Path.Name);
Runtime_Source_Dir : constant Name_Id :=
Source.Language.Config.Runtime_Source_Dir;
Start : Natural;
Finish : Natural;
Last_Obj : Natural;
Stamp : Time_Stamp_Type;
Looping : Boolean := False;
-- Set to True at the end of the first Big_Loop for Makefile fragments
Source_In_Dependencies : Boolean := False;
-- Set True if source was found in dependency file of its object file
C_Object_Name : String_Access := null;
-- The canonical file name for the object file
Object_Path : String_Access := null;
-- The absolute path name for the object file
Switches_Name : String_Access := null;
-- The file name of the file that contains the switches that were used
-- in the last compilation.
Num_Ext : Natural;
-- Number of extending projects
ALI_Project : Project_Id;
-- If the ALI file is in the object directory of a project, this is
-- the project id.
Externally_Built : constant Boolean := In_Project.Externally_Built;
-- True if the project of the source is externally built
function Process_Makefile_Deps
(Dep_Name, Obj_Dir : String) return Boolean;
function Process_ALI_Deps return Boolean;
function Process_ALI_Closure_Deps return Boolean;
-- Process the dependencies for the current source file for the various
-- dependency modes.
-- They return True if the file needs to be recompiled
procedure Cleanup;
-- Cleanup local variables
---------------------------
-- Process_Makefile_Deps --
---------------------------
function Process_Makefile_Deps
(Dep_Name, Obj_Dir : String) return Boolean
is
Dep_File : Prj.Util.Text_File;
begin
Open (Dep_File, Dep_Name);
-- If dependency file cannot be open, we need to recompile
-- the source.
if not Is_Valid (Dep_File) then
if Verbose_Mode then
Write_Str (" -> could not open dependency file ");
Write_Line (Dep_Name);
end if;
return True;
end if;
-- Loop Big_Loop is executed several times only when the
-- dependency file contains several times
-- : ...
-- When there is only one of such occurence, Big_Loop is exited
-- successfully at the beginning of the second loop.
Big_Loop :
loop
declare
End_Of_File_Reached : Boolean := False;
Object_Found : Boolean := False;
begin
loop
if End_Of_File (Dep_File) then
End_Of_File_Reached := True;
exit;
end if;
Get_Line (Dep_File, Name_Buffer, Name_Len);
if Name_Len > 0
and then Name_Buffer (1) /= '#'
then
-- Skip a first line that is an empty continuation line
for J in 1 .. Name_Len - 1 loop
if Name_Buffer (J) /= ' ' then
Object_Found := True;
exit;
end if;
end loop;
exit when Object_Found
or else Name_Buffer (Name_Len) /= '\';
end if;
end loop;
-- If dependency file contains only empty lines or comments,
-- then dependencies are unknown, and the source needs to be
-- recompiled.
if End_Of_File_Reached then
-- If we have reached the end of file after the first
-- loop, there is nothing else to do.
exit Big_Loop when Looping;
if Verbose_Mode then
Write_Str (" -> dependency file ");
Write_Str (Dep_Name);
Write_Line (" is empty");
end if;
Close (Dep_File);
return True;
end if;
end;
Start := 1;
Finish := Index (Name_Buffer (1 .. Name_Len), ": ");
if Finish = 0 then
Finish :=
Index
(Name_Buffer (1 .. Name_Len), (1 => ':', 2 => ASCII.HT));
end if;
if Finish /= 0 then
Last_Obj := Finish;
loop
Last_Obj := Last_Obj - 1;
exit when Last_Obj = Start
or else Name_Buffer (Last_Obj) /= ' ';
end loop;
while Start < Last_Obj and then Name_Buffer (Start) = ' ' loop
Start := Start + 1;
end loop;
Canonical_Case_File_Name (Name_Buffer (Start .. Last_Obj));
end if;
-- First line must start with name of object file, followed by
-- colon.
if Finish = 0
or else
(C_Object_Name /= null
and then Name_Buffer (Start .. Last_Obj) /= C_Object_Name.all)
then
if Verbose_Mode then
Write_Str (" -> dependency file ");
Write_Str (Dep_Name);
Write_Line (" has wrong format");
if Finish = 0 then
Write_Line (" no colon");
else
Write_Str (" expected object file name ");
Write_Str (C_Object_Name.all);
Write_Str (", got ");
Write_Line (Name_Buffer (Start .. Last_Obj));
end if;
end if;
Close (Dep_File);
return True;
else
Start := Finish + 2;
-- Process each line
Line_Loop : loop
declare
Line : String := Name_Buffer (1 .. Name_Len);
Last : Natural := Name_Len;
begin
Name_Loop : loop
-- Find the beginning of the next source path name
while Finish < Last and then Line (Start) = ' ' loop
Start := Start + 1;
end loop;
-- Go to next line when there is a continuation
-- character \ at the end of the line.
exit Name_Loop when Start = Last
and then Line (Start) = '\';
-- We should not be at the end of the line, without
-- a continuation character \.
if Start = Last then
if Verbose_Mode then
Write_Str (" -> dependency file ");
Write_Str (Dep_Name);
Write_Line (" has wrong format");
end if;
Close (Dep_File);
return True;
end if;
-- Look for the end of the source path name
Finish := Start;
while Finish < Last loop
if Line (Finish) = '\' then
-- On Windows, a '\' is part of the path
-- name, except when it is not the first
-- character followed by another '\' or by a
-- space. On other platforms, when we are
-- getting a '\' that is not the last
-- character of the line, the next character
-- is part of the path name, even if it is a
-- space.
if On_Windows
and then Finish = Start
and then Line (Finish + 1) = '\'
then
Finish := Finish + 2;
elsif On_Windows
and then Line (Finish + 1) /= '\'
and then Line (Finish + 1) /= ' '
then
Finish := Finish + 1;
else
Line (Finish .. Last - 1) :=
Line (Finish + 1 .. Last);
Last := Last - 1;
end if;
else
-- A space that is not preceded by '\'
-- indicates the end of the path name.
exit when Line (Finish + 1) = ' ';
Finish := Finish + 1;
end if;
end loop;
-- Check this source
declare
Src_Name : constant String :=
Normalize_Pathname
(Name => Line (Start .. Finish),
Directory => Obj_Dir,
Resolve_Links => False);
C_Src_Name : String := Src_Name;
Src_TS : Time_Stamp_Type;
Source_2 : Prj.Source_Id;
begin
Canonical_Case_File_Name (C_Src_Name);
-- If it is original source, set
-- Source_In_Dependencies.
if C_Src_Name = C_Source_Path then
Source_In_Dependencies := True;
end if;
-- Get the time stamp of the source, which is not
-- necessarily a source of any project.
Name_Len := 0;
Add_Str_To_Name_Buffer (Src_Name);
Src_TS := File_Stamp (File_Name_Type'(Name_Find));
-- If the source does not exist, we need to
-- recompile.
if Src_TS = Empty_Time_Stamp then
if Verbose_Mode then
Write_Str (" -> source ");
Write_Str (Src_Name);
Write_Line (" does not exist");
end if;
Close (Dep_File);
return True;
-- If the source has been modified after the
-- object file, we need to recompile.
elsif Src_TS > Source.Object_TS
and then Object_Check
and then Source.Language.Config.Object_Generated
then
if Verbose_Mode then
Write_Str (" -> source ");
Write_Str (Src_Name);
Write_Line
(" has time stamp later than object file");
end if;
Close (Dep_File);
return True;
else
Name_Len := Src_Name'Length;
Name_Buffer (1 .. Name_Len) := Src_Name;
Source_2 := Source_Paths_Htable.Get
(Tree.Source_Paths_HT, Name_Find);
if Source_2 /= No_Source
and then Source_2.Replaced_By /= No_Source
then
if Verbose_Mode then
Write_Str (" -> source ");
Write_Str (Src_Name);
Write_Line (" has been replaced");
end if;
Close (Dep_File);
return True;
end if;
end if;
end;
-- If the source path name ends the line, we are
-- done.
exit Line_Loop when Finish = Last;
-- Go get the next source on the line
Start := Finish + 1;
end loop Name_Loop;
end;
-- If we are here, we had a continuation character \ at
-- the end of the line, so we continue with the next
-- line.
Get_Line (Dep_File, Name_Buffer, Name_Len);
Start := 1;
Finish := 1;
end loop Line_Loop;
end if;
-- Set Looping at the end of the first loop
Looping := True;
end loop Big_Loop;
Close (Dep_File);
-- If the original sources were not in the dependency file, then
-- we need to recompile. It may mean that we are using a different
-- source (different variant) for this object file.
if not Source_In_Dependencies then
if Verbose_Mode then
Write_Str (" -> source ");
Write_Str (Source_Path);
Write_Line (" is not in the dependencies");
end if;
return True;
end if;
return False;
end Process_Makefile_Deps;
----------------------
-- Process_ALI_Deps --
----------------------
function Process_ALI_Deps return Boolean is
Text : Text_Buffer_Ptr :=
Read_Library_Info_From_Full
(File_Name_Type (Source.Dep_Path),
Source.Dep_TS'Access);
Sfile : File_Name_Type;
Dep_Src : Prj.Source_Id;
Proj : Project_Id;
Found : Boolean := False;
begin
if Text = null then
if Verbose_Mode then
Write_Str (" -> cannot read ");
Write_Line (Get_Name_String (Source.Dep_Path));
end if;
return True;
end if;
-- Read only the necessary lines of the ALI file
The_ALI :=
ALI.Scan_ALI
(File_Name_Type (Source.Dep_Path),
Text,
Ignore_ED => False,
Err => True,
Ignore_Errors => True,
Read_Lines => "PDW");
Free (Text);
if The_ALI = ALI.No_ALI_Id then
if Verbose_Mode then
Write_Str (" -> ");
Write_Str (Get_Name_String (Source.Dep_Path));
Write_Line (" is incorrectly formatted");
end if;
return True;
end if;
if ALI.ALIs.Table (The_ALI).Compile_Errors then
if Verbose_Mode then
Write_Line (" -> last compilation had errors");
end if;
return True;
end if;
if Object_Check and then ALI.ALIs.Table (The_ALI).No_Object then
if Verbose_Mode then
Write_Line
(" -> no object generated during last compilation");
end if;
return True;
end if;
if Check_Source_Info_In_ALI (The_ALI, Tree) = No_Name then
return True;
end if;
-- We need to check that the ALI file is in the correct object
-- directory. If it is in the object directory of a project
-- that is extended and it depends on a source that is in one
-- of its extending projects, then the ALI file is not in the
-- correct object directory.
ALI_Project := Source.Object_Project;
-- Count the extending projects
Num_Ext := 0;
Proj := ALI_Project;
loop
Proj := Proj.Extended_By;
exit when Proj = No_Project;
Num_Ext := Num_Ext + 1;
end loop;
declare
Projects : array (1 .. Num_Ext) of Project_Id;
begin
Proj := ALI_Project;
for J in Projects'Range loop
Proj := Proj.Extended_By;
Projects (J) := Proj;
end loop;
for D in ALI.ALIs.Table (The_ALI).First_Sdep ..
ALI.ALIs.Table (The_ALI).Last_Sdep
loop
Sfile := ALI.Sdep.Table (D).Sfile;
if ALI.Sdep.Table (D).Stamp /= Empty_Time_Stamp then
Dep_Src := Source_Files_Htable.Get
(Tree.Source_Files_HT, Sfile);
Found := False;
while Dep_Src /= No_Source loop
Initialize_Source_Record (Dep_Src);
if not Dep_Src.Locally_Removed
and then Dep_Src.Unit /= No_Unit_Index
then
Found := True;
if Opt.Minimal_Recompilation
and then ALI.Sdep.Table (D).Stamp /=
Dep_Src.Source_TS
then
-- If minimal recompilation is in action, replace
-- the stamp of the source file in the table if
-- checksums match.
declare
Source_Index : Source_File_Index;
use Scans;
begin
Source_Index :=
Sinput.C.Load_File
(Get_Name_String
(Dep_Src.Path.Display_Name));
if Source_Index /= No_Source_File then
Scanner.Initialize_Scanner (Source_Index);
-- Make sure that the project language
-- reserved words are not recognized as
-- reserved words, but as identifiers.
Set_Name_Table_Byte (Name_Project, 0);
Set_Name_Table_Byte (Name_Extends, 0);
Set_Name_Table_Byte (Name_External, 0);
Set_Name_Table_Byte
(Name_External_As_List, 0);
-- Scan the complete file to compute its
-- checksum.
loop
Scanner.Scan;
exit when Token = Tok_EOF;
end loop;
if Scans.Checksum =
ALI.Sdep.Table (D).Checksum
then
if Verbose_Mode then
Write_Str (" ");
Write_Str
(Get_Name_String
(ALI.Sdep.Table (D).Sfile));
Write_Str (": up to date, " &
"different timestamps " &
"but same checksum");
Write_Eol;
end if;
ALI.Sdep.Table (D).Stamp :=
Dep_Src.Source_TS;
end if;
end if;
-- To avoid using too much memory, free the
-- memory allocated.
Sinput.P.Clear_Source_File_Table;
end;
end if;
if ALI.Sdep.Table (D).Stamp /= Dep_Src.Source_TS then
if Verbose_Mode then
Write_Str
(" -> different time stamp for ");
Write_Line (Get_Name_String (Sfile));
if Debug.Debug_Flag_T then
Write_Str (" in ALI file: ");
Write_Line
(String (ALI.Sdep.Table (D).Stamp));
Write_Str (" actual file: ");
Write_Line (String (Dep_Src.Source_TS));
end if;
end if;
return True;
else
for J in Projects'Range loop
if Dep_Src.Project = Projects (J) then
if Verbose_Mode then
Write_Line
(" -> wrong object directory");
end if;
return True;
end if;
end loop;
exit;
end if;
end if;
Dep_Src := Dep_Src.Next_With_File_Name;
end loop;
-- If the source was not found and the runtime source
-- directory is defined, check if the file exists there, and
-- if it does, check its timestamp.
if not Found
and then
(Runtime_Source_Dir /= No_Name
or else
Is_Absolute_Path (Get_Name_String (Sfile)))
then
Name_Len := 0;
if not Is_Absolute_Path (Get_Name_String (Sfile)) then
Get_Name_String (Runtime_Source_Dir);
Add_Char_To_Name_Buffer (Directory_Separator);
end if;
Add_Str_To_Name_Buffer (Get_Name_String (Sfile));
declare
TS : constant Time_Stamp_Type :=
Source_File_Stamp (Name_Find);
begin
if TS /= Empty_Time_Stamp
and then TS /= ALI.Sdep.Table (D).Stamp
then
if Verbose_Mode then
Write_Str
(" -> different time stamp for ");
Write_Line (Get_Name_String (Sfile));
if Debug.Debug_Flag_T then
Write_Str (" in ALI file: ");
Write_Line
(String (ALI.Sdep.Table (D).Stamp));
Write_Str (" actual file: ");
Write_Line (String (TS));
end if;
end if;
return True;
end if;
end;
end if;
end if;
end loop;
end;
return False;
end Process_ALI_Deps;
package Processed_Sources is new Table.Table
(Table_Component_Type => Prj.Source_Id,
Table_Index_Type => Positive,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Gpr_Util.Processed_ALIs");
------------------------------
-- Process_ALI_Closure_Deps --
------------------------------
function Process_ALI_Closure_Deps return Boolean is
Text : Text_Buffer_Ptr :=
Read_Library_Info_From_Full
(File_Name_Type (Source.Dep_Path),
Source.Dep_TS'Access);
Sfile : File_Name_Type;
Dep_Src : Prj.Source_Id;
Proj : Project_Id;
TS0 : Time_Stamp_Type;
Found : Boolean := False;
Last_Processed_Source : Natural := 0;
Next_Source : Prj.Source_Id;
Insert_Source : Boolean := False;
Other_ALI : ALI.ALI_Id;
begin
if Text = null then
if Verbose_Mode then
Write_Str (" -> cannot read ");
Write_Line (Get_Name_String (Source.Dep_Path));
end if;
return True;
end if;
TS0 := File_Stamp (Source.Dep_Path);
-- Read only the necessary lines of the ALI file
The_ALI :=
ALI.Scan_ALI
(File_Name_Type (Source.Dep_Path),
Text,
Ignore_ED => False,
Err => True,
Ignore_Errors => True,
Read_Lines => "PDW");
Free (Text);
if The_ALI = ALI.No_ALI_Id then
if Verbose_Mode then
Write_Str (" -> ");
Write_Str (Get_Name_String (Source.Dep_Path));
Write_Line (" is incorrectly formatted");
end if;
return True;
end if;
if ALI.ALIs.Table (The_ALI).Compile_Errors then
if Verbose_Mode then
Write_Line (" -> last compilation had errors");
end if;
return True;
end if;
if Object_Check and then ALI.ALIs.Table (The_ALI).No_Object then
if Verbose_Mode then
Write_Line
(" -> no object generated during last compilation");
end if;
return True;
end if;
if Check_Source_Info_In_ALI (The_ALI, Tree) = No_Name then
return True;
end if;
Processed_Sources.Init;
Processed_Sources.Append (Source);
Last_Processed_Source := 2;
-- We need to check that the ALI file is in the correct object
-- directory. If it is in the object directory of a project
-- that is extended and it depends on a source that is in one
-- of its extending projects, then the ALI file is not in the
-- correct object directory.
ALI_Project := Source.Object_Project;
-- Count the extending projects
Num_Ext := 0;
Proj := ALI_Project;
loop
Proj := Proj.Extended_By;
exit when Proj = No_Project;
Num_Ext := Num_Ext + 1;
end loop;
declare
Projects : array (1 .. Num_Ext) of Project_Id;
begin
Proj := ALI_Project;
for J in Projects'Range loop
Proj := Proj.Extended_By;
Projects (J) := Proj;
end loop;
for D in ALI.ALIs.Table (The_ALI).First_Sdep ..
ALI.ALIs.Table (The_ALI).Last_Sdep
loop
Sfile := ALI.Sdep.Table (D).Sfile;
if ALI.Sdep.Table (D).Stamp /= Empty_Time_Stamp then
Dep_Src := Source_Files_Htable.Get
(Tree.Source_Files_HT, Sfile);
Found := False;
if Dep_Src /= No_Source then
Insert_Source := True;
for J in 1 .. Processed_Sources.Last loop
if Processed_Sources.Table (J) = Dep_Src then
Insert_Source := False;
exit;
end if;
end loop;
if Insert_Source then
Processed_Sources.Append (Dep_Src);
end if;
end if;
while Dep_Src /= No_Source loop
Initialize_Source_Record (Dep_Src);
if not Dep_Src.Locally_Removed
and then Dep_Src.Unit /= No_Unit_Index
then
Found := True;
if Opt.Minimal_Recompilation
and then ALI.Sdep.Table (D).Stamp /=
Dep_Src.Source_TS
then
-- If minimal recompilation is in action, replace
-- the stamp of the source file in the table if
-- checksums match.
declare
Source_Index : Source_File_Index;
use Scans;
begin
Source_Index :=
Sinput.C.Load_File
(Get_Name_String
(Dep_Src.Path.Display_Name));
if Source_Index /= No_Source_File then
Scanner.Initialize_Scanner (Source_Index);
-- Make sure that the project language
-- reserved words are not recognized as
-- reserved words, but as identifiers.
Set_Name_Table_Byte (Name_Project, 0);
Set_Name_Table_Byte (Name_Extends, 0);
Set_Name_Table_Byte (Name_External, 0);
Set_Name_Table_Byte
(Name_External_As_List, 0);
-- Scan the complete file to compute its
-- checksum.
loop
Scanner.Scan;
exit when Token = Tok_EOF;
end loop;
if Scans.Checksum =
ALI.Sdep.Table (D).Checksum
then
if Verbose_Mode then
Write_Str (" ");
Write_Str
(Get_Name_String
(ALI.Sdep.Table (D).Sfile));
Write_Str (": up to date, " &
"different timestamps " &
"but same checksum");
Write_Eol;
end if;
ALI.Sdep.Table (D).Stamp :=
Dep_Src.Source_TS;
end if;
end if;
-- To avoid using too much memory, free the
-- memory allocated.
Sinput.P.Clear_Source_File_Table;
end;
end if;
if ALI.Sdep.Table (D).Stamp /= Dep_Src.Source_TS then
if Verbose_Mode then
Write_Str
(" -> different time stamp for ");
Write_Line (Get_Name_String (Sfile));
if Debug.Debug_Flag_T then
Write_Str (" in ALI file: ");
Write_Line
(String (ALI.Sdep.Table (D).Stamp));
Write_Str (" actual file: ");
Write_Line (String (Dep_Src.Source_TS));
end if;
end if;
return True;
else
for J in Projects'Range loop
if Dep_Src.Project = Projects (J) then
if Verbose_Mode then
Write_Line
(" -> wrong object directory");
end if;
return True;
end if;
end loop;
exit;
end if;
end if;
Dep_Src := Dep_Src.Next_With_File_Name;
end loop;
-- If the source was not found and the runtime source
-- directory is defined, check if the file exists there, and
-- if it does, check its timestamp.
if not Found and then Runtime_Source_Dir /= No_Name then
Get_Name_String (Runtime_Source_Dir);
Add_Char_To_Name_Buffer (Directory_Separator);
Add_Str_To_Name_Buffer (Get_Name_String (Sfile));
declare
TS1 : constant Time_Stamp_Type :=
Source_File_Stamp (Name_Find);
begin
if TS1 /= Empty_Time_Stamp
and then TS1 /= ALI.Sdep.Table (D).Stamp
then
if Verbose_Mode then
Write_Str
(" -> different time stamp for ");
Write_Line (Get_Name_String (Sfile));
if Debug.Debug_Flag_T then
Write_Str (" in ALI file: ");
Write_Line
(String (ALI.Sdep.Table (D).Stamp));
Write_Str (" actual file: ");
Write_Line (String (TS1));
end if;
end if;
return True;
end if;
end;
end if;
end if;
end loop;
end;
while Last_Processed_Source <= Processed_Sources.Last loop
Next_Source := Processed_Sources.Table (Last_Processed_Source);
Text :=
Read_Library_Info_From_Full
(File_Name_Type (Next_Source.Dep_Path),
Next_Source.Dep_TS'Access);
Last_Processed_Source := Last_Processed_Source + 1;
if Text = null then
if Verbose_Mode then
Write_Str (" -> cannot read ");
Write_Line (Get_Name_String (Next_Source.Dep_Path));
end if;
return True;
end if;
-- Read only the necessary lines of the ALI file
Other_ALI :=
ALI.Scan_ALI
(File_Name_Type (Next_Source.Dep_Path),
Text,
Ignore_ED => False,
Err => True,
Ignore_Errors => True,
Read_Lines => "PDW");
Free (Text);
if Other_ALI = ALI.No_ALI_Id then
if Verbose_Mode then
Write_Str (" -> ");
Write_Str (Get_Name_String (Next_Source.Dep_Path));
Write_Line (" is incorrectly formatted");
end if;
return True;
end if;
if ALI.ALIs.Table (Other_ALI).Compile_Errors then
if Verbose_Mode then
Write_Str (" -> last compilation of ");
Write_Str (Get_Name_String (Next_Source.Dep_Path));
Write_Line (" had errors");
end if;
return True;
end if;
for D in ALI.ALIs.Table (Other_ALI).First_Sdep ..
ALI.ALIs.Table (Other_ALI).Last_Sdep
loop
Sfile := ALI.Sdep.Table (D).Sfile;
if ALI.Sdep.Table (D).Stamp /= Empty_Time_Stamp then
Dep_Src := Source_Files_Htable.Get
(Tree.Source_Files_HT, Sfile);
Found := False;
if Dep_Src /= No_Source then
Insert_Source := True;
for J in 1 .. Processed_Sources.Last loop
if Processed_Sources.Table (J) = Dep_Src then
Insert_Source := False;
exit;
end if;
end loop;
if Insert_Source then
Processed_Sources.Append (Dep_Src);
end if;
end if;
while Dep_Src /= No_Source loop
Initialize_Source_Record (Dep_Src);
if not Dep_Src.Locally_Removed
and then Dep_Src.Unit /= No_Unit_Index
then
Found := True;
if Opt.Minimal_Recompilation
and then ALI.Sdep.Table (D).Stamp /=
Dep_Src.Source_TS
then
-- If minimal recompilation is in action, replace
-- the stamp of the source file in the table if
-- checksums match.
declare
Source_Index : Source_File_Index;
use Scans;
begin
Source_Index :=
Sinput.C.Load_File
(Get_Name_String
(Dep_Src.Path.Display_Name));
if Source_Index /= No_Source_File then
Scanner.Initialize_Scanner (Source_Index);
-- Make sure that the project language
-- reserved words are not recognized as
-- reserved words, but as identifiers.
Set_Name_Table_Byte (Name_Project, 0);
Set_Name_Table_Byte (Name_Extends, 0);
Set_Name_Table_Byte (Name_External, 0);
Set_Name_Table_Byte
(Name_External_As_List, 0);
-- Scan the complete file to compute its
-- checksum.
loop
Scanner.Scan;
exit when Token = Tok_EOF;
end loop;
if Scans.Checksum =
ALI.Sdep.Table (D).Checksum
then
ALI.Sdep.Table (D).Stamp :=
Dep_Src.Source_TS;
end if;
end if;
-- To avoid using too much memory, free the
-- memory allocated.
Sinput.P.Clear_Source_File_Table;
end;
end if;
if ALI.Sdep.Table (D).Stamp /= Dep_Src.Source_TS then
if Verbose_Mode then
Write_Str
(" -> different time stamp for ");
Write_Line (Get_Name_String (Sfile));
if Debug.Debug_Flag_T then
Write_Str (" in ALI file: ");
Write_Line
(String (ALI.Sdep.Table (D).Stamp));
Write_Str (" actual file: ");
Write_Line (String (Dep_Src.Source_TS));
end if;
end if;
return True;
elsif TS0 < Dep_Src.Source_TS then
if Verbose_Mode then
Write_Str (" -> file ");
Write_Str
(Get_Name_String (Dep_Src.Path.Display_Name));
Write_Line (" later than ALI file");
end if;
return True;
end if;
end if;
Dep_Src := Dep_Src.Next_With_File_Name;
end loop;
end if;
end loop;
end loop;
return False;
end Process_ALI_Closure_Deps;
-------------
-- Cleanup --
-------------
procedure Cleanup is
begin
Free (C_Object_Name);
Free (Object_Path);
Free (Switches_Name);
end Cleanup;
begin
The_ALI := ALI.No_ALI_Id;
-- Never attempt to compile header files
if Source.Language.Config.Kind = File_Based
and then Source.Kind = Spec
then
Must_Compile := False;
return;
end if;
if Force_Compilations then
Must_Compile := Always_Compile or else (not Externally_Built);
return;
end if;
-- No need to compile if there is no "compiler"
if Length_Of_Name (Source.Language.Config.Compiler_Driver) = 0 then
Must_Compile := False;
return;
end if;
if Source.Language.Config.Object_Generated and then Object_Check then
C_Object_Name := new String'(Get_Name_String (Source.Object));
Canonical_Case_File_Name (C_Object_Name.all);
Object_Path := new String'(Get_Name_String (Source.Object_Path));
if Source.Switches_Path /= No_Path then
Switches_Name :=
new String'(Get_Name_String (Source.Switches_Path));
end if;
end if;
if Verbose_Mode and then Verbosity_Level > Opt.Low then
Write_Str (" Checking ");
Write_Str (Source_Path);
if Source.Index /= 0 then
Write_Str (" at ");
Write_Int (Source.Index);
end if;
Write_Line (" ... ");
end if;
-- No need to compile if project is externally built
if Externally_Built then
if Verbose_Mode then
Write_Line (" project is externally built");
end if;
Must_Compile := False;
Cleanup;
return;
end if;
if not Source.Language.Config.Object_Generated then
-- If no object file is generated, the "compiler" need to be invoked
-- if there is no dependency file.
if Source.Language.Config.Dependency_Kind = None then
if Verbose_Mode then
Write_Line (" -> no object file generated");
end if;
Must_Compile := True;
Cleanup;
return;
end if;
elsif Object_Check then
-- 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
Write_Str (" -> object file ");
Write_Str (Object_Path.all);
Write_Line (" does not exist");
end if;
Must_Compile := True;
Cleanup;
return;
end if;
-- If the object file has been created before the last modification
-- of the source, the source need to be recompiled.
if (not Opt.Minimal_Recompilation)
and then Source.Object_TS < Source.Source_TS
then
if Verbose_Mode then
Write_Str (" -> object file ");
Write_Str (Object_Path.all);
Write_Line (" has time stamp earlier than source");
end if;
Must_Compile := True;
Cleanup;
return;
end if;
if Verbose_Mode and then Debug.Debug_Flag_T then
Write_Str (" object file ");
Write_Str (Object_Path.all);
Write_Str (": ");
Write_Line (String (Source.Object_TS));
Write_Str (" source file: ");
Write_Line (String (Source.Source_TS));
end if;
end if;
if Source.Language.Config.Dependency_Kind /= None then
-- If there is no dependency file, then the source needs to be
-- recompiled and the dependency file need to be created.
Stamp := File_Time_Stamp (Source.Dep_Path, Source.Dep_TS'Access);
if Stamp = Empty_Time_Stamp then
if Verbose_Mode then
Write_Str (" -> dependency file ");
Write_Str (Get_Name_String (Source.Dep_Path));
Write_Line (" does not exist");
end if;
Must_Compile := True;
Cleanup;
return;
end if;
-- If the ALI file has been created after the object file, we need
-- to recompile.
if Object_Check
and then
(Source.Language.Config.Dependency_Kind = ALI_File
or else Source.Language.Config.Dependency_Kind = ALI_Closure)
and then
Source.Object_TS < Stamp
then
if Verbose_Mode then
Write_Str (" -> ALI file ");
Write_Str (Get_Name_String (Source.Dep_Path));
Write_Line (" has timestamp earlier than object file");
end if;
Must_Compile := True;
Cleanup;
return;
end if;
-- The source needs to be recompiled if the source has been modified
-- after the dependency file has been created.
if not Opt.Minimal_Recompilation
and then Stamp < Source.Source_TS
then
if Verbose_Mode then
Write_Str (" -> dependency file ");
Write_Str (Get_Name_String (Source.Dep_Path));
Write_Line (" has time stamp earlier than source");
end if;
Must_Compile := True;
Cleanup;
return;
end if;
end if;
-- If we are checking the switches and there is no switches file, then
-- the source needs to be recompiled and the switches file need to be
-- created.
if Check_Switches and then Switches_Name /= null then
if Source.Switches_TS = Empty_Time_Stamp then
if Verbose_Mode then
Write_Str (" -> switches file ");
Write_Str (Switches_Name.all);
Write_Line (" does not exist");
end if;
Must_Compile := True;
Cleanup;
return;
end if;
-- The source needs to be recompiled if the source has been modified
-- after the switches file has been created.
if not Opt.Minimal_Recompilation
and then Source.Switches_TS < Source.Source_TS
then
if Verbose_Mode then
Write_Str (" -> switches file ");
Write_Str (Switches_Name.all);
Write_Line (" has time stamp earlier than source");
end if;
Must_Compile := True;
Cleanup;
return;
end if;
end if;
case Source.Language.Config.Dependency_Kind is
when None =>
null;
when Makefile =>
if Process_Makefile_Deps
(Get_Name_String (Source.Dep_Path),
Get_Name_String
(Source.Project.Object_Directory.Display_Name))
then
Must_Compile := True;
Cleanup;
return;
end if;
when ALI_File =>
if Process_ALI_Deps then
Must_Compile := True;
Cleanup;
return;
end if;
when ALI_Closure =>
if Process_ALI_Closure_Deps then
Must_Compile := True;
Cleanup;
return;
end if;
end case;
-- If we are here, then everything is OK, and we don't need
-- to recompile.
if (not Object_Check) and then Verbose_Mode then
Write_Line (" -> up to date");
end if;
Must_Compile := False;
Cleanup;
end Need_To_Compile;
---------------
-- Knowledge --
---------------
package body Knowledge is separate;
---------------
-- Post_Scan --
---------------
procedure Post_Scan is
begin
null;
end Post_Scan;
-------------------
-- Relative_Path --
-------------------
function Relative_Path (Pathname, To : String) return String is
Dir_Sep_Map : constant Character_Mapping := To_Mapping ("\", "/");
P : String (1 .. Pathname'Length) := Pathname;
T : String (1 .. To'Length) := To;
Pi : Natural; -- common prefix ending
N : Natural := 0;
begin
pragma Assert (Is_Absolute_Path (Pathname));
pragma Assert (Is_Absolute_Path (To));
-- Use canonical directory separator
Translate (Source => P, Mapping => Dir_Sep_Map);
Translate (Source => T, Mapping => Dir_Sep_Map);
-- First check for common prefix
Pi := 1;
while Pi < P'Last and then Pi < T'Last and then P (Pi) = T (Pi) loop
Pi := Pi + 1;
end loop;
-- Cut common prefix at a directory separator
while Pi > P'First and then P (Pi) /= '/' loop
Pi := Pi - 1;
end loop;
-- Count directory under prefix in P, these will be replaced by the
-- corresponding number of "..".
N := Count (T (Pi + 1 .. T'Last), "/");
if T (T'Last) /= '/' then
N := N + 1;
end if;
return N * "../" & Ensure_Directory (P (Pi + 1 .. P'Last));
end Relative_Path;
--------------
-- UTC_Time --
--------------
function UTC_Time return Time_Stamp_Type is
Now : constant Time := Clock - Duration (UTC_Time_Offset);
begin
return Time_Stamp_Type (Image (Now, "%Y%m%d%H%M%S"));
end UTC_Time;
----------------
-- Check_Diff --
----------------
function Check_Diff
(Ts1, Ts2 : Time_Stamp_Type; Max_Drift : Duration := 5.0) return Boolean
is
use GNAT.Calendar;
function Get (T : String) return Time is
(Time_Of
(Year => Year_Number'Value (T (T'First .. T'First + 3)),
Month => Month_Number'Value (T (T'First + 4 .. T'First + 5)),
Day => Day_Number'Value (T (T'First + 6 .. T'First + 7)),
Hour => Hour_Number'Value (T (T'First + 8 .. T'First + 9)),
Minute => Minute_Number'Value (T (T'First + 10 .. T'First + 11)),
Second => Second_Number'Value (T (T'First + 12 .. T'First + 13))));
T1 : constant Time := Get (String (Ts1));
T2 : constant Time := Get (String (Ts2));
begin
return abs (T1 - T2) <= Max_Drift;
end Check_Diff;
-------------------
-- To_Time_Stamp --
-------------------
function To_Time_Stamp
(Time : Calendar.Time) return Types.Time_Stamp_Type is
begin
return Time_Stamp_Type (Image (Time, "%Y%m%d%H%M%S"));
end To_Time_Stamp;
end Gpr_Util;
gprbuild-gpl-2014-src/src/gprbuild-compilation-process.adb 0000644 0000767 0000145 00000020446 12323721731 023200 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . C O M P I L A T I O N . P R O C E S S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Containers.Indefinite_Ordered_Maps;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Output; use Output;
with Gpr_Util; use Gpr_Util;
with Gprbuild.Compilation.Result;
with Gprbuild.Compilation.Slave;
package body Gprbuild.Compilation.Process is
use Ada;
package Env_Maps is
new Containers.Indefinite_Ordered_Maps (String, String);
-- A set of key=value
package Prj_Maps is new Containers.Indefinite_Ordered_Maps
(String, Env_Maps.Map, Env_Maps."<", Env_Maps."=");
-- A set of project+language=map
function "<" (Left, Right : Id) return Boolean is
(Left.R_Pid < Right.R_Pid);
package Failures_Slave_Set is
new Containers.Indefinite_Ordered_Maps (Id, String);
function Get_Env (Project : Project_Id; Language : String) return String;
-- Get the environment for a specific project and language
task type Wait_Local;
type Wait_Local_Ref is access Wait_Local;
WL : Wait_Local_Ref;
Local_Process : Shared_Counter;
Environments : Prj_Maps.Map;
Failed_Proc : Failures_Slave_Set.Map;
------------------
-- Create_Local --
------------------
function Create_Local (Pid : Process_Id) return Id is
begin
return Id'(Local, Pid);
end Create_Local;
-------------------
-- Create_Remote --
-------------------
function Create_Remote (Pid : Remote_Id) return Id is
begin
return Id'(Remote, Pid);
end Create_Remote;
---------------------------
-- Get_Maximum_Processes --
---------------------------
function Get_Maximum_Processes return Positive is
begin
return Opt.Maximum_Processes + Slave.Get_Max_Processes;
end Get_Maximum_Processes;
-------------
-- Get_Env --
-------------
function Get_Env (Project : Project_Id; Language : String) return String is
Key : constant String :=
Get_Name_String (Project.Name) & "+" & Language;
Res : Unbounded_String;
begin
if Environments.Contains (Key) then
for C in Environments (Key).Iterate loop
if Res /= Null_Unbounded_String then
Res := Res & Opts_Sep;
end if;
Res := Res & Env_Maps.Key (C) & '=' & Env_Maps.Element (C);
end loop;
end if;
return To_String (Res);
end Get_Env;
-------------------
-- Get_Slave_For --
-------------------
function Get_Slave_For (Pid : Id) return String is
use type Failures_Slave_Set.Cursor;
begin
if Pid.Kind = Local then
return "";
else
declare
Pos : constant Failures_Slave_Set.Cursor := Failed_Proc.Find (Pid);
begin
if Pos = Failures_Slave_Set.No_Element then
return "";
else
return Failures_Slave_Set.Element (Pos);
end if;
end;
end if;
end Get_Slave_For;
----------
-- Hash --
----------
function Hash (Process : Id) return Header_Num is
Modulo : constant Integer := Integer (Header_Num'Last) + 1;
begin
if Process.Kind = Local then
return Header_Num (Pid_To_Integer (Process.Pid) mod Modulo);
else
return Header_Num (Process.R_Pid mod Remote_Id (Modulo));
end if;
end Hash;
-----------
-- Image --
-----------
function Image (Pid : Remote_Id) return String is
N_Img : constant String := Remote_Id'Image (Pid);
begin
return N_Img (N_Img'First + 1 .. N_Img'Last);
end Image;
------------------------
-- Record_Environment --
------------------------
procedure Record_Environment
(Project : Project_Id;
Language : Name_Id;
Name, Value : String)
is
Lang : constant String := Get_Name_String (Language);
Key : constant String := Get_Name_String (Project.Name) & "+" & Lang;
New_Item : Env_Maps.Map;
begin
-- Create new item, variable association
New_Item.Include (Name, Value);
if Environments.Contains (Key) then
if Environments (Key).Contains (Name) then
Environments (Key).Replace (Name, Value);
else
Environments (Key).Insert (Name, Value);
end if;
else
Environments.Insert (Key, New_Item);
end if;
end Record_Environment;
---------------------------
-- Record_Remote_Failure --
---------------------------
procedure Record_Remote_Failure (Pid : Id; Slave : String) is
begin
Failed_Proc.Insert (Pid, Slave);
end Record_Remote_Failure;
---------
-- Run --
---------
function Run
(Executable : String;
Options : GNAT.OS_Lib.Argument_List;
Project : Project_Id;
Obj_Name : String;
Language : String := "";
Dep_Name : String := "";
Output_File : String := "";
Err_To_Out : Boolean := False;
Force_Local : Boolean := False) return Id
is
Env : constant String := Get_Env (Project, Language);
begin
-- Initialize the task waiting for local process only in distributed
-- mode. In standard mode, the process are waited for in the
-- Compilation.Result.Wait procedure.
if Distributed_Mode and then WL = null then
WL := new Wait_Local;
end if;
-- Run locally first, then send jobs to remote slaves. Note that to
-- build remotely we need an output file and a language, if one of
-- this requirement is not fulfilled we just run the process locally.
if Force_Local
or else not Distributed_Mode
or else Local_Process.Count < Opt.Maximum_Processes
or else Output_File /= ""
or else Language = ""
then
Run_Local : declare
P : Id (Local);
begin
Set_Env (Env, Fail => True);
if Output_File = "" then
P.Pid := Non_Blocking_Spawn (Executable, Options);
else
P.Pid := Non_Blocking_Spawn
(Executable, Options, Output_File, Err_To_Out);
end if;
Local_Process.Increment;
return P;
end Run_Local;
else
return Slave.Run
(Project, Language, Options, Obj_Name, Dep_Name, Env);
end if;
end Run;
----------------
-- Wait_Local --
----------------
task body Wait_Local is
Pid : Process_Id;
Status : Boolean;
begin
loop
Local_Process.Wait_Non_Zero;
Wait_Process (Pid, Status);
Local_Process.Decrement;
Result.Add (Id'(Local, Pid), Status);
end loop;
exception
when E : others =>
Write_Line (Exception_Information (E));
OS_Exit (1);
end Wait_Local;
end Gprbuild.Compilation.Process;
gprbuild-gpl-2014-src/src/gprbuild-compilation.adb 0000644 0000767 0000145 00000010367 12323721731 021525 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . C O M P I L A T I O N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2012-2013, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Text_IO;
with Ada.Environment_Variables; use Ada;
with Ada.Strings.Fixed;
with GNAT.MD5; use GNAT;
with GNAT.String_Split; use GNAT.String_Split;
package body Gprbuild.Compilation is
Last_Env_MD5 : MD5.Message_Digest := (others => <>);
-- Keep last environement variable set to avoid too many system calls.
-- ??? Ideally, we should set them when spawning the process, in
-- which case it would be less expensive to set and could be set
-- every time.
-------------
-- Set_Env --
-------------
procedure Set_Env
(Env : String;
Fail : Boolean;
Force : Boolean := False)
is
Env_List : Slice_Set;
begin
Create (Env_List, Env, String'(1 => Opts_Sep));
for K in 1 .. Slice_Count (Env_List) loop
declare
Var : constant String := Slice (Env_List, K);
I : constant Natural := Strings.Fixed.Index (Var, "=");
Sum : constant MD5.Message_Digest := MD5.Digest (Var);
begin
if I /= 0 then
if Force or else Last_Env_MD5 /= Sum then
Environment_Variables.Set
(Name => Var (Var'First .. I - 1),
Value => Var (I + 1 .. Var'Last));
Last_Env_MD5 := Sum;
end if;
elsif Var'Length > 0 then
-- This is a protocol error, we do not want to fail here as
-- this routine is used by gprslave. This error message should
-- never been displayed anyway.
Text_IO.Put_Line
("wrong environment variable, missing '=' : " & Var);
if Fail then
OS_Exit (1);
end if;
end if;
end;
end loop;
end Set_Env;
--------------------
-- Shared_Counter --
--------------------
protected body Shared_Counter is
-----------
-- Count --
-----------
function Count return Natural is
begin
return Counter;
end Count;
---------------
-- Decrement --
---------------
procedure Decrement is
begin
Counter := Counter - 1;
end Decrement;
---------------
-- Increment --
---------------
procedure Increment is
begin
Counter := Counter + 1;
end Increment;
-----------
-- Reset --
-----------
procedure Reset is
begin
Counter := 0;
end Reset;
-------------------
-- Wait_Non_Zero --
-------------------
entry Wait_Non_Zero when Counter /= 0 is
begin
null;
end Wait_Non_Zero;
end Shared_Counter;
end Gprbuild.Compilation;
gprbuild-gpl-2014-src/src/gprinstall-db.ads 0000644 0000767 0000145 00000003156 12323721731 020162 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R I N S T A L L . D B --
-- --
-- S p e c --
-- --
-- Copyright (C) 2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
package Gprinstall.DB is
procedure List;
end Gprinstall.DB;
gprbuild-gpl-2014-src/src/gprbuild-compilation-sync.ads 0000644 0000767 0000145 00000005504 12323721731 022515 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . C O M P I L A T I O N . S L A V E --
-- --
-- B o d y --
-- --
-- Copyright (C) 2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- Synchronize data to/from the slave. The usage is:
--
-- 1. call To_Slave or From_Slave for every slave to be synchronise
-- 2. call Wait to wait for the synchronization to be terminated
with Gprbuild.Compilation.Protocol;
private package Gprbuild.Compilation.Sync is
procedure To_Slave
(Sync : Protocol.Sync_Kind;
Channel : Protocol.Communication_Channel;
Project_Name : String;
Root_Dir : String;
Slave_Root_Dir : String;
User : String;
Host : String;
Excluded_Patterns : Str_Vect.Vector;
Included_Patterns : Str_Vect.Vector);
-- Synchronize from from the build master to the slave depending on the
-- Sync method.
procedure From_Slave
(Sync : Protocol.Sync_Kind;
Project_Name : String;
Root_Dir : String;
Slave_Root_Dir : String;
User : String;
Host : String;
Included_Artifact_Patterns : Str_Vect.Vector);
-- Synchronize from the slave to the build master depending on the Sync
-- method.
procedure Wait;
-- Wait for all synchronization to be terminated
end Gprbuild.Compilation.Sync;
gprbuild-gpl-2014-src/src/gprlib.adb 0000644 0000767 0000145 00000231030 12323721731 016650 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R L I B --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006-2013, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- gprlib is called by gprmake to build the library for a library project
-- file. gprlib gets it parameters from a text file and give back results
-- through the same text file.
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with ALI;
with Csets;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Gpr_Util; use Gpr_Util;
with Gprexch; use Gprexch;
with Hostparm;
with Makeutl; use Makeutl;
with Namet; use Namet;
with Opt; use Opt;
with Osint;
with Prj; use Prj;
with Snames;
with Switch; use Switch;
with System.Case_Util; use System.Case_Util;
with Table;
with Tempdir;
with Types; use Types;
procedure Gprlib is
Shared_Libgnat_Separator : Character := '-';
-- Character between "-lgnat" or "-lgnarl" and the toolchain version.
-- It is not a constant because it is changed to '_' on VMS.
Size : Natural;
Partial_Number : Natural;
First_Object : Natural;
Last_Object : Natural;
Gcc_Name : constant String := "gcc";
Preserve : Attribute := Time_Stamps;
-- Used by Copy_ALI_Files. Changed to None for OpenVMS, because
-- Copy_Attributes always fails on VMS.
Object_Suffix : constant String := Get_Target_Object_Suffix.all;
-- The suffix of object files on this platform
-- Switches used when spawning processes
No_Main_String : constant String := "-n";
No_Main : constant String_Access := new String'(No_Main_String);
Output_Switch_String : constant String := "-o";
Output_Switch : constant String_Access :=
new String'(Output_Switch_String);
No_Warning_String : constant String := "-gnatws";
No_Warning : constant String_Access := new String'(No_Warning_String);
Auto_Initialize_String : constant String := "-a";
Auto_Initialize : constant String_Access :=
new String'(Auto_Initialize_String);
IO_File : File_Type;
-- The file to get the inputs and to put the results
Line : String (1 .. 1_000);
Last : Natural;
Exchange_File_Name : String_Access;
-- Name of the exchange file
GNAT_Version : String_Access := new String'("000");
-- The version of GNAT, coming from the Toolchain_Version for Ada
GNAT_Version_Set : Boolean := False;
-- True when the toolchain version is in the input exchange file
S_Osinte_Ads : File_Name_Type := No_File;
-- Name_Id for "s-osinte.ads"
S_Dec_Ads : File_Name_Type := No_File;
-- Name_Id for "dec.ads"
G_Trasym_Ads : File_Name_Type := No_File;
-- Name_Id for "g-trasym.ads"
Libgnat : String_Access := new String'("-lgnat");
Libgnarl : String_Access := new String'("-lgnarl");
Libgnarl_Needed : Boolean := False;
-- True if libgnarl is needed
Runtime_Library_Dir : String_Access := null;
-- Full path name of the Ada runtime library
Current_Section : Library_Section := No_Library_Section;
-- The current section when reading the exchange file
No_Std_Lib_String : constant String := "-nostdlib";
Use_GNAT_Lib : Boolean := True;
-- Set to False when "-nostdlib" is in the library options. When False,
-- a shared library is not linked with the GNAT libraries.
Standalone : Prj.Standalone := No;
-- True when building a stand-alone library
Copy_ALI : Boolean := True;
-- Set to False if the ALI (dep files) are not to be copied into the
-- library directory. This is the case for aggregate libraries, the
-- dependencies are stored into the ALI directory of their corresponding
-- projects.
Library_Path_Name : String_Access;
-- Path name of the library file
package Object_Files is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Gprlib.Object_Files");
-- A table to store the object files of the library
Last_Object_File_Index : Natural := 0;
-- Index of the last object file in the Object_Files table. When building
-- a Stand Alone Library, the binder generated object file will be added
-- in the Object_Files table.
package Options_Table is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Gprlib.Options_Table");
-- A table to store the options from the exchange file
package Imported_Library_Directories is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Gprlib.Imported_Library_Directories");
-- A table to store the directories of the imported libraries
package Imported_Library_Names is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Gprlib.Imported_Library_Names");
-- A table to store the names of the imported libraries
package ALIs is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 50,
Table_Increment => 100,
Table_Name => "Gprlib.Alis");
-- A table to store all of the ALI files
package Interface_ALIs is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 50,
Table_Increment => 100,
Table_Name => "Gprlib.Interface_Alis");
-- A table to store the ALI files of the interfaces of an SAL
package Other_Interfaces is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 50,
Table_Increment => 100,
Table_Name => "Gprlib.Other_Interfaces");
-- A table to store the interface files other than the ALI files
package Binding_Options_Table is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 5,
Table_Increment => 100,
Table_Name => "Gprlib.Binding_Options_Table");
-- A table to store the binding options
package Leading_Library_Options_Table is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Gprlib.Leading_Library_Options_Table");
-- A table to store the leading library options from the exchange file
package Library_Options_Table is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 5,
Table_Increment => 100,
Table_Name => "Gprlib.Library_Options_Table");
-- A table to store the library options
package Library_Rpath_Options_Table is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 5,
Table_Increment => 100,
Table_Name => "Gprlib.Library_Rpath_Options_Table");
-- A table to store the library rpath options
package Library_Switches_Table is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 5,
Table_Increment => 100,
Table_Name => "Gprlib.Library_Switches_Table");
-- A table to store the switches for the imported libraries
package Object_Directories is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 2,
Table_Increment => 100,
Table_Name => "Gprlib.Object_Directories");
-- A table to store the object directories of the project and of all
-- the projects it extends.
package Sources is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 2,
Table_Increment => 100,
Table_Name => "Gprlib.Sources");
package Generated_Sources is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 2,
Table_Increment => 100,
Table_Name => "Gprlib.Generated_Sources");
package Generated_Objects is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 2,
Table_Increment => 100,
Table_Name => "Gprlib.Generated_Objects");
package Ada_Leading_Switches is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 2,
Table_Increment => 100,
Table_Name => "Gprlib.Ada_Leading_Switches");
package Ada_Trailing_Switches is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 2,
Table_Increment => 100,
Table_Name => "Gprlib.Ada_Trailing_Switches");
Current_Language : Name_Id := No_Name;
Language_Equal : constant String := "language=";
Auto_Init : Boolean := False;
-- True when a SAL is auto initializable
Static : Boolean := False;
-- True if the library is an archive
No_Create : Boolean := False;
-- Should the library (static or dynamic) be built
Archive_Builder : String_Access := null;
-- Name of the archive builder
AB_Options : String_List_Access := new String_List (1 .. 10);
Last_AB_Option : Natural := 0;
-- Options of the archive builder
First_AB_Object_Pos : Natural;
Next_AB_Object_Pos : Natural;
Object_Pos : Natural;
-- Various indexes in AB_Options used when building an archive in chunks
AB_Append_Options : String_List_Access := new String_List (1 .. 10);
Last_AB_Append_Option : Natural := 0;
-- Options for appending to an archive
Archive_Indexer : String_Access := null;
-- Name of the archive indexer
AI_Options : String_List_Access := new String_List (1 .. 10);
Last_AI_Option : Natural := 0;
-- Options of the archive indexer
Partial_Linker : String_Access := null;
-- Name of the library partial linker
PL_Options : String_List_Access := new String_List (1 .. 10);
Last_PL_Option : Natural := 0;
-- Options of the library partial linker
Partial_Linker_Path : String_Access;
-- The path to the partial linker driver
Archive_Suffix : String_Access := new String'(".a");
Bind_Options : String_List_Access := new String_List (1 .. 10);
Last_Bind_Option : Natural := 0;
Success : Boolean;
Relocatable : Boolean := False;
Library_Name : String_Access := null;
Library_Directory : String_Access := null;
Library_Dependency_Directory : String_Access := null;
Library_Version : String_Access := new String'("");
Library_Version_Path : String_Access := new String'("");
Symbolic_Link_Supported : Boolean := False;
Major_Minor_Id_Supported : Boolean := False;
PIC_Option : String_Access := null;
package Library_Version_Options is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 2,
Table_Increment => 100,
Table_Name => "Gprlib.Library_Version_Options");
Shared_Lib_Prefix : String_Access := new String'("lib");
Shared_Lib_Suffix : String_Access := new String'(".so");
package Shared_Lib_Minimum_Options is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 2,
Table_Increment => 100,
Table_Name => "Gprlib.Shared_Lib_Minimum_Options");
Copy_Source_Directory : String_Access := null;
Driver_Name : Name_Id := No_Name;
Gnatbind_Name : String_Access := Osint.Program_Name ("gnatbind", "gprlib");
Gnatbind_Path : String_Access;
Compiler_Name : String_Access := Osint.Program_Name ("gcc", "gprlib");
Compiler_Path : String_Access;
Path_Option : String_Access := null;
Separate_Run_Path_Options : Boolean := False;
Rpath : String_List_Access := null;
-- Allocated only if Path Option is supported
Initial_Rpath_Length : constant := 4;
-- Initial size of Rpath, when first allocated
Rpath_Last : Natural := 0;
-- Index of last directory in Rpath
Rpath_Length : Natural := 0;
-- Length of the full run path option
Install_Name : String_Access := null;
Arguments : String_List_Access := new String_List (1 .. 20);
Last_Arg : Natural := 0;
Argument_Length : Natural := 0;
-- Response Files
Max_Command_Line_Length : Natural := 0;
Resp_File_Format : Prj.Response_File_Format := Prj.None;
Response_File_Switches : String_List_Access := new String_List (1 .. 0);
Delete_Response_File : Boolean := True;
procedure Add_Arg (Arg : String_Access);
-- Add one argument to the Arguments list. Increase the size of the list
-- if necessary.
procedure Add_Rpath (Path : String);
procedure Add_Rpath (Path : String_Access);
-- Add a path name to Rpath
procedure Copy_ALI_Files;
-- Copy the ALI files. For not SALs, copy all the ALI files. For SALs,
-- only copy the interface ALI files, marking them with the special
-- indicator "SL" on the P line.
procedure Copy_Sources;
-- Copy to the Copy_Source_Directory the sources of the interfaces of
-- a Stand-Alone Library.
function SALs_Use_Constructors return Boolean;
-- Indicate if Stand-Alone Libraries are automatically initialized using
-- the constructor mechanism.
procedure Build_Shared_Lib;
procedure Build_Shared_Lib is separate;
-------------
-- Add_Arg --
-------------
procedure Add_Arg (Arg : String_Access) is
begin
if Last_Arg = Arguments'Last then
-- Double the size of Arguments
declare
New_Args : constant String_List_Access :=
new String_List (1 .. 2 * Last_Arg);
begin
New_Args (Arguments'Range) := Arguments.all;
Arguments := New_Args;
end;
end if;
Last_Arg := Last_Arg + 1;
Arguments (Last_Arg) := Arg;
Argument_Length := Argument_Length + Arg'Length + 1;
end Add_Arg;
---------------
-- Add_Rpath --
---------------
procedure Add_Rpath (Path : String) is
begin
if Path'Length /= 0 then
Add_Rpath (new String'(Path));
end if;
end Add_Rpath;
procedure Add_Rpath (Path : String_Access) is
procedure Double;
-- Double Rpath size
------------
-- Double --
------------
procedure Double is
New_Rpath : constant String_List_Access :=
new String_List (1 .. 2 * Rpath'Length);
begin
New_Rpath (1 .. Rpath_Last) := Rpath (1 .. Rpath_Last);
for J in 1 .. Rpath_Last loop
Rpath (J) := null;
end loop;
Free (Rpath);
Rpath := New_Rpath;
end Double;
-- Start of processing for Add_Rpath
begin
-- If first path, allocate initial Rpath
if Rpath = null then
Rpath := new String_List (1 .. Initial_Rpath_Length);
Rpath_Last := 1;
Rpath_Length := 0;
else
-- Check if the directory is already there
for J in 1 .. Rpath_Last loop
if Rpath (J).all = Path.all then
-- Nothing to do if the directory is already in Rpath
return;
end if;
end loop;
-- Otherwise, double Rpath if it is full
if Rpath_Last = Rpath'Last then
Double;
end if;
Rpath_Last := Rpath_Last + 1;
Rpath_Length := Rpath_Length + 1;
end if;
-- Add the path name
Rpath (Rpath_Last) := Path;
Rpath_Length := Rpath_Length + Path'Length;
end Add_Rpath;
--------------------
-- Copy_ALI_Files --
--------------------
procedure Copy_ALI_Files is
Success : Boolean := False;
FD : File_Descriptor;
Len : Integer;
Actual_Len : Integer;
S : String_Access;
Curr : Natural;
P_Line_Found : Boolean;
Status : Boolean;
begin
if Standalone = No then
for Index in 1 .. ALIs.Last loop
declare
Destination : constant String :=
Library_Dependency_Directory.all &
Directory_Separator &
Base_Name (ALIs.Table (Index).all);
Disregard : Boolean;
pragma Warnings (Off, Disregard);
begin
if Is_Regular_File (Destination) then
Set_Writable (Destination);
Delete_File (Destination, Disregard);
end if;
end;
if Verbose_Mode then
Put ("Copying ");
Put (ALIs.Table (Index).all);
Put_Line (" to library dependency directory");
end if;
declare
ALI_File : constant String := ALIs.Table (Index).all;
begin
if Is_Regular_File (ALI_File) then
Copy_File
(ALI_File,
Library_Dependency_Directory.all,
Success,
Mode => Overwrite,
Preserve => Preserve);
else
Success := False;
end if;
end;
exit when not Success;
end loop;
else
for Index in 1 .. Interface_ALIs.Last loop
declare
File_Name : String :=
Base_Name (Interface_ALIs.Table (Index).all);
Destination : constant String :=
Library_Dependency_Directory.all &
Directory_Separator &
File_Name;
Disregard : Boolean;
pragma Warnings (Off, Disregard);
begin
if Is_Regular_File (Destination) then
Set_Writable (Destination);
Delete_File (Destination, Disregard);
end if;
if Verbose_Mode then
Put ("Copying ");
Put (Interface_ALIs.Table (Index).all);
Put_Line (" to library dependency directory");
end if;
Osint.Canonical_Case_File_Name (File_Name);
-- Open the file
Name_Len := Interface_ALIs.Table (Index)'Length;
Name_Buffer (1 .. Name_Len) :=
Interface_ALIs.Table (Index).all;
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.NUL;
FD := Open_Read (Name_Buffer'Address, Binary);
if FD /= Invalid_FD then
Len := Integer (File_Length (FD));
S := new String (1 .. Len + 3);
-- Read the file. Note that the loop is not necessary
-- since the whole file is read at once except on VMS.
Curr := 1;
Actual_Len := Len;
while Actual_Len /= 0 loop
Actual_Len := Read (FD, S (Curr)'Address, Len);
Curr := Curr + Actual_Len;
end loop;
-- We are done with the input file, so we close it
-- (we simply ignore any bad status on the close)
Close (FD, Status);
P_Line_Found := False;
-- Look for the P line. When found, add marker SL at the
-- beginning of the P line.
for Index in 1 .. Len - 3 loop
if (S (Index) = ASCII.LF or else S (Index) = ASCII.CR)
and then S (Index + 1) = 'P'
then
S (Index + 5 .. Len + 3) := S (Index + 2 .. Len);
S (Index + 2 .. Index + 4) := " SL";
P_Line_Found := True;
exit;
end if;
end loop;
if P_Line_Found then
-- Create new modified ALI file
Name_Len := Library_Dependency_Directory'Length;
Name_Buffer (1 .. Name_Len) :=
Library_Dependency_Directory.all;
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Directory_Separator;
Name_Buffer
(Name_Len + 1 .. Name_Len + File_Name'Length) :=
File_Name;
Name_Len := Name_Len + File_Name'Length + 1;
Name_Buffer (Name_Len) := ASCII.NUL;
FD := Create_File (Name_Buffer'Address, Binary);
-- Write the modified text and close the newly
-- created file.
if FD /= Invalid_FD then
Actual_Len := Write (FD, S (1)'Address, Len + 3);
Close (FD, Status);
-- Set Success to True only if the newly
-- created file has been correctly written.
Success := Status and Actual_Len = Len + 3;
if Success then
Set_Read_Only
(Name_Buffer (1 .. Name_Len - 1));
end if;
end if;
end if;
end if;
end;
end loop;
end if;
if not Success then
Osint.Fail ("could not copy ALI files to library directory");
end if;
end Copy_ALI_Files;
------------------
-- Copy_Sources --
------------------
procedure Copy_Sources is
Text : Text_Buffer_Ptr;
The_ALI : ALI.ALI_Id;
Lib_File : File_Name_Type;
First_Unit : ALI.Unit_Id;
Second_Unit : ALI.Unit_Id;
Copy_Subunits : Boolean := False;
use ALI;
procedure Copy (Fname : String);
-- Copy one source of the project to the copy source directory
----------
-- Copy --
----------
procedure Copy (Fname : String) is
Success : Boolean := False;
begin
for Index in 1 .. Sources.Last loop
if Base_Name (Sources.Table (Index).all) = Fname then
if Verbose_Mode then
Put ("Copying ");
Put (Sources.Table (Index).all);
Put_Line (" to copy source directory");
end if;
Copy_File
(Sources.Table (Index).all,
Copy_Source_Directory.all,
Success,
Mode => Overwrite,
Preserve => Preserve);
exit;
end if;
end loop;
end Copy;
begin
for Index in 1 .. Interface_ALIs.Last loop
-- First, load the ALI file
Name_Len := 0;
Add_Str_To_Name_Buffer (Interface_ALIs.Table (Index).all);
Lib_File := Name_Find;
Text := Osint.Read_Library_Info (Lib_File);
The_ALI :=
ALI.Scan_ALI
(Lib_File,
Text,
Ignore_ED => False,
Err => True,
Read_Lines => "UD");
Free (Text);
Second_Unit := ALI.No_Unit_Id;
First_Unit := ALI.ALIs.Table (The_ALI).First_Unit;
Copy_Subunits := True;
-- If there is both a spec and a body, check if they are both needed
if ALI.Units.Table (First_Unit).Utype = ALI.Is_Body then
Second_Unit := ALI.ALIs.Table (The_ALI).Last_Unit;
-- If the body is not needed, then reset First_Unit
if not ALI.Units.Table (Second_Unit).Body_Needed_For_SAL then
First_Unit := ALI.No_Unit_Id;
Copy_Subunits := False;
end if;
elsif ALI.Units.Table (First_Unit).Utype = ALI.Is_Spec_Only then
Copy_Subunits := False;
end if;
-- Copy the file(s) that need to be copied
if First_Unit /= No_Unit_Id then
Copy (Fname =>
Get_Name_String (ALI.Units.Table (First_Unit).Sfile));
end if;
if Second_Unit /= No_Unit_Id then
Copy (Fname =>
Get_Name_String (ALI.Units.Table (Second_Unit).Sfile));
end if;
-- Copy all the separates, if any
if Copy_Subunits then
for Dep in ALI.ALIs.Table (The_ALI).First_Sdep ..
ALI.ALIs.Table (The_ALI).Last_Sdep
loop
if ALI.Sdep.Table (Dep).Subunit_Name /= No_Name then
Copy (Fname => Get_Name_String (Sdep.Table (Dep).Sfile));
end if;
end loop;
end if;
end loop;
for Index in 1 .. Other_Interfaces.Last loop
Copy (Fname => Other_Interfaces.Table (Index).all);
end loop;
end Copy_Sources;
---------------------------
-- SALs_Use_Constructors --
---------------------------
function SALs_Use_Constructors return Boolean is
function C_SALs_Init_Using_Constructors return Integer;
pragma Import (C, C_SALs_Init_Using_Constructors,
"__gnat_sals_init_using_constructors");
begin
return C_SALs_Init_Using_Constructors /= 0;
end SALs_Use_Constructors;
begin
-- Initialize some packages
Csets.Initialize;
Namet.Initialize;
Snames.Initialize;
-- Copy_Attributes always fails on VMS
if Hostparm.OpenVMS then
Preserve := None;
Shared_Libgnat_Separator := '_';
end if;
if Argument_Count /= 1 then
Put_Line ("usage: gprlib ), if it is defined, otherwise in
-- Compiler'Default_Switches (), if it is defined.
procedure Await_Compile
(Source : out Queue.Source_Info;
OK : out Boolean;
Slave : out Unbounded_String);
-- Wait for the end of a compilation and indicate that the object directory
-- is free.
procedure Compilation_Phase
(Main_Project : Project_Id;
Project_Tree : Project_Tree_Ref);
procedure Recursive_Import (Project : Project_Id);
-- Add to table Imports the projects imported by Project, recursively
function Project_Extends
(Extending : Project_Id;
Extended : Project_Id) return Boolean;
-- Returns True if Extending is Extended or is extending Extended directly
-- or indirectly.
function Directly_Imports
(Project : Project_Id;
Imported : Project_Id) return Boolean;
-- Returns True if Project directly withs Imported or a project extending
-- Imported.
procedure Create_Config_File
(For_Project : Project_Id;
Config : Language_Config;
Language : Name_Id);
-- Create a new config file
function Config_File_For
(Project : Project_Id;
Package_Name : Name_Id;
Attribute_Name : Name_Id;
Language : Name_Id) return Path_Name_Type;
-- Returns the name of a config file. Returns No_Name if there is no
-- config file.
procedure Create_Object_Path_File (Project : Project_Id);
-- Create a temporary file that contains the list of object directories
-- in the correct order.
function "<" (Left, Right : Source_Id) return Boolean
is (Left.File < Right.File);
package Bad_Compilations_Set is new
Containers.Indefinite_Ordered_Maps (Source_Id, String);
Bad_Compilations : Bad_Compilations_Set.Map;
-- Records bad compilation with the given slave name if any
Outstanding_Compiles : Natural := 0;
-- The number of compilation jobs currently spawned
Slave_Initialized : Boolean := False;
-- Record wether the remote compilation slaves have been initialized when
-- running in distributed mode.
type Process_Purpose is (Compilation, Dependency);
-- A type to distinguish between compilation jobs and dependency file
-- building jobs.
type Process_Data is record
Process : Id := Invalid_Process;
Source : Queue.Source_Info := Queue.No_Source_Info;
Source_Project : Project_Id := null;
Mapping_File : Path_Name_Type := No_Path;
Purpose : Process_Purpose := Compilation;
Options : String_List_Access := null;
end record;
-- Data recorded for each spawned jobs, compilation of dependency file
-- building.
No_Process_Data : constant Process_Data :=
(Process => Invalid_Process,
Source => Queue.No_Source_Info,
Source_Project => null,
Mapping_File => No_Path,
Purpose => Compilation,
Options => null);
package Compilation_Htable is new GNAT.HTable.Simple_HTable
(Header_Num => Gprbuild.Compilation.Process.Header_Num,
Element => Process_Data,
No_Element => No_Process_Data,
Key => Id,
Hash => Hash,
Equal => "=");
-- Hash table to keep data for all spawned jobs
package Naming_Datas is new Table.Table
(Table_Component_Type => Lang_Naming_Data,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Makegpr.Naming_Datas");
-- Naming data when creating config files
package Imports is new GNAT.HTable.Simple_HTable
(Header_Num => Prj.Header_Num,
Element => Boolean,
No_Element => False,
Key => Project_Id,
Hash => Hash,
Equal => "=");
-- When --direct-import-only is used, contains the project ids a non Ada
-- source is allowed to import source from.
package Included_Sources is new Table.Table
(Table_Component_Type => Source_Id,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Makegpr.Included_Sources");
package Subunits is new Table.Table
(Table_Component_Type => GNAT.OS_Lib.String_Access,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Makegpr.Subunits");
-- A table to store the subunit names when switch --no-split-units ia used
------------------------------
-- Add_Compilation_Switches --
------------------------------
procedure Add_Compilation_Switches (Source : Source_Id) is
Options : Variable_Value;
Is_Default : Boolean;
begin
Makeutl.Get_Switches
(Source, Name_Compiler, Project_Tree, Options, Is_Default);
if Options /= Nil_Variable_Value then
declare
List : String_List_Id := Options.Values;
Element : String_Element;
Option : GNAT.OS_Lib.String_Access;
begin
while List /= Nil_String loop
Element := Project_Tree.Shared.String_Elements.Table (List);
-- Ignore empty options
if Element.Value /= Empty_String then
Option := Get_Option (Element.Value);
Add_Option_Internal_Codepeer
(Value => Option,
To => Compilation_Options,
Display => True);
end if;
List := Element.Next;
end loop;
end;
end if;
end Add_Compilation_Switches;
-------------------
-- Await_Compile --
-------------------
procedure Await_Compile
(Source : out Queue.Source_Info;
OK : out Boolean;
Slave : out Unbounded_String)
is
Process : Id;
Comp_Data : Process_Data;
Language : Language_Ptr;
Config : Language_Config;
begin
loop
Source := Queue.No_Source_Info;
Wait (Process, OK);
if Process = Invalid_Process then
return;
end if;
Comp_Data := Compilation_Htable.Get (Process);
if Comp_Data /= No_Process_Data then
Source := Comp_Data.Source;
Queue.Set_Obj_Dir_Free (Source.Id.Project.Object_Directory.Name);
if Comp_Data.Purpose = Compilation then
if OK then
-- We created a new ALI file, so reset the attributes of
-- the old one.
Source.Id.Dep_TS := Unknown_Attributes;
if Comp_Data.Options /= null
and then Source.Id.Switches_Path /= No_Path
and then Opt.Check_Switches
then
-- First, update the time stamp of the object file
-- that will be written in the switches file.
Source.Id.Object_TS := File_Stamp (Source.Id.Object_Path);
-- Write the switches file, now that we have the
-- updated time stamp for the object file.
declare
File : Text_IO.File_Type;
begin
Create
(File,
Out_File,
Get_Name_String (Source.Id.Switches_Path));
Put_Line (File, String (Source.Id.Object_TS));
for J in Comp_Data.Options'Range loop
Put_Line (File, Comp_Data.Options (J).all);
end loop;
Close (File);
exception
when others =>
Fail_Program
(Source.Tree,
"could not create switches file """ &
Get_Name_String (Source.Id.Switches_Path) & '"');
end;
-- For all languages other than Ada, update the time
-- stamp of the object file as it is written in the
-- global archive dependency file. For all languages,
-- update the time stamp of the object file if it is
-- in a library project.
elsif Source.Id.Language.Config.Dependency_Kind /= ALI_File
or else Source.Id.Project.Library
then
Source.Id.Object_TS := File_Stamp (Source.Id.Object_Path);
end if;
else
Set_Failed_Compilation_Status (Comp_Data.Source_Project);
Slave := To_Unbounded_String (Get_Slave_For (Process));
end if;
Language := Source.Id.Language;
-- If there is a mapping file used, recycle it in the hash
-- table of the language.
if Comp_Data.Mapping_File /= No_Path
and then Language /= No_Language_Index
then
Mapping_Files_Htable.Set
(T => Language.Mapping_Files,
K => Comp_Data.Mapping_File,
E => Comp_Data.Mapping_File);
end if;
Config := Language.Config;
if Config.Dependency_Kind = Makefile
and then Config.Compute_Dependency /= No_Name_List
then
declare
Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
List : Name_List_Index :=
Config.Compute_Dependency;
Nam : Name_Node :=
Source.Tree.Shared.Name_Lists.Table (List);
Exec_Name : constant String :=
Get_Name_String (Nam.Name);
Exec_Path : OS_Lib.String_Access;
begin
Change_Dir
(Get_Name_String
(Source.Id.Project.Object_Directory.Display_Name));
Comp_Data.Mapping_File := No_Path;
Comp_Data.Purpose := Dependency;
-- ??? We search for it on the PATH for every file,
-- this is very inefficient
Exec_Path := Locate_Exec_On_Path (Exec_Name);
if Exec_Path = null then
Fail_Program
(Source.Tree,
"unable to find dependency builder " & Exec_Name);
end if;
List := Nam.Next;
Compilation_Options.Last := 0;
if List = No_Name_List then
Name_Len := 0;
else
loop
Nam := Source.Tree.Shared.Name_Lists.Table (List);
List := Nam.Next;
if List = No_Name_List then
Get_Name_String (Nam.Name);
exit;
end if;
Add_Option
(Nam.Name, Compilation_Options, Opt.Verbose_Mode);
end loop;
end if;
Add_Str_To_Name_Buffer
(Get_Name_String (Source.Id.Path.Display_Name));
Add_Option
(Name_Buffer (1 .. Name_Len),
Compilation_Options,
Opt.Verbose_Mode,
Simple_Name => not Opt.Verbose_Mode);
if not Opt.Quiet_Output then
if Opt.Verbose_Mode then
Write_Str (Exec_Path.all);
else
Write_Str (Exec_Name);
end if;
Write_Str (" ");
for Option in 1 .. Compilation_Options.Last loop
if Compilation_Options.Visible (Option) then
Write_Str
(Compilation_Options.Options (Option).all);
Write_Str (" ");
end if;
end loop;
Write_Eol;
end if;
Comp_Data.Process :=
Run
(Executable => Exec_Path.all,
Options =>
Compilation_Options.Options
(1 .. Compilation_Options.Last),
Project => Comp_Data.Source_Project,
Obj_Name => Get_Name_String (Source.Id.Object),
Output_File => Get_Name_String (Source.Id.Dep_Path),
Err_To_Out => True,
Force_Local => True);
Compilation_Htable.Set (Comp_Data.Process, Comp_Data);
Free (Exec_Path);
Change_Dir (Current_Dir);
end;
else
Outstanding_Compiles := Outstanding_Compiles - 1;
return;
end if;
elsif Comp_Data.Purpose = Dependency then
Outstanding_Compiles := Outstanding_Compiles - 1;
return;
end if;
end if;
end loop;
end Await_Compile;
---------------------
-- Config_File_For --
---------------------
function Config_File_For
(Project : Project_Id;
Package_Name : Name_Id;
Attribute_Name : Name_Id;
Language : Name_Id) return Path_Name_Type
is
function Absolute_Path
(Path : Path_Name_Type;
Project : Project_Id) return Path_Name_Type;
-- Returns an absolute path for a config file
-------------------
-- Absolute_Path --
-------------------
function Absolute_Path
(Path : Path_Name_Type;
Project : Project_Id) return Path_Name_Type
is
begin
Get_Name_String (Path);
if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then
Get_Name_String (Project.Directory.Display_Name);
if Name_Buffer (Name_Len) /= Directory_Separator then
Add_Char_To_Name_Buffer (Directory_Separator);
end if;
Add_Str_To_Name_Buffer (Get_Name_String (Path));
end if;
return Name_Find;
end Absolute_Path;
Config_Package : constant Package_Id :=
Value_Of
(Name => Package_Name,
In_Packages => Project.Decl.Packages,
Shared => Project_Tree.Shared);
Config_Variable : Variable_Value :=
Value_Of
(Name => Language,
Attribute_Or_Array_Name => Attribute_Name,
In_Package => Config_Package,
Shared => Project_Tree.Shared);
begin
-- Get the config pragma attribute when the language is Ada and the
-- config file attribute is not declared.
if Config_Variable = Nil_Variable_Value
and then Config_Package /= No_Package
and then Language = Name_Ada
then
if Attribute_Name = Name_Global_Config_File then
Config_Variable :=
Value_Of
(Variable_Name => Name_Global_Configuration_Pragmas,
In_Variables => Project_Tree.Shared.Packages.Table
(Config_Package).Decl.Attributes,
Shared => Project_Tree.Shared);
elsif Attribute_Name = Name_Local_Config_File then
Config_Variable :=
Value_Of
(Variable_Name => Name_Local_Configuration_Pragmas,
In_Variables => Project_Tree.Shared.Packages.Table
(Config_Package).Decl.Attributes,
Shared => Project_Tree.Shared);
end if;
end if;
if Config_Variable = Nil_Variable_Value then
return No_Path;
else
Get_Name_String (Config_Variable.Value);
if Name_Len = 0 then
return No_Path;
else
return
Absolute_Path
(Path_Name_Type (Config_Variable.Value),
Config_Variable.Project);
end if;
end if;
end Config_File_For;
------------------------
-- Create_Config_File --
------------------------
procedure Create_Config_File
(For_Project : Project_Id;
Config : Language_Config;
Language : Name_Id)
is
File_Name : Path_Name_Type := No_Path;
File : File_Descriptor := Invalid_FD;
Source : Source_Id;
Iter : Source_Iterator;
procedure Check
(Project : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Boolean);
-- Check the naming schemes of the different projects of the project
-- tree. For each different naming scheme issue the pattern config
-- declarations.
procedure Check_Temp_File;
-- Check if a temp file has been created. If not, create one
procedure Copy_Config_File
(Project : Project_Id;
Package_Name : Name_Id;
Attribute_Name : Name_Id;
Language : Name_Id);
-- If a specified config file exists, copy it in the temporary config
-- file.
procedure Put_Line (File : File_Descriptor; S : String);
-- Output procedure, analogous to normal Text_IO proc of same name
-----------
-- Check --
-----------
procedure Check
(Project : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Boolean)
is
pragma Unreferenced (Dummy, Tree);
Lang_Id : Language_Ptr := Project.Languages;
Current_Naming : Positive := 1;
procedure Replace;
-------------
-- Replace --
-------------
procedure Replace is
Cur : Positive := 1;
procedure Substitute (N : File_Name_Type);
procedure Substitute (Name : String);
----------------
-- Substitute --
----------------
procedure Substitute (N : File_Name_Type) is
begin
if N = No_File then
Cur := Cur + 1;
else
Substitute (Get_Name_String (N));
end if;
end Substitute;
procedure Substitute (Name : String) is
begin
Name_Buffer
(Cur + Name'Length .. Name_Len - 2 + Name'Length) :=
Name_Buffer (Cur + 2 .. Name_Len);
Name_Buffer (Cur .. Cur + Name'Length - 1) := Name;
Name_Len := Name_Len - 2 + Name'Length;
Cur := Cur + Name'Length;
end Substitute;
begin
while Cur < Name_Len loop
if Name_Buffer (Cur) = '%' then
case Name_Buffer (Cur + 1) is
when 'b' =>
Substitute (Lang_Id.Config.Naming_Data.Body_Suffix);
when 's' =>
Substitute (Lang_Id.Config.Naming_Data.Spec_Suffix);
when 'd' =>
Substitute
(Lang_Id.Config.Naming_Data.Dot_Replacement);
when 'c' =>
Substitute
(Image (Lang_Id.Config.Naming_Data.Casing));
when '%' =>
Name_Buffer (Cur .. Name_Len - 1) :=
Name_Buffer (Cur + 1 .. Name_Len);
Name_Len := Name_Len - 1;
Cur := Cur + 1;
when others =>
Cur := Cur + 1;
end case;
else
Cur := Cur + 1;
end if;
end loop;
end Replace;
begin
if Current_Verbosity = High then
Write_Str ("Checking project file """);
Write_Str (Namet.Get_Name_String (Project.Name));
Write_Str (""".");
Write_Eol;
end if;
while Lang_Id /= No_Language_Index loop
exit when Lang_Id.Name = Language;
Lang_Id := Lang_Id.Next;
end loop;
if Lang_Id /= No_Language_Index then
Current_Naming := Naming_Datas.First;
while Current_Naming <= Naming_Datas.Last loop
exit when Naming_Datas.Table (Current_Naming) =
Lang_Id.Config.Naming_Data;
Current_Naming := Current_Naming + 1;
end loop;
if Current_Naming > Naming_Datas.Last then
Naming_Datas.Increment_Last;
Naming_Datas.Table (Naming_Datas.Last) :=
Lang_Id.Config.Naming_Data;
Check_Temp_File;
if Lang_Id.Config.Config_Spec_Pattern /= No_Name then
Get_Name_String (Lang_Id.Config.Config_Spec_Pattern);
Replace;
Put_Line (File, Name_Buffer (1 .. Name_Len));
end if;
if Lang_Id.Config.Config_Body_Pattern /= No_Name then
Get_Name_String (Lang_Id.Config.Config_Body_Pattern);
Replace;
Put_Line (File, Name_Buffer (1 .. Name_Len));
end if;
end if;
end if;
end Check;
---------------------
-- Check_Temp_File --
---------------------
procedure Check_Temp_File is
begin
if File = Invalid_FD then
Tempdir.Create_Temp_File (File, Name => File_Name);
if File = Invalid_FD then
Fail_Program
(Project_Tree,
"unable to create temporary configuration pragmas file");
else
Record_Temp_File (Project_Tree.Shared, File_Name);
if Opt.Verbose_Mode and then Opt.Verbosity_Level > Opt.Low then
Write_Str ("Creating temp file """);
Write_Str (Get_Name_String (File_Name));
Write_Line ("""");
end if;
end if;
end if;
end Check_Temp_File;
----------------------
-- Copy_Config_File --
----------------------
procedure Copy_Config_File
(Project : Project_Id;
Package_Name : Name_Id;
Attribute_Name : Name_Id;
Language : Name_Id)
is
Config_File_Path : constant Path_Name_Type :=
Config_File_For
(Project, Package_Name,
Attribute_Name, Language);
Config_File : Text_IO.File_Type;
Line : String (1 .. 1_000);
Last : Natural;
begin
if Config_File_Path /= No_Path then
begin
Open (Config_File, In_File, Get_Name_String (Config_File_Path));
exception
when others =>
Fail_Program
(Project_Tree,
"unable to open config file "
& Get_Name_String (Config_File_Path));
end;
Check_Temp_File;
while not End_Of_File (Config_File) loop
Get_Line (Config_File, Line, Last);
Put_Line (File, Line (1 .. Last));
end loop;
Close (Config_File);
end if;
end Copy_Config_File;
--------------
-- Put_Line --
--------------
procedure Put_Line (File : File_Descriptor; S : String) is
S0 : String (1 .. S'Length + 1);
Last : Natural;
begin
-- Add an ASCII.LF to the string. As this config file is supposed to
-- be used only by the compiler, we don't care about the characters
-- for the end of line. In fact we could have put a space, but
-- it is more convenient to be able to read gnat.adc during
-- development, for which the ASCII.LF is fine.
S0 (1 .. S'Length) := S;
S0 (S0'Last) := ASCII.LF;
Last := Write (File, S0'Address, S0'Length);
if Last /= S'Length + 1 then
Fail_Program (Project_Tree, "Disk full");
end if;
if Current_Verbosity = High then
Write_Line (S);
end if;
end Put_Line;
procedure Check_All_Projects is
new For_Every_Project_Imported (Boolean, Check);
Dummy : Boolean := False;
-- Start of processing for Create_Config_File
begin
-- Nothing to do if config has already been checked
if For_Project.Config_Checked then
return;
end if;
if Config.Config_File_Unique then
-- Copy an eventual global config file
Copy_Config_File
(Main_Project, Name_Builder, Name_Global_Config_File, Language);
-- Copy an eventual local config file
Copy_Config_File
(For_Project, Name_Compiler, Name_Local_Config_File, Language);
end if;
For_Project.Config_Checked := True;
Naming_Datas.Init;
Check_All_Projects (For_Project, Project_Tree, Dummy);
-- Visit all the units and issue the config declarations for those that
-- need one.
Iter := For_Each_Source (Project_Tree);
loop
Source := Prj.Element (Iter);
exit when Source = No_Source;
if Source.Language.Name = Language
and then Source.Naming_Exception /= No
and then Source.Unit /= No_Unit_Index
and then not Source.Locally_Removed
and then Source.Replaced_By = No_Source
then
Name_Len := 0;
if Source.Kind = Spec then
if Source.Index = 0 and then Config.Config_Spec /= No_Name then
Get_Name_String (Config.Config_Spec);
elsif
Source.Index /= 0 and then Config.Config_Spec_Index /= No_Name
then
Get_Name_String (Config.Config_Spec_Index);
end if;
else
if Source.Index = 0 and then Config.Config_Body /= No_Name then
Get_Name_String (Config.Config_Body);
elsif
Source.Index /= 0 and then Config.Config_Body_Index /= No_Name
then
Get_Name_String (Config.Config_Body_Index);
end if;
end if;
if Name_Len /= 0 then
declare
Cur : Positive := 1;
Unit : constant String :=
Get_Name_String (Source.Unit.Name);
File_Name : constant String :=
Get_Name_String (Source.Display_File);
begin
while Cur < Name_Len loop
if Name_Buffer (Cur) /= '%' then
Cur := Cur + 1;
else
case Name_Buffer (Cur + 1) is
when 'u' =>
Name_Buffer
(Cur + Unit'Length ..
Name_Len - 2 + Unit'Length) :=
Name_Buffer (Cur + 2 .. Name_Len);
Name_Buffer (Cur .. Cur + Unit'Length - 1) :=
Unit;
Cur := Cur + Unit'Length;
Name_Len := Name_Len - 2 + Unit'Length;
when 'f' =>
Name_Buffer
(Cur + File_Name'Length ..
Name_Len - 2 + File_Name'Length) :=
Name_Buffer (Cur + 2 .. Name_Len);
Name_Buffer
(Cur .. Cur + File_Name'Length - 1) :=
File_Name;
Cur := Cur + File_Name'Length;
Name_Len := Name_Len - 2 + File_Name'Length;
when 'i' =>
declare
Index_String : constant String :=
Source.Index'Img;
begin
Name_Buffer
(Cur + Index_String'Length ..
Name_Len - 2 + Index_String'Length) :=
Name_Buffer (Cur + 2 .. Name_Len);
Name_Buffer
(Cur .. Cur + Index_String'Length - 1) :=
Index_String;
Cur := Cur + Index_String'Length;
Name_Len :=
Name_Len - 2 + Index_String'Length;
end;
when '%' =>
Name_Buffer (Cur .. Name_Len - 1) :=
Name_Buffer (Cur + 1 .. Name_Len);
Cur := Cur + 1;
Name_Len := Name_Len - 1;
when others =>
Cur := Cur + 1;
end case;
end if;
end loop;
Put_Line (File, Name_Buffer (1 .. Name_Len));
end;
end if;
end if;
Next (Iter);
end loop;
if File /= Invalid_FD then
Close (File);
For_Project.Config_File_Name := File_Name;
end if;
end Create_Config_File;
-----------------------------
-- Create_Object_Path_File --
-----------------------------
procedure Create_Object_Path_File (Project : Project_Id) is
FD : File_Descriptor;
Name : Path_Name_Type;
LF : constant String := (1 => ASCII.LF);
procedure Add
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Dummy : in out Boolean);
-- Add the object directory of a project to the file
---------
-- Add --
---------
procedure Add
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Dummy : in out Boolean)
is
pragma Unreferenced (Dummy, In_Tree);
Path : constant Path_Name_Type :=
Get_Object_Directory
(Project,
Including_Libraries => True,
Only_If_Ada => False);
Last : Natural;
pragma Unreferenced (Last);
begin
if Path /= No_Path then
Get_Name_String (Path);
Last := Write (FD, Name_Buffer (1)'Address, Name_Len);
Last := Write (FD, LF (1)'Address, 1);
end if;
Dummy := True;
end Add;
procedure For_All_Projects is
new For_Every_Project_Imported (Boolean, Add);
Status : Boolean := False;
pragma Warnings (Off, Status);
begin
Tempdir.Create_Temp_File (FD, Name);
Project.Object_Path_File := Name;
For_All_Projects
(Project, Project_Tree, Status, Include_Aggregated => True);
Close (FD, Status);
end Create_Object_Path_File;
----------------------
-- Recursive_Import --
----------------------
procedure Recursive_Import (Project : Project_Id) is
Ext : constant Project_Id := Project.Extends;
L : Project_List := Project.Imported_Projects;
begin
if Ext /= No_Project
and then not Imports.Get (Ext)
then
Imports.Set (Ext, True);
Recursive_Import (Ext);
end if;
while L /= null loop
if not Imports.Get (L.Project) then
Imports.Set (L.Project, True);
Recursive_Import (L.Project);
end if;
L := L.Next;
end loop;
end Recursive_Import;
----------------------
-- Directly_Imports --
----------------------
function Directly_Imports
(Project : Project_Id;
Imported : Project_Id) return Boolean
is
L : Project_List := Project.Imported_Projects;
P : Project_Id;
begin
while L /= null loop
P := L.Project;
while P /= No_Project loop
if Imported = P then
return True;
end if;
P := P.Extends;
end loop;
L := L.Next;
end loop;
return False;
end Directly_Imports;
---------
-- Run --
---------
procedure Run is
procedure Do_Compile (Project : Project_Id; Tree : Project_Tree_Ref);
----------------
-- Do_Compile --
----------------
procedure Do_Compile (Project : Project_Id; Tree : Project_Tree_Ref) is
use type Containers.Count_Type;
begin
if Builder_Data (Tree).Need_Compilation then
Compilation_Phase (Project, Tree);
if Total_Errors_Detected > 0
or else not Bad_Compilations.Is_Empty
then
-- If switch -k or -jnn (with nn > 1), output a summary of the
-- sources that could not be compiled.
if (Opt.Keep_Going or else Get_Maximum_Processes > 1)
and then not Bad_Compilations.Is_Empty
then
Write_Eol;
for Index in Bad_Compilations.Iterate loop
declare
Source : constant Source_Id :=
Bad_Compilations_Set.Key (Index);
Slave : constant String :=
Bad_Compilations_Set.Element (Index);
begin
if Source /= No_Source then
Write_Str (" compilation of ");
Write_Str
(Get_Name_String (Source.Display_File));
Write_Str (" failed");
if Slave /= "" then
Write_Str (" on " & Slave);
end if;
Write_Eol;
end if;
end;
end loop;
Write_Eol;
end if;
if Opt.Keep_Going and then Project.Qualifier = Aggregate then
Bad_Compilations.Clear;
else
if Distributed_Mode and then Slave_Initialized then
Gprbuild.Compilation.Slave.Unregister_Remote_Slaves;
end if;
Fail_Program (Tree, "*** compilation phase failed");
end if;
end if;
end if;
end Do_Compile;
procedure Compile_All is new For_Project_And_Aggregated (Do_Compile);
begin
Compile_All (Main_Project, Project_Tree);
-- Unregister the slaves and get back compiled object code. This is a
-- nop if no compilation has been done.
Gprbuild.Compilation.Slave.Unregister_Remote_Slaves;
end Run;
-----------------------
-- Compilation_Phase --
-----------------------
procedure Compilation_Phase
(Main_Project : Project_Id;
Project_Tree : Project_Tree_Ref)
is
type Local_Project_Data is record
Include_Language : Language_Ptr := No_Language_Index;
-- Prepared arguments for "include" parameters (-I or include file).
-- These are specific to each language and project.
Include_Path_File : Path_Name_Type;
-- The path name of the of the source search directory file
Imported_Dirs_Switches : Argument_List_Access;
-- List of the source search switches (-I) to be used
-- when compiling.
Include_Path : OS_Lib.String_Access := null;
-- The search source path for the project. Used as the value for an
-- environment variable, specified by attribute Include_Path
-- (). The names of the environment variables are in component
-- Include_Path of the records Language_Config.
end record;
-- project-specific data required for this procedure. These are not
-- stored in the Project_Data record so that projects kept in memory do
-- not have to allocate space for these temporary data
No_Local_Project_Data : constant Local_Project_Data :=
(Include_Language => No_Language_Index,
Include_Path => null,
Imported_Dirs_Switches => null,
Include_Path_File => No_Path);
package Local_Projects_HT is new Simple_HTable
(Header_Num => Prj.Header_Num,
Element => Local_Project_Data,
No_Element => No_Local_Project_Data,
Key => Project_Id,
Hash => Prj.Hash,
Equal => "=");
Local_Projects : Local_Projects_HT.Instance;
Current_Project : Project_Id := No_Project;
Current_Language_Ind : Language_Ptr := No_Language_Index;
-- The project for which the include path environment has been set last,
-- to avoid computing it several times.
Dep_File : Text_File;
Start : Natural;
Finish : Natural;
Last_Obj : Natural;
procedure Add_Config_File_Switch
(Config : Language_Config;
Path_Name : Path_Name_Type);
procedure Record_ALI_For
(Source_Identity : Queue.Source_Info;
The_ALI : ALI.ALI_Id := ALI.No_ALI_Id);
-- Record the Id of an ALI file in Good_ALI table.
-- The_ALI can contain the pre-parsed ali file, to save time.
-- Tree is the tree to which Source_Identity belongs
function Phase_2_Makefile (Src_Data : Queue.Source_Info) return Boolean;
function Phase_2_ALI (Src_Data : Queue.Source_Info) return Boolean;
-- Process Wait_For_Available_Slot depending on Src_Data.Dependency type
-- This returns whether the compilation is considered as successful or
-- not.
procedure Set_Options_For_File (Id : Source_Id);
-- Prepare the compiler options to use when building Id
procedure Process_Project_Phase_1 (Source : Queue.Source_Info);
-- If some compilation is needed for this project, perform it
function Must_Exit_Because_Of_Error return Boolean;
-- Return True if there were errors and the user decided to exit in such
-- a case. This waits for any outstanding compilation.
function Check_Switches_File (Id : Source_Id) return Boolean;
-- Check in its switches file where Id was compiled with the same
-- switches
procedure Update_Object_Path
(Id : Source_Id; Source_Project : Project_Id);
-- Update, if necessary, the path of the object file, of the dependency
-- file and of the switches file, in the case of the compilation of a
-- source in an extended project, when the source is in a project being
-- extended.
procedure Add_Dependency_Options (Id : Source_Id);
-- Add switches to the compilation command line to create the
-- dependency file
procedure Add_Object_File_Switches (Id : Source_Id);
-- If there are switches to specify the name of the object file, add
-- them.
procedure Add_Object_Path_Switches (Id : Source_Id);
-- If attribute Compiler'Object_Path_Switches has been specified, create
-- the temporary object path file, if not already done, and add the
-- switch(es) to the invocation of the compiler.
procedure Add_Config_File_Switches
(Id : Source_Id;
Source_Project : Project_Id);
-- If Config_File_Switches is specified, check if a config file need to
-- be specified. Return the path to the config file
procedure Add_Trailing_Switches (Id : Source_Id);
-- Add the trailing required switches, if any, so that they will be put
-- in the switches file.
procedure Add_Name_Of_Source_Switches (Id : Source_Id);
-- Add the name of the source to be compiled
function Add_Mapping_File_Switches
(Source : Queue.Source_Info;
Source_Project : Project_Id) return Path_Name_Type;
-- If the compiler supports mapping files, add the necessary switch.
-- Returns the name of the mapping file to use (or No_File)
procedure Add_Multi_Unit_Switches (Id : Source_Id);
-- Add, if needed, the required switches to compile a multi-unit source
-- file.
procedure Spawn_Compiler_And_Register
(Source : Queue.Source_Info;
Source_Project : Project_Id;
Compiler_Path : String;
Mapping_File_Path : Path_Name_Type;
Last_Switches_For_File : Integer);
-- Spawn the compiler with the arguments currently set in
-- Compiler_Options. It registers the process we just spawned, so that
-- we start monitoring it.
-- This also displays on the output the command we are spawning.
-- Last_Switches_For_File is the index in Compilation_Options of the
-- last switch that should be written to the switches file. All
-- following switches are not output in that file.
function Get_Compatible_Languages (Lang : Language_Ptr) return Name_Ids;
-- Return the list of languages that Id could potentially include (for
-- instance "C" if Id is a "C++" file. This also includes Id's own
-- language.
procedure Prepare_Imported_Dirs_Switches
(Data : out Local_Project_Data;
Project : Project_Id;
Lang : Language_Ptr);
-- Add the switches for include directories to the command line (these
-- are the "-I" switches in the case of C for instance).
procedure Prepare_Include_Path_File
(Data : out Local_Project_Data;
Project : Project_Id;
Lang : Language_Ptr);
-- Create a file to pass the include directories to the compiler
procedure Start_Compile_If_Possible;
-- Checks if there is more work that we can do (ie the Queue is non
-- empty). If there is, do it only if we have not yet used up all the
-- available processes.
procedure Wait_For_Available_Slot;
-- Check if we should wait for a compilation to finish. This is the case
-- if all the available processes are busy compiling sources or there is
-- nothing else to do (that is the Q is empty and there are outstanding
-- compilations).
procedure Set_Env_For_Include_Dirs
(Id : Source_Id; Source_Project : Project_Id);
-- Set environment variables or switches to pass the include directories
-- to the compiler
----------------------------
-- Add_Config_File_Switch --
----------------------------
procedure Add_Config_File_Switch
(Config : Language_Config;
Path_Name : Path_Name_Type)
is
List : Name_List_Index := Config.Config_File_Switches;
Nam : Name_Node;
begin
while List /= No_Name_List loop
Nam := Project_Tree.Shared.Name_Lists.Table (List);
Get_Name_String (Nam.Name);
if Nam.Next = No_Name_List then
Add_Str_To_Name_Buffer (Get_Name_String (Path_Name));
end if;
Add_Option
(Name_Buffer (1 .. Name_Len),
To => Compilation_Options,
Display => Opt.Verbose_Mode);
List := Nam.Next;
end loop;
end Add_Config_File_Switch;
--------------------
-- Record_ALI_For --
--------------------
procedure Record_ALI_For
(Source_Identity : Queue.Source_Info;
The_ALI : ALI.ALI_Id := ALI.No_ALI_Id)
is
Local_ALI : ALI.ALI_Id := The_ALI;
Text : Text_Buffer_Ptr;
begin
if The_ALI = ALI.No_ALI_Id then
Text := Read_Library_Info_From_Full
(File_Name_Type (Source_Identity.Id.Dep_Path),
Source_Identity.Id.Dep_TS'Access);
if Text /= null then
-- Read the ALI file but read only the necessary lines
Local_ALI :=
ALI.Scan_ALI
(File_Name_Type (Source_Identity.Id.Dep_Path),
Text,
Ignore_ED => False,
Err => True,
Ignore_Errors => True,
Read_Lines => "W");
Free (Text);
end if;
end if;
if Local_ALI /= ALI.No_ALI_Id then
Queue.Insert_Withed_Sources_For (Local_ALI, Source_Identity.Tree);
ALI.Initialize_ALI;
ALI.Util.Initialize_ALI_Source;
end if;
end Record_ALI_For;
----------------------
-- Phase_2_Makefile --
----------------------
function Phase_2_Makefile
(Src_Data : Queue.Source_Info) return Boolean
is
Compilation_OK : Boolean := True;
begin
Open (Dep_File, Get_Name_String (Src_Data.Id.Dep_Path));
if Is_Valid (Dep_File) then
Big_Loop :
loop
declare
End_Of_File_Reached : Boolean := False;
Object_Found : Boolean := False;
begin
loop
if End_Of_File (Dep_File) then
End_Of_File_Reached := True;
exit;
end if;
Get_Line (Dep_File, Name_Buffer, Name_Len);
if Name_Len > 0
and then Name_Buffer (1) /= '#'
then
-- Skip a first line that is an empty
-- continuation line.
for J in 1 .. Name_Len - 1 loop
if Name_Buffer (J) /= ' ' then
Object_Found := True;
exit;
end if;
end loop;
exit when Object_Found
or else Name_Buffer (Name_Len) /= '\';
end if;
end loop;
exit Big_Loop when End_Of_File_Reached;
end;
Start := 1;
Finish := Index (Name_Buffer (1 .. Name_Len), ": ");
exit Big_Loop when Finish = 0;
Last_Obj := Finish;
loop
Last_Obj := Last_Obj - 1;
exit when Last_Obj = Start
or else Name_Buffer (Last_Obj) /= ' ';
end loop;
while Start < Last_Obj
and then Name_Buffer (Start) = ' '
loop
Start := Start + 1;
end loop;
Start := Finish + 2;
-- Process each line
Line_Loop : loop
declare
Line : String := Name_Buffer (1 .. Name_Len);
Last : Natural := Name_Len;
begin
Name_Loop : loop
-- Find the beginning of the next source path
-- name.
while Start < Last and then Line (Start) = ' ' loop
Start := Start + 1;
end loop;
-- Go to next line when there is a
-- continuation character \ at the end of the
-- line.
exit Name_Loop when Start = Last
and then Line (Start) = '\';
-- We should not be at the end of the line,
-- without a continuation character \.
exit Name_Loop when Start = Last;
-- Look for the end of the source path name
Finish := Start;
while Finish < Last loop
if Line (Finish) = '\' then
-- On Windows, a '\' is part of the
-- path name, except when it is not the
-- first character followed by another
-- '\' or by a space. On other
-- platforms, when we are getting a '\'
-- that is not the last character of
-- the line, the next character is part
-- of the path name, even if it is a
-- space.
if On_Windows
and then Finish = Start
and then Line (Finish + 1) = '\'
then
Finish := Finish + 2;
elsif On_Windows
and then Line (Finish + 1) /= '\'
and then Line (Finish + 1) /= ' '
then
Finish := Finish + 1;
else
Line (Finish .. Last - 1) :=
Line (Finish + 1 .. Last);
Last := Last - 1;
end if;
else
-- A space that is not preceded by '\'
-- indicates the end of the path name.
exit when Line (Finish + 1) = ' ';
Finish := Finish + 1;
end if;
end loop;
-- Check this source
declare
Src_Name : constant String :=
Normalize_Pathname
(Name =>
Line (Start .. Finish),
Resolve_Links => False,
Case_Sensitive => False);
Source_2 : Source_Id;
begin
Name_Len := 0;
Add_Str_To_Name_Buffer (Src_Name);
Source_2 := Source_Paths_Htable.Get
(Src_Data.Tree.Source_Paths_HT,
Name_Find);
if Source_2 /= No_Source then
-- It is a source of a project
if not Project_Extends
(Src_Data.Id.Project, Source_2.Project)
and then
not Project_Extends
(Source_2.Project, Src_Data.Id.Project)
then
-- It is not a source of the same project
-- as the source just compiled. Check if
-- it can be imported.
if not Indirect_Imports then
if Directly_Imports
(Src_Data.Id.Project, Source_2.Project)
then
-- It is a source of a directly
-- imported project. Record its
-- project, for later processing.
Imports.Set
(Source_2.Project, True);
else
-- It is a source of a project that
-- is not directly imported. Record
-- the source for later processing.
Included_Sources.Append (Source_2);
end if;
end if;
if not Source_2.In_Interfaces then
-- It is not a source in the interfaces
-- of its project. Report an error and
-- invalidate the compilation.
Write_Char ('"');
Write_Str
(Get_Name_String
(Src_Data.Id.Path.Display_Name));
Write_Str (""" cannot import """);
Write_Str (Src_Name);
Write_Line (""":");
Write_Str
(" it is not part of the "
& "interfaces of its project """);
Write_Str
(Get_Name_String
(Source_2.Project.Display_Name));
Write_Line ("""");
Compilation_OK := False;
end if;
end if;
end if;
end;
exit Line_Loop when Finish = Last;
-- Go get the next source on the line
Start := Finish + 1;
end loop Name_Loop;
end;
-- If we are here, we had a continuation character
-- \ at the end of the line, so we continue with
-- the next line.
Get_Line (Dep_File, Name_Buffer, Name_Len);
Start := 1;
Finish := 1;
end loop Line_Loop;
end loop Big_Loop;
Close (Dep_File);
if Included_Sources.Last > 0 then
-- Sources in project that are not directly imported
-- have been found. Check if they may be imported by
-- other allowed imported sources.
declare
L : Project_List := Src_Data.Id.Project.Imported_Projects;
begin
-- Put in hash table Imports the project trees
-- rooted at the projects that are already in
-- Imports.
while L /= null loop
if Imports.Get (L.Project) then
Recursive_Import (L.Project);
end if;
L := L.Next;
end loop;
-- For all the imported sources from project not
-- directly imported, check if their projects are
-- in table imports.
for J in 1 .. Included_Sources.Last loop
declare
Included : constant Source_Id :=
Included_Sources.Table (J);
begin
if not Imports.Get (Included.Project) then
-- This source is either directly imported or
-- imported from another source that should not be
-- imported. Report an error and invalidate the
-- compilation.
Write_Char ('"');
Write_Str
(Get_Name_String (Src_Data.Id.Path.Display_Name));
Write_Str (""" cannot import """);
Write_Str
(Get_Name_String (Included.Path.Display_Name));
Write_Line (""":");
Write_Str (" """);
Write_Str
(Get_Name_String
(Src_Data.Id.Project.Display_Name));
Write_Str
(""" does not directly import project """);
Write_Str
(Get_Name_String (Included.Project.Display_Name));
Write_Line ("""");
Compilation_OK := False;
end if;
end;
end loop;
end;
end if;
end if;
return Compilation_OK;
end Phase_2_Makefile;
-----------------
-- Phase_2_ALI --
-----------------
function Phase_2_ALI (Src_Data : Queue.Source_Info) return Boolean is
Compilation_OK : Boolean := True;
Text : Text_Buffer_Ptr :=
Read_Library_Info_From_Full
(File_Name_Type (Src_Data.Id.Dep_Path),
Src_Data.Id.Dep_TS'Access);
The_ALI : ALI.ALI_Id := ALI.No_ALI_Id;
Sfile : File_Name_Type;
Afile : File_Name_Type;
Source_2 : Source_Id;
procedure Check_Source (Sfile : File_Name_Type);
-- Check if source Sfile is in the same project file as the Src_Data
-- source file. Invalidate the compilation if it is not.
------------------
-- Check_Source --
------------------
procedure Check_Source (Sfile : File_Name_Type) is
Source_3 : constant Source_Id :=
Find_Source
(Src_Data.Tree, No_Project, Base_Name => Sfile);
begin
if Source_3 = No_Source then
Write_Str ("source ");
Write_Str (Get_Name_String (Sfile));
Write_Line (" is not a source of a project");
Compilation_OK := False;
elsif Ultimate_Extending_Project_Of (Source_3.Project) /=
Ultimate_Extending_Project_Of (Src_Data.Id.Project)
then
Write_Str ("sources ");
Write_Str (Get_Name_String (Source_3.File));
Write_Str (" and ");
Write_Str (Get_Name_String (Src_Data.Id.File));
Write_Str (" belong to different projects: ");
Write_Str (Get_Name_String (Source_3.Project.Display_Name));
Write_Str (" and ");
Write_Line (Get_Name_String (Src_Data.Id.Project.Display_Name));
Compilation_OK := False;
end if;
end Check_Source;
begin
if Text /= null then
-- Read the ALI file but read only the necessary lines
The_ALI :=
ALI.Scan_ALI
(File_Name_Type (Src_Data.Id.Dep_Path),
Text,
Ignore_ED => False,
Err => True,
Ignore_Errors => True,
Read_Lines => "DW");
if The_ALI /= ALI.No_ALI_Id then
for J in ALI.ALIs.Table (The_ALI).First_Unit ..
ALI.ALIs.Table (The_ALI).Last_Unit
loop
for K in ALI.Units.Table (J).First_With ..
ALI.Units.Table (J).Last_With
loop
if not
ALI.Withs.Table (K).Implicit_With_From_Instantiation
then
Sfile := ALI.Withs.Table (K).Sfile;
-- Skip generics
if Sfile /= No_File then
-- Look for this source
Afile := ALI.Withs.Table (K).Afile;
Source_2 := Source_Files_Htable.Get
(Src_Data.Tree.Source_Files_HT, Sfile);
while Source_2 /= No_Source loop
if Is_Compilable (Source_2)
and then Source_2.Dep_Name = Afile
then
case Source_2.Kind is
when Spec => null;
when Impl =>
if Is_Subunit (Source_2) then
Source_2 := No_Source;
end if;
when Sep =>
Source_2 := No_Source;
end case;
exit;
end if;
Source_2 := Source_2.Next_With_File_Name;
end loop;
-- If it is the source of a project that is not the
-- project of the source just compiled, check if it
-- is allowed to be imported.
if Source_2 /= No_Source then
if not Project_Extends
(Src_Data.Id.Project, Source_2.Project)
and then
not Project_Extends
(Source_2.Project, Src_Data.Id.Project)
then
if not Indirect_Imports
and then not Directly_Imports
(Src_Data.Id.Project, Source_2.Project)
then
-- It is in a project that is not directly
-- imported. Report an error and
-- invalidate the compilation.
Write_Str ("Unit """);
Write_Str
(Get_Name_String
(Src_Data.Id.Unit.Name));
Write_Str (""" cannot import unit """);
Write_Str
(Get_Name_String (Source_2.Unit.Name));
Write_Line (""":");
Write_Str (" """);
Write_Str
(Get_Name_String
(Src_Data.Id.Project.Display_Name));
Write_Str
(""" does not directly"
& " import project """);
Write_Str
(Get_Name_String
(Source_2.Project.Display_Name));
Write_Line ("""");
Compilation_OK := False;
elsif not Source_2.In_Interfaces then
-- It is not an interface of its project.
-- Report an error and invalidate the
-- compilation.
Write_Str ("Unit """);
Write_Str
(Get_Name_String
(Src_Data.Id.Unit.Name));
Write_Str (""" cannot import unit """);
Write_Str
(Get_Name_String (Source_2.Unit.Name));
Write_Line (""":");
Write_Str
(" it is not part of the "
& "interfaces of its project """);
Write_Str
(Get_Name_String
(Source_2.Project.Display_Name));
Write_Line ("""");
Compilation_OK := False;
end if;
end if;
end if;
end if;
end if;
end loop;
end loop;
if Opt.No_Split_Units then
-- Initialized the list of subunits with the unit name
Subunits.Init;
Subunits.Append
(new String'(Get_Name_String (Src_Data.Id.Unit.Name)));
-- First check that the spec and the body are in the same
-- project.
for J in ALI.ALIs.Table (The_ALI).First_Unit ..
ALI.ALIs.Table (The_ALI).Last_Unit
loop
Check_Source (ALI.Units.Table (J).Sfile);
end loop;
-- Next, check the subunits, if any
declare
Subunit_Found : Boolean;
Already_Found : Boolean;
Last : Positive;
begin
-- Loop until we don't find new subunits
loop
Subunit_Found := False;
for D in ALI.ALIs.Table (The_ALI).First_Sdep
.. ALI.ALIs.Table (The_ALI).Last_Sdep
loop
if ALI.Sdep.Table (D).Subunit_Name /= No_Name then
Get_Name_String
(ALI.Sdep.Table (D).Subunit_Name);
-- First check if we already found this subunit
Already_Found := False;
for K in 1 .. Subunits.Last loop
if Name_Buffer (1 .. Name_Len) =
Subunits.Table (K).all
then
Already_Found := True;
exit;
end if;
end loop;
if not Already_Found then
-- Find the name of the parent
Last := Name_Len - 1;
while Last > 1
and then Name_Buffer (Last + 1) /= '.'
loop
Last := Last - 1;
end loop;
for J in 1 .. Subunits.Last loop
if Subunits.Table (J).all =
Name_Buffer (1 .. Last)
then
-- It is a new subunit, add it o the
-- list and check if it is in the right
-- project.
Subunits.Append
(new String'
(Name_Buffer (1 .. Name_Len)));
Subunit_Found := True;
Check_Source (ALI.Sdep.Table (D).Sfile);
exit;
end if;
end loop;
end if;
end if;
end loop;
exit when not Subunit_Found;
end loop;
end;
end if;
if Compilation_OK
and then Builder_Data (Src_Data.Tree).Closure_Needed
then
Record_ALI_For (Src_Data, The_ALI);
end if;
end if;
Free (Text);
end if;
return Compilation_OK;
end Phase_2_ALI;
--------------------------
-- Set_Options_For_File --
--------------------------
procedure Set_Options_For_File (Id : Source_Id) is
Config : Language_Config renames Id.Language.Config;
Builder_Options_Instance : constant Builder_Comp_Option_Table_Ref :=
Builder_Compiling_Options_HTable.Get
(Id.Language.Name);
Comp_Opt : constant Comp_Option_Table_Ref :=
Compiling_Options_HTable.Get
(Id.Language.Name);
List : Name_List_Index;
Nam_Nod : Name_Node;
First : Boolean;
begin
Compilation_Options.Last := 0;
-- 1a) The leading required switches
List := Config.Compiler_Leading_Required_Switches;
First := True;
while List /= No_Name_List loop
Nam_Nod := Project_Tree.Shared.Name_Lists.Table (List);
if Nam_Nod.Name /= Empty_String then
Add_Option
(Value => Nam_Nod.Name,
To => Compilation_Options,
Display => First or Opt.Verbose_Mode);
First := False;
end if;
List := Nam_Nod.Next;
end loop;
-- 1b) The switches in CodePeer mode
if Opt.CodePeer_Mode then
-- Replace -x ada with -x adascil
declare
Cur : Integer := Compilation_Options.Last - 1;
begin
while Cur > 0
and then Compilation_Options.Options (Cur).all /= "-x"
loop
Cur := Cur - 1;
end loop;
if Cur /= 0 then
Compilation_Options.Visible (Cur) := True;
Compilation_Options.Options (Cur + 1) :=
new String'("adascil");
Compilation_Options.Visible (Cur + 1) := True;
else
Add_Option
(Value => "-x",
To => Compilation_Options,
Display => True);
Add_Option
(Value => "adascil",
To => Compilation_Options,
Display => True);
end if;
end;
Add_Option
(Value => "-gnatcC",
To => Compilation_Options,
Display => True);
end if;
-- 2) the compilation switches specified in package Builder
-- for all compilers, following "-cargs", if any.
for Index in 1 .. All_Language_Builder_Compiling_Options.Last loop
Add_Option_Internal_Codepeer
(Value => All_Language_Builder_Compiling_Options.Table (Index),
To => Compilation_Options,
Display => True);
end loop;
-- 3) the compilation switches specified in package Builder
-- for the compiler of the language, following
-- -cargs:.
if Builder_Options_Instance /= null then
for Index in 1 ..
Builder_Compiling_Options.Last (Builder_Options_Instance.all)
loop
Add_Option_Internal_Codepeer
(Value => Builder_Options_Instance.Table (Index),
To => Compilation_Options,
Display => True);
end loop;
end if;
-- 4) The PIC option if it exists, for shared libraries
if Id.Project.Library
and then Id.Project.Library_Kind /= Static
then
List := Config.Compilation_PIC_Option;
while List /= No_Name_List loop
Nam_Nod := Project_Tree.Shared.Name_Lists.Table (List);
Add_Option
(Value => Nam_Nod.Name,
To => Compilation_Options,
Display => True);
List := Nam_Nod.Next;
end loop;
end if;
-- 5) Compiler'Switches(), if it is
-- defined, otherwise Compiler'Switches (),
-- if defined.
Add_Compilation_Switches (Id);
-- 6) the switches specified on the gprbuild command line
-- for all compilers, following "-cargs", if any.
for Index in 1 .. All_Language_Compiling_Options.Last loop
Add_Option_Internal_Codepeer
(Value => All_Language_Compiling_Options.Table (Index),
To => Compilation_Options,
Display => True);
end loop;
-- 7) the switches specified on the gprbuild command line
-- for the compiler of the language, following
-- -cargs:.
if Comp_Opt /= null then
for Index in 1 .. Compiling_Options.Last (Comp_Opt.all) loop
Add_Option_Internal_Codepeer
(Value => Comp_Opt.Table (Index),
To => Compilation_Options,
Display => True);
end loop;
end if;
end Set_Options_For_File;
-------------------------
-- Check_Switches_File --
-------------------------
function Check_Switches_File (Id : Source_Id) return Boolean is
File : Text_IO.File_Type;
function Assert_Line (Current : String) return Boolean;
-- Return False if Current is not the next line in the switches file
-----------------
-- Assert_Line --
-----------------
function Assert_Line (Current : String) return Boolean is
Line : String (1 .. 1_000);
Last : Natural;
begin
if End_Of_File (File) then
if Opt.Verbose_Mode then
Write_Line (" -> switches file has fewer switches");
end if;
Close (File);
return False;
end if;
Get_Line (File, Line, Last);
if Line (1 .. Last) /= Current then
if Opt.Verbose_Mode then
Write_Line (" -> switches file '"
& Get_Name_String (Id.Switches_Path)
& "' has different line");
Write_Line (" " & Line (1 .. Last));
Write_Line (" " & Current);
end if;
Close (File);
return False;
end if;
return True;
end Assert_Line;
List : Name_List_Index;
Nam_Nod : Name_Node;
begin
Open (File, In_File, Get_Name_String (Id.Switches_Path));
if not Assert_Line (String (Id.Object_TS)) then
return True;
end if;
for Index in 1 .. Compilation_Options.Last loop
if not Assert_Line (Compilation_Options.Options (Index).all) then
return True;
end if;
end loop;
List := Id.Language.Config.Compiler_Trailing_Required_Switches;
while List /= No_Name_List loop
Nam_Nod := Project_Tree.Shared.Name_Lists.Table (List);
if not Assert_Line (Get_Name_String (Nam_Nod.Name)) then
return True;
end if;
List := Nam_Nod.Next;
end loop;
if not End_Of_File (File) then
if Opt.Verbose_Mode then
Write_Line (" -> switches file has more switches");
end if;
Close (File);
return True;
end if;
Close (File);
return False;
exception
when others =>
if Opt.Verbose_Mode then
Write_Line (" -> no switches file");
end if;
return True;
end Check_Switches_File;
------------------------
-- Update_Object_Path --
------------------------
procedure Update_Object_Path
(Id : Source_Id; Source_Project : Project_Id) is
begin
Id.Object_Project := Source_Project;
if Id.Object_Project /= Id.Project then
if Id.Object /= No_File then
Get_Name_String
(Id.Object_Project.Object_Directory.Display_Name);
Add_Str_To_Name_Buffer (Get_Name_String (Id.Object));
Id.Object_Path := Name_Find;
end if;
if Id.Dep_Name /= No_File then
Get_Name_String
(Id.Object_Project.Object_Directory.Display_Name);
Add_Str_To_Name_Buffer (Get_Name_String (Id.Dep_Name));
Id.Dep_Path := Name_Find;
end if;
if Id.Switches /= No_File then
Get_Name_String
(Id.Object_Project.Object_Directory.Display_Name);
Add_Str_To_Name_Buffer (Get_Name_String (Id.Switches));
Id.Switches_Path := Name_Find;
end if;
end if;
end Update_Object_Path;
----------------------------
-- Add_Dependency_Options --
----------------------------
procedure Add_Dependency_Options (Id : Source_Id) is
List : Name_List_Index := Id.Language.Config.Dependency_Option;
Node : Name_Node;
begin
if Id.Language.Config.Dependency_Kind /= None then
while List /= No_Name_List loop
Node := Project_Tree.Shared.Name_Lists.Table (List);
List := Node.Next;
if List = No_Name_List then
Add_Option
(Value => Get_Name_String (Node.Name)
& Get_Name_String (Id.Dep_Name),
To => Compilation_Options,
Display => Opt.Verbose_Mode);
else
Add_Option
(Value => Node.Name,
To => Compilation_Options,
Display => Opt.Verbose_Mode);
end if;
end loop;
end if;
end Add_Dependency_Options;
------------------------------
-- Add_Object_File_Switches --
------------------------------
procedure Add_Object_File_Switches (Id : Source_Id) is
List : Name_List_Index := Id.Language.Config.Object_File_Switches;
Node : Name_Node;
begin
if List /= No_Name_List then
loop
Node := Project_Tree.Shared.Name_Lists.Table (List);
exit when Node.Next = No_Name_List;
Add_Option
(Node.Name,
To => Compilation_Options,
Display => Opt.Verbose_Mode or else Id.Index /= 0);
List := Node.Next;
end loop;
Get_Name_String (Node.Name);
Add_Str_To_Name_Buffer (Get_Name_String (Id.Object));
Add_Option
(Name_Buffer (1 .. Name_Len),
To => Compilation_Options,
Display => Opt.Verbose_Mode or else Id.Index /= 0);
-- Always specify object-file for a multi-unit source file
elsif Id.Index /= 0 then
Add_Option
("-o",
To => Compilation_Options,
Display => True);
Add_Option
(Get_Name_String (Id.Object),
To => Compilation_Options,
Display => True);
end if;
end Add_Object_File_Switches;
------------------------------
-- Add_Object_Path_Switches --
------------------------------
procedure Add_Object_Path_Switches (Id : Source_Id) is
List : Name_List_Index := Id.Language.Config.Object_Path_Switches;
Node : Name_Node;
begin
if List /= No_Name_List then
if Id.Project.Object_Path_File = No_Path then
Create_Object_Path_File (Id.Project);
end if;
while List /= No_Name_List loop
Node := Project_Tree.Shared.Name_Lists.Table (List);
exit when Node.Next = No_Name_List;
Add_Option
(Node.Name,
To => Compilation_Options,
Display => Opt.Verbose_Mode);
List := Node.Next;
end loop;
Get_Name_String (Node.Name);
Add_Str_To_Name_Buffer
(Get_Name_String (Id.Project.Object_Path_File));
Add_Option
(Name_Buffer (1 .. Name_Len),
To => Compilation_Options,
Display => Opt.Verbose_Mode);
end if;
end Add_Object_Path_Switches;
------------------------------
-- Add_Config_File_Switches --
------------------------------
procedure Add_Config_File_Switches
(Id : Source_Id;
Source_Project : Project_Id)
is
Config : constant Language_Config := Id.Language.Config;
Config_File_Path : Path_Name_Type;
begin
if Config.Config_File_Switches /= No_Name_List
and then (Config.Config_Body /= No_Name
or else Config.Config_Body_Index /= No_Name
or else Config.Config_Body_Pattern /= No_Name
or else Config.Config_Spec /= No_Name
or else Config.Config_Spec_Index /= No_Name
or else Config.Config_Spec_Pattern /= No_Name)
then
Create_Config_File
(For_Project => Source_Project,
Config => Config,
Language => Id.Language.Name);
if Source_Project.Config_File_Name /= No_Path then
Add_Config_File_Switch
(Config => Config,
Path_Name => Source_Project.Config_File_Name);
end if;
if not Config.Config_File_Unique then
Config_File_Path :=
Config_File_For
(Project => Main_Project,
Package_Name => Name_Builder,
Attribute_Name => Name_Global_Config_File,
Language => Id.Language.Name);
if Config_File_Path /= No_Path then
Add_Config_File_Switch
(Config => Config,
Path_Name => Config_File_Path);
end if;
Config_File_Path :=
Config_File_For
(Project => Source_Project,
Package_Name => Name_Compiler,
Attribute_Name => Name_Local_Config_File,
Language => Id.Language.Name);
if Config_File_Path /= No_Path then
Add_Config_File_Switch
(Config => Config,
Path_Name => Config_File_Path);
end if;
end if;
end if;
end Add_Config_File_Switches;
-------------------------------
-- Add_Mapping_File_Switches --
-------------------------------
function Add_Mapping_File_Switches
(Source : Queue.Source_Info;
Source_Project : Project_Id) return Path_Name_Type
is
List : Name_List_Index :=
Source.Id.Language.Config.Mapping_File_Switches;
Node : Name_Node;
Mapping_File_Path : Path_Name_Type;
begin
if List /= No_Name_List then
-- Check if there is a temporary mapping file we can use
Mapping_File_Path := Mapping_Files_Htable.Get_First
(Source.Id.Language.Mapping_Files);
if Mapping_File_Path /= No_Path then
-- Reuse this temporary mapping file and remove its
-- name from the HTable so that it is not reused
-- before the compilation terminates.
Mapping_Files_Htable.Remove
(Source.Id.Language.Mapping_Files, Mapping_File_Path);
else
-- Create a new temporary mapping file, as there are
-- none that can be reused.
Prj.Env.Create_Mapping_File
(Project => Source_Project,
Language => Source.Id.Language.Name,
In_Tree => Source.Tree,
Name => Mapping_File_Path);
end if;
while List /= No_Name_List loop
Node := Source.Tree.Shared.Name_Lists.Table (List);
List := Node.Next;
if List /= No_Name_List then
Add_Option
(Value => Node.Name,
To => Compilation_Options,
Display => Opt.Verbose_Mode);
else
Get_Name_String (Node.Name);
Add_Str_To_Name_Buffer (Get_Name_String (Mapping_File_Path));
Add_Option
(Name_Buffer (1 .. Name_Len),
To => Compilation_Options,
Display => Opt.Verbose_Mode);
end if;
end loop;
return Mapping_File_Path;
else
return No_Path;
end if;
end Add_Mapping_File_Switches;
-----------------------------
-- Add_Multi_Unit_Switches --
-----------------------------
procedure Add_Multi_Unit_Switches (Id : Source_Id) is
List : Name_List_Index := Id.Language.Config.Multi_Unit_Switches;
begin
if Id.Index /= 0
and then List /= No_Name_List
then
declare
Index_Img : constant String := Id.Index'Img;
Node : Name_Node;
begin
loop
Node := Project_Tree.Shared.Name_Lists.Table (List);
exit when Node.Next = No_Name_List;
Add_Option
(Node.Name,
To => Compilation_Options,
Display => True);
List := Node.Next;
end loop;
Get_Name_String (Node.Name);
Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last));
Add_Option
(Name_Buffer (1 .. Name_Len),
To => Compilation_Options,
Display => True);
end;
end if;
end Add_Multi_Unit_Switches;
---------------------------
-- Add_Trailing_Switches --
---------------------------
procedure Add_Trailing_Switches (Id : Source_Id) is
List : Name_List_Index :=
Id.Language.Config.Compiler_Trailing_Required_Switches;
Node : Name_Node;
begin
while List /= No_Name_List loop
Node := Project_Tree.Shared.Name_Lists.Table (List);
Add_Option
(Node.Name,
To => Compilation_Options,
Display => Opt.Verbose_Mode);
List := Node.Next;
end loop;
end Add_Trailing_Switches;
---------------------------------
-- Add_Name_Of_Source_Switches --
---------------------------------
procedure Add_Name_Of_Source_Switches (Id : Source_Id) is
List : Name_List_Index :=
Id.Language.Config.Source_File_Switches;
Node : Name_Node;
Source_Path : OS_Lib.String_Access;
begin
-- Add any source file prefix
if List /= No_Name_List then
loop
Node := Project_Tree.Shared.Name_Lists.Table (List);
exit when Node.Next = No_Name_List;
Add_Option
(Node.Name,
To => Compilation_Options,
Display => Opt.Verbose_Mode or else Id.Index /= 0);
List := Node.Next;
end loop;
end if;
-- Then handle the source file
Get_Name_String (Id.Path.Display_Name);
case Id.Language.Config.Path_Syntax is
when Canonical =>
Source_Path := new String'(Name_Buffer (1 .. Name_Len));
when Host =>
Source_Path := To_Host_File_Spec (Name_Buffer (1 .. Name_Len));
end case;
if Node.Name = No_Name then
Add_Option_Internal
(Source_Path,
To => Compilation_Options,
Display => True,
Simple_Name => not Opt.Verbose_Mode);
else
Get_Name_String (Node.Name);
Add_Option
(Name_Buffer (1 .. Name_Len) & Source_Path.all,
To => Compilation_Options,
Display => True,
Simple_Name => not Opt.Verbose_Mode);
end if;
end Add_Name_Of_Source_Switches;
---------------------------------
-- Spawn_Compiler_And_Register --
---------------------------------
procedure Spawn_Compiler_And_Register
(Source : Queue.Source_Info;
Source_Project : Project_Id;
Compiler_Path : String;
Mapping_File_Path : Path_Name_Type;
Last_Switches_For_File : Integer)
is
procedure Add_Process
(Process : Id;
Source : Queue.Source_Info;
Source_Project : Project_Id;
Mapping_File : Path_Name_Type;
Purpose : Process_Purpose;
Options : String_List_Access);
-- Add compilation process and indicate that the object directory is
-- busy.
-----------------
-- Add_Process --
-----------------
procedure Add_Process
(Process : Id;
Source : Queue.Source_Info;
Source_Project : Project_Id;
Mapping_File : Path_Name_Type;
Purpose : Process_Purpose;
Options : String_List_Access)
is
begin
Compilation_Htable.Set
(Process,
(Process, Source, Source_Project,
Mapping_File, Purpose, Options));
Outstanding_Compiles := Outstanding_Compiles + 1;
Queue.Set_Obj_Dir_Busy (Source.Id.Project.Object_Directory.Name);
end Add_Process;
function Get_Language return String is
(if Source.Id.Language /= null
then Get_Name_String (Source.Id.Language.Name)
else "");
Process : Id;
Options : String_List_Access;
begin
if not Opt.Quiet_Output then
if Opt.Verbose_Mode then
Write_Str (Compiler_Path);
else
Name_Len := 0;
Add_Str_To_Name_Buffer (Base_Name (Compiler_Path));
if Executable_Suffix'Length /= 0
and then Name_Len > Executable_Suffix'Length
and then Name_Buffer
(Name_Len - Executable_Suffix'Length + 1 .. Name_Len)
= Executable_Suffix.all
then
Name_Len := Name_Len - Executable_Suffix'Length;
end if;
Write_Str (Name_Buffer (1 .. Name_Len));
end if;
for Option in 1 .. Compilation_Options.Last loop
if Compilation_Options.Visible (Option) then
Write_Char (' ');
if Compilation_Options.Simple_Name (Option) then
Write_Str
(Base_Name (Compilation_Options.Options (Option).all));
else
Write_Str (Compilation_Options.Options (Option).all);
end if;
end if;
end loop;
Write_Eol;
end if;
Process := Run
(Compiler_Path,
Compilation_Options.Options (1 .. Compilation_Options.Last),
Source_Project,
Language => Get_Language,
Dep_Name => (if Source.Id.Dep_Name = No_File
then ""
else Get_Name_String (Source.Id.Dep_Name)),
Obj_Name => (if Source.Id.Object = No_File
then ""
else Get_Name_String (Source.Id.Object)));
if Last_Switches_For_File >= 0 then
Compilation_Options.Last := Last_Switches_For_File;
Add_Trailing_Switches (Source.Id);
Options :=
new String_List'
(Compilation_Options.Options (1 .. Compilation_Options.Last));
end if;
Add_Process
(Process => Process,
Source => Source,
Source_Project => Source_Project,
Mapping_File => Mapping_File_Path,
Purpose => Compilation,
Options => Options);
end Spawn_Compiler_And_Register;
------------------------------
-- Get_Compatible_Languages --
------------------------------
function Get_Compatible_Languages
(Lang : Language_Ptr) return Name_Ids
is
NL : Name_List_Index :=
Lang.Config.Include_Compatible_Languages;
Languages : Name_Ids
(1 .. 1 + Length (Project_Tree.Shared.Name_Lists, NL));
Index : Positive := 1;
begin
Languages (Index) := Lang.Name;
while NL /= No_Name_List loop
Index := Index + 1;
Languages (Index) :=
Project_Tree.Shared.Name_Lists.Table (NL).Name;
NL := Project_Tree.Shared.Name_Lists.Table (NL).Next;
end loop;
return Languages;
end Get_Compatible_Languages;
-------------------------------
-- Prepare_Include_Path_File --
-------------------------------
procedure Prepare_Include_Path_File
(Data : out Local_Project_Data;
Project : Project_Id;
Lang : Language_Ptr)
is
FD : File_Descriptor;
Status : Boolean;
begin
Get_Directories
(Project_Tree => Project_Tree,
For_Project => Project,
Activity => Compilation,
Languages => Get_Compatible_Languages (Lang));
Prj.Env.Create_New_Path_File
(Shared => Project_Tree.Shared,
Path_FD => FD,
Path_Name => Data.Include_Path_File);
if FD = Invalid_FD then
Fail_Program
(Project_Tree, "could not create temporary path file");
end if;
for Index in 1 .. Directories.Last loop
Get_Name_String (Directories.Table (Index));
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.LF;
if Write (FD, Name_Buffer (1)'Address, Name_Len) /= Name_Len then
Fail_Program
(Project_Tree,
"disk full when writing include path file");
end if;
end loop;
Close (FD, Status);
if not Status then
Fail_Program
(Project_Tree,
"disk full when writing include path file");
end if;
end Prepare_Include_Path_File;
------------------------------------
-- Prepare_Imported_Dirs_Switches --
------------------------------------
procedure Prepare_Imported_Dirs_Switches
(Data : out Local_Project_Data;
Project : Project_Id;
Lang : Language_Ptr)
is
Len : constant Natural :=
Length
(Project_Tree.Shared.Name_Lists,
Lang.Config.Include_Option);
Host_Path : OS_Lib.String_Access;
Last : Natural := 0;
List : Name_List_Index;
Nam : Name_Node;
begin
Get_Directories
(Project_Tree => Project_Tree,
For_Project => Project,
Activity => Compilation,
Languages => Get_Compatible_Languages (Lang));
Free (Data.Imported_Dirs_Switches);
Data.Imported_Dirs_Switches :=
new String_List (1 .. Directories.Last * Len);
for Index in 1 .. Directories.Last loop
List := Lang.Config.Include_Option;
while List /= No_Name_List loop
Nam := Project_Tree.Shared.Name_Lists.Table (List);
exit when Nam.Next = No_Name_List;
Last := Last + 1;
Data.Imported_Dirs_Switches (Last) :=
new String'(Get_Name_String (Nam.Name));
List := Nam.Next;
end loop;
Get_Name_String (Directories.Table (Index));
while Name_Len > 1
and then (Name_Buffer (Name_Len) = Directory_Separator
or else Name_Buffer (Name_Len) = '/')
loop
Name_Len := Name_Len - 1;
end loop;
Last := Last + 1;
-- Concatenate the last switch and the path in a single option
case Lang.Config.Path_Syntax is
when Canonical =>
Data.Imported_Dirs_Switches (Last) := new String'
(Get_Name_String (Nam.Name) & Name_Buffer (1 .. Name_Len));
when Host =>
Host_Path := To_Host_Dir_Spec
(Name_Buffer (1 .. Name_Len), False);
Data.Imported_Dirs_Switches (Last) := new String'
(Get_Name_String (Nam.Name) & Host_Path.all);
Free (Host_Path);
end case;
end loop;
end Prepare_Imported_Dirs_Switches;
------------------------------
-- Set_Env_For_Include_Dirs --
------------------------------
procedure Set_Env_For_Include_Dirs
(Id : Source_Id; Source_Project : Project_Id)
is
Data : Local_Project_Data :=
Local_Projects_HT.Get (Local_Projects, Id.Object_Project);
begin
-- Prepare (if not already done) the data for Project/Lang.
-- All files for a given language are processed sequentially, before
-- we switch to the next language, so we are only preparing once per
-- language here.
if Data.Include_Language /= Id.Language then
Free (Data.Include_Path);
Free (Data.Imported_Dirs_Switches);
Data := No_Local_Project_Data;
if Id.Language.Config.Include_Option /= No_Name_List then
Prepare_Imported_Dirs_Switches
(Data, Id.Object_Project, Id.Language);
elsif Id.Language.Config.Include_Path_File /= No_Name then
if Id.Language.Config.Mapping_File_Switches = No_Name_List
or else Opt.Use_Include_Path_File
then
Prepare_Include_Path_File
(Data, Id.Object_Project, Id.Language);
end if;
elsif Id.Language.Config.Include_Path /= No_Name then
Get_Directories
(Project_Tree => Project_Tree,
For_Project => Id.Object_Project,
Activity => Compilation,
Languages => Get_Compatible_Languages (Id.Language));
Data.Include_Path := Create_Path_From_Dirs;
end if;
Data.Include_Language := Id.Language;
Local_Projects_HT.Set (Local_Projects, Id.Object_Project, Data);
end if;
-- Reset environment variables if they have changed
if Id.Object_Project /= Current_Project
or else Id.Language /= Current_Language_Ind
then
Current_Project := Id.Object_Project;
Current_Language_Ind := Id.Language;
if Data.Include_Path_File /= No_Path then
Setenv (Get_Name_String (Id.Language.Config.Include_Path_File),
Get_Name_String (Data.Include_Path_File));
elsif Data.Include_Path /= null then
Gprbuild.Compilation.Process.Record_Environment
(Source_Project,
Id.Language.Name,
Get_Name_String (Id.Language.Config.Include_Path),
Data.Include_Path.all);
if Opt.Verbose_Mode then
Write_Str
(Get_Name_String (Id.Language.Config.Include_Path));
Write_Str (" = ");
Write_Line (Data.Include_Path.all);
end if;
end if;
end if;
-- But always set the switches
if Data.Imported_Dirs_Switches /= null then
for J in Data.Imported_Dirs_Switches'Range loop
if Data.Imported_Dirs_Switches (J)'Length > 0 then
Add_Option_Internal
(Value => Data.Imported_Dirs_Switches (J),
To => Compilation_Options,
Display => Opt.Verbose_Mode);
end if;
end loop;
end if;
end Set_Env_For_Include_Dirs;
-----------------------------
-- Process_Project_Phase_1 --
-----------------------------
procedure Process_Project_Phase_1 (Source : Queue.Source_Info) is
Id : constant Source_Id := Source.Id;
Project_Tree : constant Project_Tree_Ref := Source.Tree;
Source_Project : constant Project_Id :=
Ultimate_Extending_Project_Of
(Source.Id.Project);
Compilation_Needed : Boolean := True;
Last_Switches_For_File : Integer;
Mapping_File : Path_Name_Type;
The_ALI : ALI.ALI_Id;
begin
if Always_Compile or else not Source_Project.Externally_Built then
Need_To_Compile
(Source => Source.Id,
Tree => Source.Tree,
In_Project => Source_Project,
Must_Compile => Compilation_Needed,
The_ALI => The_ALI,
Object_Check => Object_Checked,
Always_Compile => Always_Compile);
if Compilation_Needed and then Opt.Keep_Going then
-- When in Keep_Going mode first check that we did not already
-- tried to compile this source as part of another import of
-- the corresponding project file.
if Bad_Compilations.Contains (Source.Id) then
Compilation_Needed := False;
end if;
end if;
if Compilation_Needed or else Opt.Check_Switches then
Set_Options_For_File (Source.Id);
if Opt.Check_Switches and then not Compilation_Needed then
Compilation_Needed := Check_Switches_File (Source.Id);
end if;
end if;
if Compilation_Needed then
-- If Distributed_Mode activated, parse Remote package to
-- register and initialize the slaves.
if Distributed_Mode and then not Slave_Initialized then
Gprbuild.Compilation.Slave.Register_Remote_Slaves
(Project_Tree, Main_Project);
Slave_Initialized := True;
end if;
Update_Object_Path (Source.Id, Source_Project);
Change_To_Object_Directory (Source_Project);
-- Record the last recorded option index, to be able to
-- write the switches file later.
if Id.Language.Config.Object_Generated then
Last_Switches_For_File := Compilation_Options.Last;
else
Last_Switches_For_File := -1;
end if;
Add_Dependency_Options (Id);
Set_Env_For_Include_Dirs (Id, Source_Project);
Add_Config_File_Switches (Id, Source_Project);
Mapping_File := Add_Mapping_File_Switches
(Source, Source_Project);
Add_Trailing_Switches (Id);
Add_Name_Of_Source_Switches (Id);
Add_Object_File_Switches (Id);
Add_Multi_Unit_Switches (Id);
Add_Object_Path_Switches (Id);
Spawn_Compiler_And_Register
(Source => Source,
Source_Project => Source_Project,
Compiler_Path => Get_Compiler_Driver_Path
(Project_Tree, Id.Language).all,
Mapping_File_Path => Mapping_File,
Last_Switches_For_File => Last_Switches_For_File);
elsif Builder_Data (Source.Tree).Closure_Needed
and then
(Id.Language.Config.Dependency_Kind = ALI_File
or else Id.Language.Config.Dependency_Kind = ALI_Closure)
then
Record_ALI_For (Source, The_ALI);
else
ALI.Initialize_ALI;
ALI.Util.Initialize_ALI_Source;
end if;
end if;
end Process_Project_Phase_1;
--------------------------------
-- Must_Exit_Because_Of_Error --
--------------------------------
function Must_Exit_Because_Of_Error return Boolean is
use type Containers.Count_Type;
Source_Identity : Queue.Source_Info;
Compilation_OK : Boolean;
Slave : Unbounded_String;
begin
if not Bad_Compilations.Is_Empty and then not Opt.Keep_Going then
while Outstanding_Compiles > 0 loop
Await_Compile (Source_Identity, Compilation_OK, Slave);
if not Compilation_OK then
Bad_Compilations.Insert
(Source_Identity.Id, To_String (Slave));
end if;
end loop;
return True;
end if;
return False;
end Must_Exit_Because_Of_Error;
-------------------------------
-- Start_Compile_If_Possible --
-------------------------------
procedure Start_Compile_If_Possible is
Found : Boolean;
Source : Queue.Source_Info;
begin
if not Queue.Is_Empty
and then Outstanding_Compiles < Get_Maximum_Processes
then
Queue.Extract (Found, Source);
if Found then
Initialize_Source_Record (Source.Id);
Process_Project_Phase_1 (Source);
end if;
end if;
end Start_Compile_If_Possible;
-----------------------------
-- Wait_For_Available_Slot --
-----------------------------
procedure Wait_For_Available_Slot is
Source_Identity : Queue.Source_Info;
Compilation_OK : Boolean;
No_Check : Boolean;
Slave : Unbounded_String;
use Queue;
begin
if Outstanding_Compiles = Get_Maximum_Processes
or else (Queue.Is_Virtually_Empty and then Outstanding_Compiles > 0)
then
Await_Compile (Source_Identity, Compilation_OK, Slave);
if Compilation_OK
and then Source_Identity /= Queue.No_Source_Info
then
-- Check if dependencies are on sources in Interfaces and,
-- when --direct-import-only is used, the imported sources
-- come from directly withed projects.
Imports.Reset;
Included_Sources.Set_Last (0);
case Source_Identity.Id.Language.Config.Dependency_Kind is
when None => null;
when Makefile =>
Compilation_OK := Phase_2_Makefile (Source_Identity);
when ALI_File | ALI_Closure =>
Compilation_OK := Phase_2_ALI (Source_Identity);
end case;
-- If the compilation was invalidated, delete the compilation
-- artifacts.
if not Compilation_OK then
if Source_Identity.Id.Dep_Path /= No_Path then
Delete_File
(Get_Name_String (Source_Identity.Id.Dep_Path),
No_Check);
end if;
if Source_Identity.Id.Object_Path /= No_Path then
Delete_File
(Get_Name_String (Source_Identity.Id.Object_Path),
No_Check);
end if;
if Source_Identity.Id.Switches_Path /= No_Path then
Delete_File
(Get_Name_String (Source_Identity.Id.Switches_Path),
No_Check);
end if;
end if;
end if;
if not Compilation_OK then
Bad_Compilations.Insert (Source_Identity.Id, To_String (Slave));
end if;
end if;
end Wait_For_Available_Slot;
-- Start of processing for Compilation_Phase
begin
Outstanding_Compiles := 0;
-- Then process each files in the queue (new files might be added to
-- the queue as a result).
Compilation_Loop :
while not Queue.Is_Empty or else Outstanding_Compiles > 0 loop
exit Compilation_Loop when Must_Exit_Because_Of_Error;
Start_Compile_If_Possible;
Wait_For_Available_Slot;
if Opt.Display_Compilation_Progress then
Write_Str ("completed ");
Write_Int (Int (Queue.Processed));
Write_Str (" out of ");
Write_Int (Int (Queue.Size));
Write_Str (" (");
Write_Int (Int (((Queue.Processed) * 100) / Queue.Size));
Write_Str ("%)...");
Write_Eol;
end if;
end loop Compilation_Loop;
-- Release local memory
declare
Data : Local_Project_Data :=
Local_Projects_HT.Get_First (Local_Projects);
begin
while Data /= No_Local_Project_Data loop
Free (Data.Include_Path);
Free (Data.Imported_Dirs_Switches);
Data := Local_Projects_HT.Get_Next (Local_Projects);
end loop;
Local_Projects_HT.Reset (Local_Projects);
end;
end Compilation_Phase;
---------------------
-- Project_Extends --
---------------------
function Project_Extends
(Extending : Project_Id;
Extended : Project_Id) return Boolean
is
Current : Project_Id := Extending;
begin
loop
if Current = No_Project then
return False;
elsif Current = Extended then
return True;
end if;
Current := Current.Extends;
end loop;
end Project_Extends;
end Gprbuild.Compile;
gprbuild-gpl-2014-src/src/gprbuild-compilation-protocol.ads 0000644 0000767 0000145 00000023651 12323721731 023405 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . C O M P I L A T I O N . P R O T O C O L --
-- --
-- S p e c --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Streams; use Ada.Streams;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with GNAT.OS_Lib; use GNAT;
with GNAT.Sockets; use GNAT.Sockets;
with Gprbuild.Compilation.Process;
package Gprbuild.Compilation.Protocol is
Wrong_Command : exception;
-- Raised when a command cannot be parsed
WD_Path_Tag : constant String := "<1>";
-- The string replacing root working diretory of full path name, see
-- Set_Rewrite below.
CD_Path_Tag : constant String := "<2>";
-- The string replacing the compiler root directory, see Set_Rewrite below
Any_OS : constant String := "any";
-- Used when OS check is not necessary, for example gprclean does not need
-- this check. It is safe to clean-up a Solaris slave from a Windows
-- master.
--
-- Communication
--
type Communication_Channel is private;
-- A communication channel, this channel is used for any communication
-- between the build master and the slaves.
No_Channel : constant Communication_Channel;
function Create (Sock : Socket_Type) return Communication_Channel;
-- Create a communication channel
function Sock (Channel : Communication_Channel) return Socket_Type;
pragma Inline (Sock);
procedure Close (Channel : in out Communication_Channel);
-- Close the channel
procedure Set_Rewrite_WD
(Channel : in out Communication_Channel; Path : String);
-- Add rewrite information for the working directory. This is needed to
-- translate paths to/from build master and slave working directories.
procedure Set_Rewrite_CD
(Channel : in out Communication_Channel; Path : String);
-- Add rewrite information for the compiler directory. This is needed to
-- translate paths to/from compilers path in build master and in slave.
-- This is needed to be able to find the files from other projects
-- installed with the compiler. The translated paths are in the
-- gprbuild mapping file.
procedure Clear_Rewrite (Channel : in out Communication_Channel);
-- Remove any rewrite information from the channel
function Translate_Receive
(Channel : Communication_Channel; Str : String) return String;
-- Translate Str using Channel rewrite
function Translate_Send
(Channel : Communication_Channel; Str : String) return String;
-- Translate Str using Channel rewrite
type Sync_Kind is (Rsync, Gpr);
-- The kind of synchronization used. It is either using rsync external
-- tool based or gprbuild internal protocol.
--
-- Command
--
type Command is private;
type Command_Kind is
(EX, -- execute a command
AK, -- acknowledge received command (with pid)
TS, -- a file timestamp
ES, -- end of file timestamp
FL, -- a file, content being rewritten from builder/slave PATH
FR, -- a RAW file, no rewrite taking place
OK, -- compilation ok (with optional pid)
KO, -- compilation failed (with optional pid)
CX, -- master context
CU, -- clean-up request
DP, -- display output
EC); -- end of compilation
function Kind (Cmd : Command) return Command_Kind;
pragma Inline (Kind);
function Args (Cmd : Command) return OS_Lib.Argument_List_Access;
pragma Inline (Args);
-- Returns all arguments for Cmd
function Output (Cmd : Command) return Unbounded_String;
pragma Inline (Output);
-- Returns the output for a DP command
function Get_Command (Channel : Communication_Channel) return Command;
-- Wait and return a command as parsed from the communication channel
Invalid_Pid : constant := -1;
--
-- From gprbuild
--
procedure Send_Context
(Channel : Communication_Channel;
Target : String;
Project_Name : String;
Build_Env : String;
Sync : Sync_Kind);
-- Send initial context to the slave
procedure Send_Exec
(Channel : Communication_Channel;
Project : String;
Dir : String;
Command : String;
Options : GNAT.OS_Lib.Argument_List;
Obj_Name : String;
Dep_Name : String;
Env : String;
Filter : access function (Str, Sep : String) return String := null);
-- Send a compilation job to a slave. The compilation must be done on
-- Dir. This directory is specified relative to the root directory of
-- the sources. Dep_Name is the dependency file that is generated by this
-- compilation and which must be sent back to the build master after the
-- compilation. Filter is a function used to make path on the command line
-- all relatives to the root directory. The build master root in full path
-- is replaced by Full_Path_Tag. The slaves will change back this tag to
-- the actual full path on their working environment. The Env string is a
-- set of environement variables (name=value[;name=value]) to set before
-- spawning the process.
procedure Send_File
(Channel : Communication_Channel;
Path_Name : String;
Rewrite : Boolean);
-- Path_Name is the full path name to the local filename
procedure Sync_Files
(Channel : Communication_Channel;
Root_Dir : String;
Files : File_Data_Set.Vector);
-- Send a set of filenames and associated timestamps. Will receive a OK or
-- KO with the list of files to be transfered to the slave.
procedure Send_End_Of_Compilation (Channel : Communication_Channel);
-- Send an end of compilation signal, the slave will at this point be able
-- to get jobs from another build master (Get_Context).
procedure Send_End_Of_File_List (Channel : Communication_Channel);
-- Send an end of file list signal, it means that all files timestamps have
-- been checked. After this the compilation can be started.
procedure Get_Pid
(Channel : Communication_Channel;
Pid : out Process.Remote_Id;
Success : out Boolean);
-- Get a process id, Success is set to False in case of failure
procedure Send_Clean_Up
(Channel : Communication_Channel; Project_Name : String);
-- Send a clean-up requets to the slave
--
-- From gprslave
--
procedure Get_Context
(Channel : Communication_Channel;
Target : out Unbounded_String;
Project_Name : out Unbounded_String;
Build_Env : out Unbounded_String;
Sync : out Sync_Kind;
Timestamp : out Time_Stamp_Type;
Version : out Unbounded_String);
-- Wait for an initial context from a build master
procedure Send_Slave_Config
(Channel : Communication_Channel;
Max_Process : Positive;
Root_Directory : String;
Clock_Status : Boolean);
-- Send the slave configuration to the build master
procedure Send_Ack
(Channel : Communication_Channel; Pid : Process.Remote_Id);
-- Send Acknoledgement of a received compilation job
procedure Send_Ok
(Channel : Communication_Channel; Pid : Process.Remote_Id);
-- Send Pid of a successful command
procedure Send_Ko
(Channel : Communication_Channel; Pid : Process.Remote_Id);
-- Send Pid of an un-successful command
procedure Send_Ok (Channel : Communication_Channel);
-- Send Ok for a successful command (clean-up for example)
procedure Send_Ko (Channel : Communication_Channel);
-- Send Ko to initial handshake (slave not compatible with master for
-- example).
procedure Send_Ko
(Channel : Communication_Channel;
Files : File_Data_Set.Vector);
-- Send a Ko message with a list of file names
procedure Send_Output (Channel : Communication_Channel; File_Name : String);
-- Send an output of a command
function Get_Raw_Data
(Channel : Communication_Channel) return Stream_Element_Array;
-- Get a Stream_Element_Array from the channel and return it
private
type Communication_Channel is record
Sock : Socket_Type;
Channel : Stream_Access;
WD_From, WD_To : Unbounded_String; -- working directory
CD_From, CD_To : Unbounded_String; -- compiler directory
end record;
No_Channel : constant Communication_Channel :=
(Sock => <>,
Channel => null,
others => Null_Unbounded_String);
type Command is record
Cmd : Command_Kind;
Args : Argument_List_Access;
Output : Unbounded_String;
end record;
end Gprbuild.Compilation.Protocol;
gprbuild-gpl-2014-src/src/gprbuild-compilation-sync.adb 0000644 0000767 0000145 00000052342 12323721731 022476 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . C O M P I L A T I O N . S L A V E --
-- --
-- B o d y --
-- --
-- Copyright (C) 2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Containers.Indefinite_Ordered_Maps;
with Ada.Containers.Vectors;
with Ada.Directories; use Ada.Directories;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with GNAT.Regexp; use GNAT.Regexp;
with Gpr_Util; use Gpr_Util;
with Output; use Output;
package body Gprbuild.Compilation.Sync is
use Ada;
use type Containers.Count_Type;
package Hosts_Set is
new Containers.Indefinite_Ordered_Maps (Integer, String);
procedure Wait_Rsync (N : Natural);
-- Wait for N rsync processes. If one of the is in error exit
function User_Host (User, Host : String) return String is
(if User = "" then Host else User & '@' & Host);
Default_Excluded_Patterns : Str_Vect.Vector;
-- Default excluded patterns to use when in excluded mode as opposed to
-- include mode where we describe the patterns to include specifically.
Rsync_Cmd : constant GNAT.OS_Lib.String_Access :=
Locate_Exec_On_Path ("rsync");
Rsync_Count : Natural := 0;
-- The number of rsync process started, we need to wait for them to
-- terminate.
Max_Gpr_Sync : constant := 10;
-- The number of parallele synchronization done for the gpr protocol. This
-- is currenlty fixed to 6 but could probable be a parameter. The number is
-- high, as these tasks are mostly doing IO and so are not CPU demanding,
-- the goal is to saturate the network bandwidth.
Hosts : Hosts_Set.Map;
procedure To_Slave_Rsync
(Project_Name : String;
Root_Dir : String;
Slave_Root_Dir : String;
User : String;
Host : String;
Excluded_Patterns : Str_Vect.Vector;
Included_Patterns : Str_Vect.Vector);
-- Rsync based synchronization to the slave
procedure From_Slave_Rsync
(Project_Name : String;
Root_Dir : String;
Slave_Root_Dir : String;
User : String;
Host : String;
Included_Artifact_Patterns : Str_Vect.Vector);
-- Rsync based synchronization from the slave
procedure To_Slave_Gpr
(Channel : Protocol.Communication_Channel;
Project_Name : String;
Root_Dir : String;
Slave_Root_Dir : String;
User : String;
Host : String;
Excluded_Patterns : Str_Vect.Vector;
Included_Patterns : Str_Vect.Vector);
-- Gpr based synchronization to the slave
-- Data for each synchronization job for the Gpr protocol
type Gpr_Data is record
Channel : Protocol.Communication_Channel;
Project_Name : Unbounded_String;
Root_Dir : Unbounded_String;
Slave_Root_Dir : Unbounded_String;
User, Host : Unbounded_String;
Excluded_Patterns : Str_Vect.Vector;
Included_Patterns : Str_Vect.Vector;
end record;
package Gpr_Data_Set is new Containers.Vectors (Positive, Gpr_Data);
-- Queue of job to be done for the gpr protocol
protected Gpr_Queue is
procedure Add (Job : Gpr_Data);
-- Add a new synchronization job
entry Get
(Job : out Gpr_Data;
Files : out File_Data_Set.Vector;
Stop : out Boolean);
-- Get a synchronization job with the corresponding files, Stop is set
-- to True if there is no more job to handle and False otherwise.
procedure No_More_Job;
private
procedure Set_Project_Files (Job : Gpr_Data);
-- Set the project files to be synchronized
Jobs : Gpr_Data_Set.Vector;
Project_Files : File_Data_Set.Vector;
PF_Initialized : Boolean := False;
No_More : Boolean := False;
end Gpr_Queue;
-- Synchronization job are handled by the Gpr_Sync tasks
task type Gpr_Sync is
entry Stop;
end Gpr_Sync;
type Gpr_Sync_Tasks is array (1 .. Max_Gpr_Sync) of Gpr_Sync;
type Sync_Tasks_Ref is access all Gpr_Sync_Tasks;
Sync_Tasks : Sync_Tasks_Ref;
-- Only allocated (and so started) if a some slaves are using the gpr
-- protocol. Otherwise this variable will stay null.
----------------
-- From_Slave --
----------------
procedure From_Slave
(Sync : Protocol.Sync_Kind;
Project_Name : String;
Root_Dir : String;
Slave_Root_Dir : String;
User : String;
Host : String;
Included_Artifact_Patterns : Str_Vect.Vector) is
begin
case Sync is
when Protocol.Gpr =>
-- Nothing to do as the artifacts are copied after each
-- compilation.
null;
when Protocol.Rsync =>
From_Slave_Rsync
(Project_Name, Root_Dir, Slave_Root_Dir, User, Host,
Included_Artifact_Patterns);
end case;
end From_Slave;
----------------------
-- From_Slave_Rsync --
----------------------
procedure From_Slave_Rsync
(Project_Name : String;
Root_Dir : String;
Slave_Root_Dir : String;
User : String;
Host : String;
Included_Artifact_Patterns : Str_Vect.Vector)
is
Args : Argument_List
(1 ..
6 + Positive'Max
(4, Natural (Included_Artifact_Patterns.Length)));
N : Positive range 3 .. Args'Last := 3;
Pid : Process_Id;
begin
-- Archive mode, compression and ignore VCS
Args (1) := new String'("-az");
Args (2) := new String'("--update");
-- Check all subdirectories
Args (3) := new String'("--include=*/");
if Included_Artifact_Patterns.Length = 0 then
-- Include known suffix (objects, dependencies)
Args (4) := new String'("--include=*.o");
Args (5) := new String'("--include=*.gli");
Args (6) := new String'("--include=*.obj");
Args (7) := new String'("--include=*.coff");
N := 7;
else
for P of Included_Artifact_Patterns loop
N := N + 1;
Args (N) := new String'("--include=" & P);
end loop;
end if;
-- Exclude everything else
N := N + 1;
Args (N) := new String'("--exclude=*");
-- Local and remote directory
N := N + 1;
Args (N) := new String'
(User_Host (User, Host)
& ":" & Compose (Slave_Root_Dir, Project_Name) & "/");
N := N + 1;
Args (N) := new String'(Root_Dir);
if Opt.Verbose_Mode then
Write_Line (" synchronize back data");
Write_Line (" from: " & Args (N - 1).all);
Write_Line (" to : " & Args (N).all);
end if;
Pid := Non_Blocking_Spawn (Rsync_Cmd.all, Args (1 .. N));
Hosts.Insert (Pid_To_Integer (Pid), Host);
for A of Args loop
Free (A);
end loop;
end From_Slave_Rsync;
---------------
-- Gpr_Queue --
---------------
protected body Gpr_Queue is
---------
-- Add --
---------
procedure Add (Job : Gpr_Data) is
begin
Jobs.Append (Job);
end Add;
---------
-- Get --
---------
entry Get
(Job : out Gpr_Data;
Files : out File_Data_Set.Vector;
Stop : out Boolean) when Jobs.Length > 0 or No_More is
begin
if Jobs.Length = 0 and then No_More then
Stop := True;
else
Stop := False;
Job := Jobs.First_Element;
Jobs.Delete_First;
if not PF_Initialized then
Set_Project_Files (Job);
end if;
Files := Project_Files;
end if;
end Get;
-----------------
-- No_More_Job --
-----------------
procedure No_More_Job is
begin
No_More := True;
end No_More_Job;
-----------------------
-- Set_Project_Files --
-----------------------
procedure Set_Project_Files (Job : Gpr_Data) is
Root_Dir : constant String :=
(if Job.Root_Dir = Null_Unbounded_String
then "." else To_String (Job.Root_Dir));
type Regexp_Set is array (Containers.Count_Type range <>) of Regexp;
I_Regexp : Regexp_Set (1 .. Job.Included_Patterns.Length);
E_Regexp : Regexp_Set (1 .. Job.Excluded_Patterns.Length
+ Default_Excluded_Patterns.Length);
procedure Process (Prefix : String);
procedure Process (Prefix : String) is
procedure Check (File : Directory_Entry_Type);
-- Check and add this file if it passes the filters
-----------
-- Check --
-----------
procedure Check (File : Directory_Entry_Type) is
use GNAT;
function Match
(Name : String; R_Set : Regexp_Set)
return Boolean with Inline;
-- Returns true if Name is matched by one of the regexp in
-- R_Set.
-----------
-- Match --
-----------
function Match
(Name : String; R_Set : Regexp_Set) return Boolean is
begin
for Regexp of R_Set loop
if Match (Name, Regexp) then
return True;
end if;
end loop;
return False;
end Match;
S_Name : constant String := Simple_Name (File);
Entry_Name : constant String := Prefix & S_Name;
Is_File : Boolean;
begin
if Kind (File) = Directory then
if S_Name not in "." | ".."
and then (I_Regexp'Length /= 0
or else not Match (S_Name, E_Regexp))
and then not Is_Symbolic_Link
(Root_Dir & Directory_Separator & Entry_Name)
then
Process (Entry_Name & Directory_Separator);
end if;
else
if I_Regexp'Length = 0 then
if Match (S_Name, E_Regexp) then
Is_File := False;
else
Is_File := True;
end if;
else
if Match (S_Name, I_Regexp) then
Is_File := True;
else
Is_File := False;
end if;
end if;
if Is_File then
Project_Files.Append
(File_Data'
(To_Unbounded_String (Entry_Name),
To_Time_Stamp (Modification_Time (File)),
Dummy_Time_Stamp));
end if;
end if;
end Check;
begin
Search
(Directory =>
Root_Dir
& (if Prefix = "" then "" else Directory_Separator & Prefix),
Pattern => "*",
Filter => (Special_File => False, others => True),
Process => Check'Access);
end Process;
begin
-- Compile the patterns
declare
K : Containers.Count_Type := 1;
begin
for P of Job.Included_Patterns loop
I_Regexp (K) := Compile (P, Glob => True);
K := K + 1;
end loop;
K := 1;
for P of Default_Excluded_Patterns loop
E_Regexp (K) := Compile (P, Glob => True);
K := K + 1;
end loop;
for P of Job.Excluded_Patterns loop
E_Regexp (K) := Compile (P, Glob => True);
K := K + 1;
end loop;
end;
-- Check the files under the project root
Process (Prefix => "");
PF_Initialized := True;
end Set_Project_Files;
end Gpr_Queue;
--------------
-- Gpr_Sync --
--------------
task body Gpr_Sync is
Job : Gpr_Data;
Files : File_Data_Set.Vector;
No_More_Job : Boolean;
begin
For_Slave : loop
-- Get a new job and the associated files if any
Gpr_Queue.Get (Job, Files, No_More_Job);
exit For_Slave when No_More_Job;
declare
Chunk_Size : constant := 500;
-- This constant controls the number of files sent with the sync
-- command. Doing one at a time is really time consumming as
-- we have for every file and send and a receive command on
-- the socket.
F_List : File_Data_Set.Vector;
Count : Natural := 0;
begin
-- Synchronize each file in the list we got
for F of Files loop
if Count = Chunk_Size then
Protocol.Sync_Files
(Job.Channel, To_String (Job.Root_Dir), F_List);
F_List.Clear;
Count := 0;
end if;
F_List.Append (F);
Count := Count + 1;
end loop;
-- Then send the last chunk if any
if Count /= 0 then
Protocol.Sync_Files
(Job.Channel, To_String (Job.Root_Dir), F_List);
end if;
Protocol.Send_End_Of_File_List (Job.Channel);
end;
end loop For_Slave;
accept Stop;
exception
when E : others =>
Write_Line (Exception_Information (E));
OS_Exit (1);
end Gpr_Sync;
--------------
-- To_Slave --
--------------
procedure To_Slave
(Sync : Protocol.Sync_Kind;
Channel : Protocol.Communication_Channel;
Project_Name : String;
Root_Dir : String;
Slave_Root_Dir : String;
User : String;
Host : String;
Excluded_Patterns : Str_Vect.Vector;
Included_Patterns : Str_Vect.Vector) is
begin
case Sync is
when Protocol.Gpr =>
To_Slave_Gpr
(Channel, Project_Name, Root_Dir, Slave_Root_Dir, User, Host,
Excluded_Patterns, Included_Patterns);
when Protocol.Rsync =>
To_Slave_Rsync
(Project_Name, Root_Dir, Slave_Root_Dir, User, Host,
Excluded_Patterns, Included_Patterns);
end case;
end To_Slave;
------------------
-- To_Slave_Gpr --
------------------
procedure To_Slave_Gpr
(Channel : Protocol.Communication_Channel;
Project_Name : String;
Root_Dir : String;
Slave_Root_Dir : String;
User : String;
Host : String;
Excluded_Patterns : Str_Vect.Vector;
Included_Patterns : Str_Vect.Vector) is
begin
-- Starts the tasks if not already done
if Sync_Tasks = null then
Sync_Tasks := new Gpr_Sync_Tasks;
end if;
Gpr_Queue.Add
(Gpr_Data'
(Channel,
To_Unbounded_String (Project_Name),
To_Unbounded_String (Root_Dir),
To_Unbounded_String (Slave_Root_Dir),
To_Unbounded_String (User),
To_Unbounded_String (Host),
Excluded_Patterns, Included_Patterns));
end To_Slave_Gpr;
--------------------
-- To_Slave_Rsync --
--------------------
procedure To_Slave_Rsync
(Project_Name : String;
Root_Dir : String;
Slave_Root_Dir : String;
User : String;
Host : String;
Excluded_Patterns : Str_Vect.Vector;
Included_Patterns : Str_Vect.Vector)
is
procedure Add_Arg (Str : String);
-- Add new argument
Args : Argument_List
(1 ..
6 + Positive'Max
(11 + Natural (Excluded_Patterns.Length),
2 + Natural (Included_Patterns.Length)));
N : Natural range 0 .. Args'Last := 0;
--------------
-- Add_Args --
--------------
procedure Add_Arg (Str : String) is
begin
N := N + 1;
Args (N) := new String'(Str);
end Add_Arg;
Pid : Process_Id;
begin
-- Check for rsync tool
if Rsync_Cmd = null then
Write_Line
("error: rsync not found for " & Host);
OS_Exit (1);
end if;
-- Archive mode, compression and ignore VCS
Add_Arg ("-arz");
if Included_Patterns.Length = 0 then
-- Default excluded patterns objects/ali
for P of Default_Excluded_Patterns loop
Add_Arg ("--exclude=" & P);
end loop;
-- Add any user's defined excluded patterns
for P of Excluded_Patterns loop
Add_Arg ("--exclude=" & P);
end loop;
else
-- Include sub-directories
Add_Arg ("--include=*/");
-- Add any user's defined included patterns
for P of Included_Patterns loop
Add_Arg ("--include=" & P);
end loop;
-- Then we exclude everything else
Add_Arg ("--exclude=*");
end if;
-- Delete remote files not in local directory
Add_Arg ("--delete-excluded");
Add_Arg ("--delete");
Add_Arg ("--copy-links");
-- Local and remote directory
Add_Arg (Root_Dir & "/");
Add_Arg
(User_Host (User, Host) & ":"
& Compose (Slave_Root_Dir, Project_Name));
if Opt.Verbose_Mode then
Write_Line (" synchronize data");
Write_Line (" from: " & Args (N - 1).all);
Write_Line (" to : " & Args (N).all);
end if;
Pid := Non_Blocking_Spawn (Rsync_Cmd.all, Args (1 .. N));
Hosts.Insert (Pid_To_Integer (Pid), Host);
Rsync_Count := Rsync_Count + 1;
for A of Args (1 .. N) loop
Free (A);
end loop;
end To_Slave_Rsync;
----------------
-- Wait_Rsync --
----------------
procedure Wait_Rsync (N : Natural) is
Pid : Process_Id;
Success : Boolean;
Error : Boolean := False;
Host : Hosts_Set.Cursor;
begin
for K in 1 .. N loop
Wait_Process (Pid, Success);
Host := Hosts.Find (Pid_To_Integer (Pid));
if Success then
if Opt.Verbose_Mode then
Write_Line
(" synchronization done for " & Hosts_Set.Element (Host));
end if;
else
Error := True;
Write_Line ("error: rsync on " & Hosts_Set.Element (Host));
end if;
end loop;
-- If there is any error we cannot continue, just exit now
if Error then
OS_Exit (1);
end if;
end Wait_Rsync;
----------
-- Wait --
----------
procedure Wait is
begin
Gpr_Queue.No_More_Job;
Wait_Rsync (Rsync_Count);
if Sync_Tasks /= null then
for T of Sync_Tasks.all loop
if not T'Terminated then
T.Stop;
end if;
end loop;
end if;
end Wait;
begin
Default_Excluded_Patterns.Append ("*.o");
Default_Excluded_Patterns.Append ("*.obj");
Default_Excluded_Patterns.Append ("*.ali");
Default_Excluded_Patterns.Append ("*.dll");
Default_Excluded_Patterns.Append ("*.so");
Default_Excluded_Patterns.Append ("*.so.*");
Default_Excluded_Patterns.Append ("*.exe");
Default_Excluded_Patterns.Append (".git");
Default_Excluded_Patterns.Append (".svn");
Default_Excluded_Patterns.Append ("CVS");
Default_Excluded_Patterns.Append ("gnatinspect.db*");
end Gprbuild.Compilation.Sync;
gprbuild-gpl-2014-src/src/gprbuild-compilation-result.adb 0000644 0000767 0000145 00000007241 12323721731 023036 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D . C O M P I L A T I O N . R E S U L T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Containers.Doubly_Linked_Lists;
with Gpr_Util; use Gpr_Util;
package body Gprbuild.Compilation.Result is
use Ada;
use type Containers.Count_Type;
type Process_Data is record
Process : Id;
Status : Boolean;
end record;
package Endded_Process is new Containers.Doubly_Linked_Lists (Process_Data);
protected Results is
procedure Add (Result : Process_Data);
entry Get (Result : out Process_Data);
private
List : Endded_Process.List;
end Results;
---------
-- Add --
---------
procedure Add (Process : Id; Status : Boolean; Slave : String := "") is
begin
Results.Add (Process_Data'(Process, Status));
-- For a compilation failure records the slave to be able to report it
if not Status and then Slave /= "" then
Record_Remote_Failure (Process, Slave);
end if;
end Add;
-------------
-- Results --
-------------
protected body Results is
---------
-- Add --
---------
procedure Add (Result : Process_Data) is
begin
List.Append (Result);
end Add;
---------
-- Get --
---------
entry Get (Result : out Process_Data) when List.Length /= 0 is
begin
Result := List.First_Element;
List.Delete_First;
end Get;
end Results;
----------
-- Wait --
----------
procedure Wait (Process : out Id; Status : out Boolean) is
Data : Process_Data;
Pid : Process_Id;
begin
-- In distributed mode we wait for a result to be available into the
-- shared Results list. This list is filed with results from local
-- process (see Compilation.Process.Wait_Local) and also with the
-- remotes ones (see Compilation.Slave.Wait_Remote).
if Distributed_Mode then
Results.Get (Data);
Process := Data.Process;
Status := Data.Status;
else
-- In non distributed mode just wait for a compilation to terminate
Wait_Process (Pid, Status);
Process := Create_Local (Pid);
end if;
end Wait;
end Gprbuild.Compilation.Result;
gprbuild-gpl-2014-src/src/gpr_util-knowledge-vms.adb 0000644 0000767 0000145 00000004124 12323721731 022000 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R _ U T I L . K N O W L E D G E --
-- --
-- B o d y --
-- --
-- Copyright (C) 2010-2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- This is the VMS dummy version of this package
separate (Gpr_Util)
package body Knowledge is
-------------------------
-- Normalized_Hostname --
-------------------------
function Normalized_Hostname return String is
begin
return "";
end Normalized_Hostname;
--------------------------
-- Parse_Knowledge_Base --
--------------------------
procedure Parse_Knowledge_Base (Directory : String := "") is
pragma Unreferenced (Directory);
begin
null;
end Parse_Knowledge_Base;
end Knowledge;
gprbuild-gpl-2014-src/src/gprinstall.exe.manifest 0000644 0000767 0000145 00000001165 12064643534 021422 0 ustar gnatmail gnat
Description of your application
gprbuild-gpl-2014-src/src/gprinstall-install.adb 0000644 0000767 0000145 00000225600 12323721731 021222 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R I N S T A L L . M A I N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2012-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Containers.Indefinite_Vectors; use Ada;
with Ada.Containers.Indefinite_Ordered_Sets;
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Vectors;
with Ada.Directories; use Ada.Directories;
with Ada.Strings.Equal_Case_Insensitive;
with Ada.Strings.Less_Case_Insensitive;
with Ada.Strings.Fixed; use Ada.Strings;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.MD5; use GNAT.MD5;
with Gpr_Util; use Gpr_Util;
with GPR_Version; use GPR_Version;
with Namet; use Namet;
with Opt;
with Osint;
with Output; use Output;
with Prj.Util; use Prj.Util;
with Snames; use Snames;
package body Gprinstall.Install is
package Name_Id_Set is new Containers.Ordered_Sets (Name_Id);
Installed : Name_Id_Set.Set;
-- Record already installed project
-------------
-- Process --
-------------
procedure Process
(Tree : Project_Tree_Ref;
Project : Project_Id)
is
Windows_Target : constant Boolean :=
Get_Name_String
(Project.Config.Shared_Lib_Suffix) = ".dll";
Pcks : Package_Table.Table_Ptr renames Tree.Shared.Packages.Table;
Strs : String_Element_Table.Table_Ptr renames
Tree.Shared.String_Elements.Table;
-- Local values for the given project, these are initially set with the
-- default values. It is updated using the Install package found in the
-- project if any.
Active : Boolean := True;
-- Whether installation is active or not (Install package's attribute)
Prefix_Dir : Param := Dup (Global_Prefix_Dir);
Exec_Subdir : Param := Dup (Global_Exec_Subdir);
Lib_Subdir : Param := Dup (Global_Lib_Subdir);
Link_Lib_Subdir : Param := Dup (Global_Link_Lib_Subdir);
Sources_Subdir : Param := Dup (Global_Sources_Subdir);
Project_Subdir : Param := Dup (Global_Project_Subdir);
type Items is (Source, Object, Dependency, Library, Executable);
Copy : array (Items) of Boolean := (others => False);
-- What should be copied from a project, this depends on the actual
-- project kind and the mode (usage, dev) set for the install.
Man : Text_IO.File_Type;
-- File where manifest for this project is kept
-- Keeping track of artifacts to install
type Artifacts_Data is record
Destination, Filename : Name_Id;
end record;
package Artifacts_Set is
new Containers.Vectors (Positive, Artifacts_Data);
Artifacts : Artifacts_Set.Vector;
procedure Copy_File
(From, To, File : String;
Sym_Link : Boolean := False;
Executable : Boolean := False);
-- Copy file From into To, if Sym_Link is set a symbolic link is
-- created. If Executable is set, the destination file exec attribute
-- is set.
function Dir_Name (Suffix : Boolean := True) return String;
-- Returns the name of directory where project files are to be
-- installed. This name is the name of the project. If Suffix is
-- True then the build name is also returned.
function Cat
(Dir : Path_Name_Type; File : File_Name_Type) return String;
pragma Inline (Cat);
-- Returns the string which is the catenation of Dir and File
function Sources_Dir (Build_Name : Boolean := True) return String;
-- Returns the full pathname to the sources destination directory
function Exec_Dir return String;
-- Returns the full pathname to the executable destination directory
function Lib_Dir (Build_Name : Boolean := True) return String;
-- Returns the full pathname to the library destination directory
function Link_Lib_Dir return String;
-- Returns the full pathname to the lib symlib directory
function Project_Dir return String;
-- Returns the full pathname to the project destination directory
procedure Check_Install_Package;
-- Check Project's install package and overwrite the default values of
-- the corresponding variables above.
procedure Copy_Files;
-- Do the file copues for the project's sources, object, library,
-- executable.
procedure Create_Project (Project : Project_Id);
-- Create install project for the given project
procedure Add_To_Manifest (Pathname : String);
-- Add filename to manifest
function Get_Library_Filename return File_Name_Type;
-- Returns the actual file name for the library
function Has_Sources (Project : Project_Id) return Boolean;
pragma Inline (Has_Sources);
-- Returns True if the project contains sources
function Bring_Sources (Project : Project_Id) return Boolean;
-- Returns True if Project gives visibility to some sources directly or
-- indirectly via the with clauses.
function Main_Binary (Source : Name_Id) return String;
-- Give the source name found in the Main attribute, returns the actual
-- binary as built by gprbuild. This routine looks into the Builder
-- switches for a the Executable attribute.
function Is_Install_Active
(Tree : Project_Tree_Ref;
Project : Project_Id) return Boolean;
-- Returns True if the Project is active, that is there is no attribute
-- Activer set to False in the Install package.
procedure Open_Check_Manifest;
-- Check that manifest file can be used
---------------------
-- Add_To_Manifest --
---------------------
procedure Add_To_Manifest (Pathname : String) is
Prefix_Len : constant Natural := Prefix_Dir.V'Length;
begin
if not Is_Open (Man) then
Open_Check_Manifest;
end if;
-- Append entry into manifest
Put_Line
(Man,
File_MD5 (Pathname) & " "
-- Remove the prefix, we want to store the pathname relative to
-- the prefix of installation.
& Pathname (Pathname'First + Prefix_Len .. Pathname'Last));
end Add_To_Manifest;
-------------------
-- Bring_Sources --
-------------------
function Bring_Sources (Project : Project_Id) return Boolean is
begin
if Has_Sources (Project) then
return True;
else
declare
List : Project_List := Project.All_Imported_Projects;
begin
while List /= null loop
if Has_Sources (List.Project) then
return True;
end if;
List := List.Next;
end loop;
end;
end if;
return False;
end Bring_Sources;
---------------------------
-- Check_Install_Package --
---------------------------
procedure Check_Install_Package is
Pck : Package_Id := Project.Decl.Packages;
procedure Replace (P : in out Param; Val : Name_Id);
pragma Inline (Replace);
-- Set Var with Value, free previous pointer
-------------
-- Replace --
-------------
procedure Replace (P : in out Param; Val : Name_Id) is
V : constant String := Ensure_Directory (Get_Name_String (Val));
begin
if V /= "" then
Free (P.V);
P := (new String'(V), Default => False);
end if;
end Replace;
begin
Look_Install_Package : while Pck /= No_Package loop
if Pcks (Pck).Decl /= No_Declarations
and then Pcks (Pck).Name = Name_Install
then
-- Found Install package, check attributes
declare
Id : Variable_Id := Pcks (Pck).Decl.Attributes;
begin
while Id /= No_Variable loop
declare
V : constant Variable :=
Tree.Shared.Variable_Elements.Table (Id);
begin
if V.Name = Name_Prefix
and then Global_Prefix_Dir.Default
then
Replace (Prefix_Dir, V.Value.Value);
elsif V.Name = Name_Exec_Subdir
and then Global_Exec_Subdir.Default
then
Replace (Exec_Subdir, V.Value.Value);
elsif V.Name = Name_Lib_Subdir
and then Global_Lib_Subdir.Default
then
Replace (Lib_Subdir, V.Value.Value);
elsif V.Name = Name_Link_Lib_Subdir
and then Global_Link_Lib_Subdir.Default
then
Replace (Link_Lib_Subdir, V.Value.Value);
elsif V.Name = Name_Sources_Subdir
and then Global_Sources_Subdir.Default
then
Replace (Sources_Subdir, V.Value.Value);
elsif V.Name = Name_Project_Subdir
and then Global_Project_Subdir.Default
then
Replace (Project_Subdir, V.Value.Value);
elsif V.Name = Name_Active then
declare
Val : constant String :=
To_Lower
(Get_Name_String (V.Value.Value));
begin
if Val = "false" then
Active := False;
else
Active := True;
end if;
end;
end if;
end;
Id := Tree.Shared.Variable_Elements.Table (Id).Next;
end loop;
end;
-- Now check arrays
declare
Id : Array_Id := Pcks (Pck).Decl.Arrays;
begin
while Id /= No_Array loop
declare
V : constant Array_Data :=
Tree.Shared.Arrays.Table (Id);
begin
if V.Name = Name_Artifacts then
declare
Eid : Array_Element_Id := V.Value;
begin
while Eid /= No_Array_Element loop
declare
E : constant Array_Element :=
Tree.Shared.Array_Elements.Table
(Eid);
S : String_List_Id := E.Value.Values;
begin
while S /= Nil_String loop
Artifacts.Append
(Artifacts_Data'
(E.Index, Strs (S).Value));
S := Strs (S).Next;
end loop;
end;
Eid := Tree.Shared.Array_Elements.
Table (Eid).Next;
end loop;
end;
end if;
end;
Id := Tree.Shared.Arrays.Table (Id).Next;
end loop;
end;
exit Look_Install_Package;
end if;
Pck := Pcks (Pck).Next;
end loop Look_Install_Package;
end Check_Install_Package;
--------------
-- Dir_Name --
--------------
function Dir_Name (Suffix : Boolean := True) return String is
function Get_Suffix return String;
-- Returns a suffix if needed
----------------
-- Get_Suffix --
----------------
function Get_Suffix return String is
begin
-- .default is always ommitted from the directory name
if Suffix and then Build_Name.all /= "default" then
return '.' & Build_Name.all;
else
return "";
end if;
end Get_Suffix;
begin
return Get_Name_String (Project.Name) & Get_Suffix;
end Dir_Name;
---------------------------
-- Get_Library_Filenaame --
---------------------------
function Get_Library_Filename return File_Name_Type is
begin
-- Library prefix
Name_Len := 0;
if Project.Library_Kind /= Static
and then Project.Config.Shared_Lib_Prefix /= No_File
then
Add_Str_To_Name_Buffer
(Get_Name_String (Project.Config.Shared_Lib_Prefix));
else
Add_Str_To_Name_Buffer ("lib");
end if;
-- Library name
Add_Str_To_Name_Buffer (Get_Name_String (Project.Library_Name));
-- Library suffix
if Project.Library_Kind = Static
and then Project.Config.Archive_Suffix /= No_File
then
Add_Str_To_Name_Buffer
(Get_Name_String (Project.Config.Archive_Suffix));
elsif Project.Library_Kind /= Static
and then Project.Config.Shared_Lib_Suffix /= No_File
then
Add_Str_To_Name_Buffer
(Get_Name_String (Project.Config.Shared_Lib_Suffix));
else
Add_Str_To_Name_Buffer (".so");
end if;
return Name_Find;
end Get_Library_Filename;
-----------------------
-- Is_Install_Active --
-----------------------
function Is_Install_Active
(Tree : Project_Tree_Ref;
Project : Project_Id) return Boolean
is
Pcks : Package_Table.Table_Ptr renames Tree.Shared.Packages.Table;
Pck : Package_Id := Project.Decl.Packages;
begin
Look_Install_Package : while Pck /= No_Package loop
if Pcks (Pck).Decl /= No_Declarations
and then Pcks (Pck).Name = Name_Install
then
-- Found Install package, check attributes
declare
Id : Variable_Id := Pcks (Pck).Decl.Attributes;
begin
while Id /= No_Variable loop
declare
V : constant Variable :=
Tree.Shared.Variable_Elements.Table (Id);
begin
if V.Name = Name_Active then
declare
Val : constant String :=
To_Lower
(Get_Name_String (V.Value.Value));
begin
if Val = "false" then
return False;
else
return True;
end if;
end;
end if;
end;
Id := Tree.Shared.Variable_Elements.Table (Id).Next;
end loop;
end;
exit Look_Install_Package;
end if;
Pck := Pcks (Pck).Next;
end loop Look_Install_Package;
-- If not defined, the default is active
return True;
end Is_Install_Active;
-----------------
-- Main_Binary --
-----------------
function Main_Binary (Source : Name_Id) return String is
function Get_Exec_Suffix return String;
-- Return the target executable suffix
---------------------
-- Get_Exec_Suffix --
---------------------
function Get_Exec_Suffix return String is
begin
if Project.Config.Executable_Suffix = No_Name then
return "";
else
return Get_Name_String (Project.Config.Executable_Suffix);
end if;
end Get_Exec_Suffix;
Builder_Package : constant Package_Id :=
Value_Of
(Name_Builder, Main_Project.Decl.Packages,
Project_Tree.Shared);
Value : Variable_Value;
begin
if Builder_Package /= No_Package then
Value := Value_Of
(Name => Source,
Attribute_Or_Array_Name => Name_Executable,
In_Package => Builder_Package,
Shared => Project_Tree.Shared);
if Value = Nil_Variable_Value then
-- If not found and name has an extension, try without
declare
Name : constant String := Get_Name_String (Source);
S : Name_Id;
begin
if Name /= Base_Name (Name) then
Name_Len := 0;
Add_Str_To_Name_Buffer (Base_Name (Name));
S := Name_Find;
Value := Value_Of
(Name => S,
Attribute_Or_Array_Name => Name_Executable,
In_Package => Builder_Package,
Shared => Project_Tree.Shared);
end if;
end;
end if;
end if;
if Value = Nil_Variable_Value then
return Base_Name (Get_Name_String (Source)) & Get_Exec_Suffix;
else
return Get_Name_String (Value.Value) & Get_Exec_Suffix;
end if;
end Main_Binary;
-----------------
-- Has_Sources --
-----------------
function Has_Sources (Project : Project_Id) return Boolean is
begin
return Project.Source_Dirs /= Nil_String
or else Project.Qualifier = Aggregate_Library;
end Has_Sources;
--------------
-- Exec_Dir --
--------------
function Exec_Dir return String is
begin
if Is_Absolute_Path (Exec_Subdir.V.all) then
return Exec_Subdir.V.all;
else
return Prefix_Dir.V.all & Exec_Subdir.V.all;
end if;
end Exec_Dir;
-------------
-- Lib_Dir --
-------------
function Lib_Dir (Build_Name : Boolean := True) return String is
begin
if Is_Absolute_Path (Lib_Subdir.V.all) then
return Lib_Subdir.V.all;
elsif not Lib_Subdir.Default or else not Build_Name then
return Prefix_Dir.V.all & Lib_Subdir.V.all;
else
return Ensure_Directory
(Prefix_Dir.V.all & Lib_Subdir.V.all & Dir_Name);
end if;
end Lib_Dir;
------------------
-- Link_Lib_Dir --
------------------
function Link_Lib_Dir return String is
begin
if Is_Absolute_Path (Link_Lib_Subdir.V.all) then
return Link_Lib_Subdir.V.all;
else
return Prefix_Dir.V.all & Link_Lib_Subdir.V.all;
end if;
end Link_Lib_Dir;
-----------------
-- Sources_Dir --
-----------------
function Sources_Dir (Build_Name : Boolean := True) return String is
begin
if Is_Absolute_Path (Sources_Subdir.V.all) then
return Sources_Subdir.V.all;
elsif not Sources_Subdir.Default or else not Build_Name then
return Prefix_Dir.V.all & Sources_Subdir.V.all;
else
return Ensure_Directory
(Prefix_Dir.V.all & Sources_Subdir.V.all & Dir_Name);
end if;
end Sources_Dir;
-----------------
-- Project_Dir --
-----------------
function Project_Dir return String is
begin
if Is_Absolute_Path (Project_Subdir.V.all) then
return Project_Subdir.V.all;
else
return Prefix_Dir.V.all & Project_Subdir.V.all;
end if;
end Project_Dir;
---------
-- Cat --
---------
function Cat
(Dir : Path_Name_Type; File : File_Name_Type) return String is
begin
return Get_Name_String (Dir) & Get_Name_String (File);
end Cat;
---------------
-- Copy_File --
---------------
procedure Copy_File
(From, To, File : String;
Sym_Link : Boolean := False;
Executable : Boolean := False)
is
Dest_Filename : constant String := To & File;
begin
if not Sym_Link
and then Exists (Dest_Filename)
and then not Force_Installations
then
Write_Str ("file ");
Write_Str (File);
Write_Str (" exists, use -f to overwrite");
Write_Eol;
OS_Exit (1);
end if;
if Dry_Run or else Opt.Verbose_Mode then
if Sym_Link then
Write_Str ("ln -s ");
else
Write_Str ("cp ");
end if;
Write_Str (From);
Write_Str (" ");
Write_Str (Dest_Filename);
Write_Eol;
end if;
if not Dry_Run then
if not Sym_Link and then not Exists (From) then
Write_Str ("file ");
Write_Str (From);
Write_Str (" does not exist, build may not be complete");
Write_Eol;
OS_Exit (1);
end if;
if (not Sym_Link and then not Exists (To))
or else (Sym_Link and then not Exists (From))
then
if Create_Dest_Dir then
if Sym_Link then
Create_Path (Containing_Directory (From));
else
Create_Path (To);
end if;
else
Set_Standard_Error;
Write_Line ("directory does not exist, use -p to create");
OS_Exit (1);
end if;
end if;
-- Do copy
if Sym_Link then
Create_Sym_Link (From, To & File);
-- Add file to manifest
Add_To_Manifest (From);
else
begin
Directories.Copy_File
(Source_Name => From,
Target_Name => Dest_Filename,
Form => "preserve=timestamps");
exception
when Text_IO.Use_Error =>
Write_Line
("cannot overwrite file " & Dest_Filename
& " check permissions.");
OS_Exit (1);
end;
if Executable then
Set_Executable
(Dest_Filename, Mode => S_Owner + S_Group + S_Others);
end if;
-- Add file to manifest
Add_To_Manifest (Dest_Filename);
end if;
end if;
end Copy_File;
----------------
-- Copy_Files --
----------------
procedure Copy_Files is
procedure Copy_Project_Sources
(Project : Project_Id; Tree : Project_Tree_Ref);
-- Copy sources from the given project
procedure Copy_Source (Sid : Source_Id);
procedure Copy_Artifacts (Pathname, Destination : String);
-- Copy items from the artifacts attribute
Source_Copied : Name_Id_Set.Set;
--------------------------
-- Copy_Project_Sources --
--------------------------
procedure Copy_Project_Sources
(Project : Project_Id; Tree : Project_Tree_Ref)
is
function Is_Ada (Sid : Source_Id) return Boolean;
pragma Inline (Is_Ada);
-- Returns True if Sid is an Ada source
------------
-- Is_Ada --
------------
function Is_Ada (Sid : Source_Id) return Boolean is
begin
return Sid.Language /= null
and then Get_Name_String (Sid.Language.Name) = "ada";
end Is_Ada;
Iter : Source_Iterator;
Sid : Source_Id;
begin
if Project.Qualifier = Aggregate_Library then
Iter := For_Each_Source (Tree);
else
Iter := For_Each_Source (Tree, Project);
end if;
loop
Sid := Element (Iter);
exit when Sid = No_Source;
-- Skip sources that are removed/excluded and sources not
-- part of the interface for standalone libraries.
if not Sid.Locally_Removed
and then not Sid.Project.Externally_Built
and then (Project.Standalone_Library = No
or else Sid.Declared_In_Interfaces)
then
-- If the unit has a naming exception we install it
-- regardless of the fact that it is part of the interface
-- or not. This is because the installed project will have
-- a Naming package referencing this file. The .ali is
-- looked based on the name of the renamed body.
if All_Sources or else Sid.Naming_Exception = Yes then
Copy_Source (Sid);
end if;
-- Objects / Deps
if Other_Part (Sid) = null or else Sid.Kind /= Spec then
if Copy (Object) then
Copy_File
(From => Cat
(Get_Object_Directory
(Sid.Project, False), Sid.Object),
To => Lib_Dir,
File => Get_Name_String (Sid.Object));
end if;
-- Only install Ada .ali files
if Copy (Dependency)
and then Sid.Kind /= Sep
and then Is_Ada (Sid)
then
Copy_File
(From => Cat
(Get_Object_Directory (Sid.Project, False),
Sid.Dep_Name),
To => Lib_Dir,
File => Get_Name_String (Sid.Dep_Name));
end if;
end if;
end if;
Next (Iter);
end loop;
end Copy_Project_Sources;
-----------------
-- Copy_Source --
-----------------
procedure Copy_Source (Sid : Source_Id) is
begin
if Copy (Source) then
declare
Prep_Filename : constant String :=
Cat
(Get_Object_Directory
(Sid.Project, False),
Sid.File) & Osint.Prep_Suffix;
begin
if not Source_Copied.Contains (Name_Id (Sid.Path.Name)) then
Source_Copied.Insert (Name_Id (Sid.Path.Name));
Copy_File
(From => (if Exists (Prep_Filename)
then Prep_Filename
else Get_Name_String (Sid.Path.Name)),
To => Sources_Dir,
File => Get_Name_String (Sid.File));
end if;
end;
end if;
end Copy_Source;
--------------------
-- Copy_Artifacts --
--------------------
procedure Copy_Artifacts (Pathname, Destination : String) is
procedure Copy_Entry (E : Directory_Entry_Type);
-- Copy file pointed by E
function Get_Directory (Fullname : String) return String;
-- Returns the directory containing fullname. Note that we
-- cannot use the standard Containing_Directory as filename
-- can be a pattern and not be allowed in filename.
function Get_Pattern return String;
-- Return filename of pattern from Filename below
----------------
-- Copy_Entry --
----------------
procedure Copy_Entry (E : Directory_Entry_Type) is
Fullname : constant String := Full_Name (E);
Dest_Dir : constant String :=
(if Is_Absolute_Path (Destination)
then Destination
else Prefix_Dir.V.all & Destination);
begin
if Kind (E) = Directory
and then Simple_Name (E) /= "."
and then Simple_Name (E) /= ".."
then
Copy_Artifacts
(Fullname & "/*", Dest_Dir & Simple_Name (E) & '/');
elsif Kind (E) = Ordinary_File then
Copy_File
(From => Fullname,
To => Dest_Dir,
File => Simple_Name (Fullname));
end if;
end Copy_Entry;
-------------------
-- Get_Directory --
-------------------
function Get_Directory (Fullname : String) return String is
K : Natural := Fullname'Last;
begin
while K > 0
and then not Osint.Is_Directory_Separator (Fullname (K))
loop
K := K - 1;
end loop;
pragma Assert (K > 0);
return Fullname (Fullname'First .. K);
end Get_Directory;
-----------------
-- Get_Pattern --
-----------------
function Get_Pattern return String is
K : Natural := Pathname'Last;
begin
while K > 0
and then not Osint.Is_Directory_Separator (Pathname (K))
loop
K := K - 1;
end loop;
if K = 0 then
return Pathname;
else
return Pathname (K + 1 .. Pathname'Last);
end if;
end Get_Pattern;
begin
Directories.Search
(Directory => Get_Directory (Pathname),
Pattern => Get_Pattern,
Process => Copy_Entry'Access);
exception
when Text_IO.Name_Error =>
Put_Line
("warning: path does not exists '"
& Get_Directory (Pathname) & ''');
end Copy_Artifacts;
procedure Copy_Interfaces is new For_Interface_Sources (Copy_Source);
begin
if not All_Sources then
Copy_Interfaces (Tree, Project);
end if;
Copy_Project_Sources (Project, Tree);
-- Copy library
if Copy (Library) then
if Project.Library_Kind /= Static
and then Project.Lib_Internal_Name /= No_Name
and then Project.Library_Name /= Project.Lib_Internal_Name
then
if Windows_Target then
-- No support for version, do a simple copy
Copy_File
(From => Cat
(Project.Library_Dir.Display_Name,
Get_Library_Filename),
To => Lib_Dir,
File => Get_Name_String (Get_Library_Filename),
Executable => Project.Library_Kind /= Static);
else
Copy_File
(From => Cat
(Project.Library_Dir.Display_Name,
File_Name_Type (Project.Lib_Internal_Name)),
To => Lib_Dir,
File => Get_Name_String (Project.Lib_Internal_Name),
Executable => Project.Library_Kind /= Static);
Copy_File
(From => Lib_Dir
& Get_Name_String (Get_Library_Filename),
To => Lib_Dir,
File => Get_Name_String (Project.Lib_Internal_Name),
Sym_Link => True);
end if;
else
Copy_File
(From => Cat
(Project.Library_Dir.Display_Name,
Get_Library_Filename),
To => Lib_Dir,
File => Get_Name_String (Get_Library_Filename),
Executable => Project.Library_Kind /= Static);
end if;
-- On Windows copy the shared libraries into the bin directory
-- for it to be found in the PATH when running executable. On non
-- Windows platforms add a symlink into the lib directory.
if Project.Library_Kind /= Static and then Add_Lib_Link then
if Windows_Target then
Copy_File
(From => Lib_Dir
& Get_Name_String (Get_Library_Filename),
To => Exec_Dir,
File => Get_Name_String (Get_Library_Filename),
Executable => True);
else
Copy_File
(From => Link_Lib_Dir
& Get_Name_String (Get_Library_Filename),
To => Lib_Dir,
File => Get_Name_String (Get_Library_Filename),
Sym_Link => True);
end if;
end if;
end if;
-- Copy executable(s)
if Copy (Executable) then
declare
M : String_List_Id := Project.Mains;
begin
while M /= Nil_String loop
declare
Bin : constant String := Main_Binary (Strs (M).Value);
begin
Copy_File
(From =>
Get_Name_String
(Project.Exec_Directory.Display_Name) & Bin,
To => Exec_Dir,
File => Bin,
Executable => True);
end;
M := Strs (M).Next;
end loop;
end;
end if;
-- Copy artifacts
for E of Artifacts loop
declare
Destination : constant String :=
Ensure_Directory
(Get_Name_String (E.Destination));
Filename : constant String :=
Get_Name_String (E.Filename);
begin
Copy_Artifacts
(Get_Name_String (Project.Directory.Name) & Filename,
Destination);
end;
end loop;
end Copy_Files;
--------------------
-- Create_Project --
--------------------
procedure Create_Project (Project : Project_Id) is
Filename : constant String :=
Project_Dir
& Base_Name (Get_Name_String (Project.Path.Display_Name))
& ".gpr";
Gprinstall_Tag : constant String :=
"This project has been generated by GPRINSTALL";
package String_Vector is
new Containers.Indefinite_Vectors (Positive, String);
package Seen_Set is new Containers.Indefinite_Ordered_Sets (String);
Content : String_Vector.Vector;
-- The content of the project, this is used when creating the project
-- and is needed to ease the project section merging when installing
-- multiple builds.
Line : Unbounded_String;
function "+"
(Item : String) return Unbounded_String renames To_Unbounded_String;
function "-"
(Item : Unbounded_String) return String renames To_String;
procedure Create_Packages;
-- Create packages that are needed, currently Naming and part of
-- Linker is generated for the installed project.
function Image
(Name : Name_Id;
Id : Array_Element_Id) return String;
-- Returns Id image
function Image (Id : Variable_Id) return String;
-- Returns Id image
function Image (Var : Variable_Value) return String;
-- Returns Id image
procedure Read_Project;
-- Read project and set Content accordingly
procedure Write_Project;
-- Write content into project
procedure Add_Empty_Line;
pragma Inline (Add_Empty_Line);
function Naming_Case_Alternative
(Proj : Project_Id) return String_Vector.Vector;
-- Returns the naming case alternative for this project configuration
function Linker_Case_Alternative
(Proj : Project_Id) return String_Vector.Vector;
-- Returns the linker case alternative for this project configuration
function Data_Attributes return String_Vector.Vector;
-- Returns the attributes for the sources, objects and library
function Get_Languages return String;
-- Returns the list of languages
function Get_Package
(Project : Project_Id; Pkg_Name : Name_Id) return Package_Id;
-- Returns the package Name for the given project
--------------------
-- Add_Empty_Line --
--------------------
procedure Add_Empty_Line is
begin
if Content.Element (Content.Last_Index) /= "" then
Content.Append ("");
end if;
end Add_Empty_Line;
---------------------
-- Create_Packages --
---------------------
procedure Create_Packages is
procedure Create_Naming (Proj : Project_Id);
-- Create the naming package
procedure Create_Linker (Proj : Project_Id);
-- Create the linker package if needed
-------------------
-- Create_Naming --
-------------------
procedure Create_Naming (Proj : Project_Id) is
begin
Content.Append (" package Naming is");
-- Attributes
declare
V : Variable_Id := Pcks
(Get_Package (Proj, Name_Naming)).Decl.Attributes;
begin
while V /= No_Variable loop
Content.Append (" " & Image (V));
V := Tree.Shared.Variable_Elements.Table (V).Next;
end loop;
end;
Content.Append (" case BUILD is");
Content.Append (Naming_Case_Alternative (Proj));
Content.Append (" end case;");
Content.Append (" end Naming;");
Add_Empty_Line;
end Create_Naming;
-------------------
-- Create_Linker --
-------------------
procedure Create_Linker (Proj : Project_Id) is
begin
Content.Append (" package Linker is");
Content.Append (" case BUILD is");
-- Attribute Linker_Options only if set
Content.Append (Linker_Case_Alternative (Proj));
Content.Append (" end case;");
Content.Append (" end Linker;");
Add_Empty_Line;
end Create_Linker;
begin
Create_Naming (Project);
Create_Linker (Project);
end Create_Packages;
---------------------
-- Data_Attributes --
---------------------
function Data_Attributes return String_Vector.Vector is
procedure Gen_Dir_Name
(P : Param; Line : in out Unbounded_String);
-- Generate dir name
------------------
-- Gen_Dir_Name --
------------------
procedure Gen_Dir_Name
(P : Param; Line : in out Unbounded_String) is
begin
if P.Default then
-- This is the default value, add Dir_Name
Line := Line & Dir_Name (Suffix => False);
-- Furthermore, if the build name is "default" do not output
if Build_Name.all /= "default" then
Line := Line & "." & Build_Name.all;
end if;
end if;
end Gen_Dir_Name;
V : String_Vector.Vector;
Line : Unbounded_String;
begin
V.Append (" when """ & Build_Name.all & """ =>");
-- Project sources
Line := +" for Source_Dirs use (""";
Line := Line
& Relative_Path
(Sources_Dir (Build_Name => False), To => Project_Dir);
Gen_Dir_Name (Sources_Subdir, Line);
Line := Line & """);";
V.Append (-Line);
-- Project objects and/or library
if Project.Library then
Line := +" for Library_Dir use """;
else
Line := +" for Object_Dir use """;
end if;
Line := Line
& Relative_Path
(Lib_Dir (Build_Name => False), To => Project_Dir);
Gen_Dir_Name (Lib_Subdir, Line);
Line := Line & """;";
V.Append (-Line);
if Project.Library then
Line := +" for Library_Kind use """;
Line := Line & To_Lower (Lib_Kind'Image (Project.Library_Kind));
Line := Line & """;";
V.Append (-Line);
if Project.Standalone_Library /= No then
Line := +" for Library_Standalone use """;
Line := Line &
To_Lower (Standalone'Image (Project.Standalone_Library));
Line := Line & """;";
V.Append (-Line);
-- And then generates the interfaces
Line := +" for Library_Interface use (";
declare
L : String_List_Id := Project.Lib_Interface_ALIs;
First : Boolean := True;
begin
while L /= Nil_String loop
if not First then
Append (Line, ", ");
else
First := False;
end if;
Append (Line, """");
-- Removes the trailing .ali extension
Append
(Line,
Base_Name (Get_Name_String (Strs (L).Value)));
Append (Line, """");
L := Strs (L).Next;
end loop;
end;
Append (Line, ");");
V.Append (-Line);
end if;
end if;
return V;
end Data_Attributes;
-------------------
-- Get_Languages --
-------------------
function Get_Languages return String is
package Lang_Set is new Containers.Indefinite_Ordered_Sets
(String,
Strings.Less_Case_Insensitive, Strings.Equal_Case_Insensitive);
Langs : Lang_Set.Set;
procedure For_Project (Project : Project_Id);
-- Add languages for the given project
-----------------
-- For_Project --
-----------------
procedure For_Project (Project : Project_Id) is
L : Language_Ptr := Project.Languages;
begin
while L /= null loop
if L.Config.Compiler_Driver /= No_File
and then Get_Name_String (L.Config.Compiler_Driver) /= ""
then
Langs.Include (Get_Name_String (L.Display_Name));
end if;
L := L.Next;
end loop;
end For_Project;
begin
-- First adds language for the main project
For_Project (Project);
-- If we are dealing with an aggregate library, adds the languages
-- from all aggregated projects.
if Project.Qualifier = Aggregate_Library then
declare
Agg : Aggregated_Project_List := Project.Aggregated_Projects;
begin
while Agg /= null loop
For_Project (Agg.Project);
Agg := Agg.Next;
end loop;
end;
end if;
declare
Res : Unbounded_String;
First : Boolean := True;
begin
for V of Langs loop
if not First then
Res := Res & ", ";
end if;
Res := Res & '"' & V & '"';
First := False;
end loop;
return To_String (Res);
end;
end Get_Languages;
-----------------
-- Get_Package --
-----------------
function Get_Package
(Project : Project_Id; Pkg_Name : Name_Id) return Package_Id
is
Pck : Package_Id := Project.Decl.Packages;
begin
while Pck /= No_Package loop
if Pcks (Pck).Decl /= No_Declarations
and then Pcks (Pck).Name = Pkg_Name
then
return Pck;
end if;
Pck := Pcks (Pck).Next;
end loop;
return No_Package;
end Get_Package;
-----------
-- Image --
-----------
function Image
(Name : Name_Id;
Id : Array_Element_Id) return String
is
E : constant Array_Element :=
Tree.Shared.Array_Elements.Table (Id);
begin
return "for "
& Get_Name_String (Name)
& " ("""
& Get_Name_String (E.Index)
& """) use "
& Image (E.Value);
end Image;
function Image (Id : Variable_Id) return String is
V : constant Variable_Value :=
Tree.Shared.Variable_Elements.Table (Id).Value;
begin
if V.Default then
return "";
else
return "for "
& Get_Name_String
(Tree.Shared.Variable_Elements.Table (Id).Name)
& " use "
& Image (V);
end if;
end Image;
function Image (Var : Variable_Value) return String is
begin
case Var.Kind is
when Single =>
return """" & Get_Name_String (Var.Value) & """;";
when List =>
declare
V : Unbounded_String;
L : String_List_Id := Var.Values;
First : Boolean := True;
begin
Append (V, "(");
while L /= Nil_String loop
if not First then
Append (V, ", ");
else
First := False;
end if;
Append (V, """");
Append (V, Get_Name_String (Strs (L).Value));
Append (V, """");
L := Strs (L).Next;
end loop;
Append (V, ");");
return To_String (V);
end;
when Undefined =>
return "";
end case;
end Image;
-----------------------------
-- Linker_Case_Alternative --
-----------------------------
function Linker_Case_Alternative
(Proj : Project_Id) return String_Vector.Vector
is
use type Ada.Containers.Count_Type;
procedure Linker_For (Pck : Package_Id);
-- Handle the linker options for this package
Seen : Seen_Set.Set;
-- Records the attribute generated to avoid duplicate when
-- handling aggregated projects.
R : String_Vector.Vector;
Opts : String_Vector.Vector;
----------------
-- Linker_For --
----------------
procedure Linker_For (Pck : Package_Id) is
V : Variable_Id := Pcks (Pck).Decl.Attributes;
begin
while V /= No_Variable loop
if Tree.Shared.Variable_Elements.Table (V).Name =
Name_Linker_Options
then
declare
Val : constant Variable_Value :=
Tree.Shared.Variable_Elements.Table (V).Value;
L : String_List_Id := Val.Values;
begin
while L /= Nil_String loop
Opts.Append (Get_Name_String (Strs (L).Value));
Seen.Include (Get_Name_String (Strs (L).Value));
L := Strs (L).Next;
end loop;
end;
end if;
V := Tree.Shared.Variable_Elements.Table (V).Next;
end loop;
end Linker_For;
begin
R.Append (" when """ & Build_Name.all & """ =>");
Linker_For (Get_Package (Proj, Name_Linker));
if Proj.Qualifier = Aggregate_Library then
declare
Agg : Aggregated_Project_List :=
Project.Aggregated_Projects;
begin
while Agg /= null loop
Linker_For (Get_Package (Agg.Project, Name_Linker));
Agg := Agg.Next;
end loop;
end;
end if;
-- We also want to add the externally built libraries without
-- sources (referencing system libraries for example).
declare
L : Project_List := Project.All_Imported_Projects;
begin
while L /= null loop
if L.Project.Library
and then L.Project.Externally_Built
and then not Bring_Sources (L.Project)
then
Opts.Append
("-l" & Get_Name_String (L.Project.Library_Name));
end if;
L := L.Next;
end loop;
end;
if Opts.Length = 0 then
-- No linker alternative found, add null statement
R.Append (" null;");
else
declare
O_List : Unbounded_String;
begin
for O of Opts loop
if O_List /= Null_Unbounded_String then
Append (O_List, ", ");
end if;
Append (O_List, '"' & O & '"');
end loop;
R.Append
(" for Linker_Options use ("
& To_String (O_List) & ");");
end;
end if;
return R;
end Linker_Case_Alternative;
-----------------------------
-- Naming_Case_Alternative --
-----------------------------
function Naming_Case_Alternative
(Proj : Project_Id) return String_Vector.Vector
is
procedure Naming_For (Pck : Package_Id);
-- Handle the naming scheme for this package
Seen : Seen_Set.Set;
-- Records the attribute generated to avoid duplicate when
-- handling aggregated projects.
V : String_Vector.Vector;
----------------
-- Naming_For --
----------------
procedure Naming_For (Pck : Package_Id) is
A : Array_Id := Pcks (Pck).Decl.Arrays;
N : Name_Id;
E : Array_Element_Id;
begin
-- Arrays
while A /= No_Array loop
N := Tree.Shared.Arrays.Table (A).Name;
E := Tree.Shared.Arrays.Table (A).Value;
while E /= No_Array_Element loop
declare
Decl : constant String := Image (N, E);
begin
if not Seen.Contains (Decl) then
V.Append (" " & Image (N, E));
Seen.Include (Decl);
end if;
end;
E := Tree.Shared.Array_Elements.Table (E).Next;
end loop;
A := Tree.Shared.Arrays.Table (A).Next;
end loop;
end Naming_For;
begin
V.Append (" when """ & Build_Name.all & """ =>");
Naming_For (Get_Package (Proj, Name_Naming));
if Proj.Qualifier = Aggregate_Library then
declare
Agg : Aggregated_Project_List :=
Project.Aggregated_Projects;
begin
while Agg /= null loop
Naming_For (Get_Package (Agg.Project, Name_Naming));
Agg := Agg.Next;
end loop;
end;
end if;
return V;
end Naming_Case_Alternative;
------------------
-- Read_Project --
------------------
procedure Read_Project is
File : File_Type;
Buffer : String (1 .. 1_024);
Last : Natural;
begin
Open (File, In_File, Filename);
while not End_Of_File (File) loop
Get_Line (File, Buffer, Last);
Content.Append (Buffer (1 .. Last));
end loop;
Close (File);
end Read_Project;
-------------------
-- Write_Project --
-------------------
procedure Write_Project is
F : File_Access := Standard_Output;
File : aliased File_Type;
begin
if not Dry_Run then
Create (File, Out_File, Filename);
F := File'Unchecked_Access;
end if;
for K in Content.First_Index .. Content.Last_Index loop
Put_Line (F.all, Content.Element (K));
end loop;
if not Dry_Run then
Close (File);
end if;
end Write_Project;
type Section_Kind is (Top, Naming, Linker);
Project_Exists : constant Boolean := Exists (Filename);
Current_Section : Section_Kind := Top;
Pos : String_Vector.Cursor;
Generated : Boolean := False;
begin
if Dry_Run or else Opt.Verbose_Mode then
Write_Eol;
Write_Str ("Project ");
Write_Str (Filename);
if Dry_Run then
Write_Line (" would be installed");
else
Write_Line (" installed");
end if;
Write_Eol;
end if;
-- If project exists, read it and check the generated status
if Project_Exists then
Read_Project;
-- First check that this project has been generated by gprbuild,
-- if not exit with an error as we cannot modify a project created
-- manually and we do not want to overwrite it.
Pos := Content.First;
Check_Generated_Status :
while String_Vector.Has_Element (Pos) loop
if Fixed.Index
(String_Vector.Element (Pos), Gprinstall_Tag) /= 0
then
Generated := True;
exit Check_Generated_Status;
end if;
String_Vector.Next (Pos);
end loop Check_Generated_Status;
if not Generated and then not Force_Installations then
Write_Str ("non gprinstall project file ");
Write_Str (Filename);
Write_Str (" exists, use -f to overwrite");
Write_Eol;
OS_Exit (1);
end if;
end if;
if Project_Exists and then Generated then
if not Has_Sources (Project) then
-- Nothing else to do in this case
return;
end if;
if Opt.Verbose_Mode then
Write_Line ("project file exists, merging new build");
end if;
-- Do merging for new build, we need to add an entry into the
-- BUILD_KIND type and a corresponding case entry in the naming
-- and Linker package.
Parse_Content :
while String_Vector.Has_Element (Pos) loop
declare
BN : constant String := Build_Name.all;
Line : constant String := String_Vector.Element (Pos);
P, L : Natural;
begin
if Fixed.Index (Line, "type BUILD_KIND is (") /= 0 then
-- This is the "type BUILD_KIND" line, add new build name
-- First check if the current build name already exists
if Fixed.Index (Line, """" & BN & """") = 0 then
-- Get end of line
P := Fixed.Index (Line, ");");
if P = 0 then
Write_Line ("cannot parse the BUILD_KIND line");
OS_Exit (1);
else
Content.Replace_Element
(Pos,
Line (Line'First .. P - 1)
& ", """ & BN & """);");
end if;
end if;
elsif Fixed.Index (Line, ":= external") /= 0
and then Build_Var /= null
then
-- Replace build-var with new one
P := Fixed.Index (Line, """");
if P = 0 then
Write_Line ("cannot parse the BUILD line");
OS_Exit (1);
else
L := P + 1;
while L <= Line'Last and then Line (L) /= '"' loop
L := L + 1;
end loop;
if Line (L) /= '"' then
Write_Line ("cannot parse the BUILD line");
OS_Exit (1);
else
Content.Replace_Element
(Pos,
Line (Line'First .. P)
& Build_Var.all & Line (L .. Line'Last));
end if;
end if;
elsif Fixed.Index (Line, "package Naming is") /= 0 then
Current_Section := Naming;
elsif Fixed.Index (Line, "package Linker is") /= 0 then
Current_Section := Linker;
elsif Fixed.Index (Line, "case BUILD is") /= 0 then
-- Add new case section for the new build name
case Current_Section is
when Naming =>
String_Vector.Next (Pos);
Content.Insert
(Pos, Naming_Case_Alternative (Project));
when Linker =>
String_Vector.Next (Pos);
Content.Insert
(Pos, Linker_Case_Alternative (Project));
when Top =>
-- For the Sources/Lib attributes
String_Vector.Next (Pos);
Content.Insert (Pos, Data_Attributes);
end case;
elsif Fixed.Index (Line, "when """ & BN & """ =>") /= 0 then
-- Found a when with the current build name, this is a
-- previous install overwritten by this one. Remove this
-- section. Note that this removes sections from all
-- packages Naming and Linker, and from project level
-- case alternative.
Count_And_Delete : declare
use type Containers.Count_Type;
function End_When (L : String) return Boolean;
-- Return True if L is the end of a when alternative
--------------
-- End_When --
--------------
function End_When (L : String) return Boolean is
P : constant Natural :=
Strings.Fixed.Index_Non_Blank (L);
Len : constant Natural := L'Length;
begin
return P > 0
and then
((P + 4 <= Len
and then L (P .. P + 4) = "when ")
or else
(P + 8 <= Len
and then L (P .. P + 8) = "end case;"));
end End_When;
N : Containers.Count_Type := 0;
P : String_Vector.Cursor := Pos;
begin
-- The number of line to delete are from Pos to the
-- first line starting with a "when".
loop
String_Vector.Next (P);
N := N + 1;
exit when End_When (String_Vector.Element (P));
end loop;
Content.Delete (Pos, N);
end Count_And_Delete;
end if;
end;
String_Vector.Next (Pos);
end loop Parse_Content;
else
-- Project does not exists, or it exists, was not generated by
-- gprinstall and -f used. In this case it will be overwriten by
-- a generated project.
Content.Clear;
-- Tag project as generated by gprbuild
Content.Append
("-- " & Gprinstall_Tag & ' ' & Gpr_Version_String);
Add_Empty_Line;
-- Handle with clauses, generate a with clauses only for project
-- bringing some visibility to sources. No need for doing this for
-- aggregate projects.
if Project.Qualifier /= Aggregate_Library then
declare
L : Project_List := Project.Imported_Projects;
begin
while L /= null loop
if Has_Sources (L.Project)
and then not L.Project.Externally_Built
and then Is_Install_Active (Tree, L.Project)
then
Content.Append
("with """
& Base_Name
(Get_Name_String (L.Project.Path.Display_Name))
& """;");
end if;
L := L.Next;
end loop;
end;
end if;
-- In all cases adds externally built projects
declare
L : Project_List := Project.All_Imported_Projects;
begin
while L /= null loop
if Has_Sources (L.Project)
and then L.Project.Externally_Built
then
Content.Append
("with """
& Base_Name
(Get_Name_String (L.Project.Path.Display_Name))
& """;");
end if;
L := L.Next;
end loop;
end;
Add_Empty_Line;
-- Project name
if Has_Sources (Project) then
if Project.Library then
Line := +"library ";
else
Line := +"standard ";
end if;
else
Line := +"abstract ";
end if;
Line := Line & "project ";
Line := Line & Get_Name_String (Project.Display_Name);
Line := Line & " is";
Content.Append (-Line);
if Has_Sources (Project) then
-- BUILD variable
Content.Append
(" type BUILD_KIND is (""" & Build_Name.all & """);");
Line := +" BUILD : BUILD_KIND := external(""";
if Build_Var /= null then
Line := Line & Build_Var.all;
else
Line := Line & To_Upper (Dir_Name (Suffix => False));
Line := Line & "_BUILD";
end if;
Line := Line & """, """ & Build_Name.all & """);";
Content.Append (-Line);
-- Add languages, for an aggregate library we want all unique
-- languages from all aggregated libraries.
Add_Empty_Line;
Content.Append
(" for Languages use (" & Get_Languages & ");");
-- Build_Suffix used to avoid .default as suffix
Add_Empty_Line;
Content.Append (" case BUILD is");
Content.Append (Data_Attributes);
Content.Append (" end case;");
Add_Empty_Line;
-- Library Name
if Project.Library then
Content.Append
(" for Library_Name use """
& Get_Name_String (Project.Library_Name)
& """;");
-- Issue the Library_Version only if needed
if Project.Library_Kind /= Static
and then Project.Lib_Internal_Name /= No_Name
and then Project.Library_Name /= Project.Lib_Internal_Name
then
Content.Append
(" for Library_Version use """
& Get_Name_String (Project.Lib_Internal_Name)
& """;");
end if;
end if;
Add_Empty_Line;
-- Packages
Create_Packages;
-- Externally Built
Content.Append (" for Externally_Built use ""True"";");
else
-- This is an abstract project
Content.Append (" for Source_Dirs use ();");
end if;
-- Close project
Content.Append
("end " & Get_Name_String (Project.Display_Name) & ";");
end if;
-- Write new project if needed
Write_Project;
if not Dry_Run then
-- Add project file to manifest
Add_To_Manifest (Filename);
end if;
end Create_Project;
-------------------------
-- Open_Check_Manifest --
-------------------------
procedure Open_Check_Manifest is
Dir : constant String := Project_Dir & "manifests";
Name : constant String := Dir & DS & Install_Name.all;
Prj_Sig : constant String :=
File_MD5 (Get_Name_String (Project.Path.Display_Name));
Buf : String (1 .. 128);
Last : Natural;
begin
-- Check wether the manifest does not exist in this case
if Exists (Name) then
Open (Man, In_File, Name);
Get_Line (Man, Buf, Last);
if Last >= Message_Digest'Length
and then (Buf (1 .. 2) /= Sig_Line
or else Buf (3 .. Message_Digest'Last + 2) /= Prj_Sig)
and then Install_Name_Default
then
Write_Line
("Project already installed, either:");
Write_Line
(" - uninstall first using --uninstall option");
Write_Line
(" - install under another name, use --install-name");
Write_Line
(" - force installation under the same name, "
& "use --install-name=" & Install_Name.all);
OS_Exit (1);
end if;
Reset (Man, Append_File);
else
Create_Path (Dir);
Create (Man, Out_File, Name);
Put_Line (Man, Sig_Line & Prj_Sig);
end if;
end Open_Check_Manifest;
Install_Project : Boolean;
-- Whether the project is to be installed
begin
-- If we have an aggregate project we just install separately all
-- aggregated projects.
if Project.Qualifier = Aggregate then
declare
L : Aggregated_Project_List := Project.Aggregated_Projects;
begin
while L /= null loop
Process (L.Tree, L.Project);
L := L.Next;
end loop;
end;
-- Nothing more to do for an aggegate project
return;
end if;
if not Installed.Contains (Project.Name) then
Installed.Include (Project.Name);
-- First look for the Install package and set up the local values
-- accordingly.
Check_Install_Package;
-- The default install name is the name of the project without
-- extension.
if Install_Name = null or else Install_Name_Default then
Free (Install_Name);
Install_Name :=
new String'((Base_Name (Get_Name_String (Project.Path.Name))));
end if;
-- Skip non active project and externally built ones
Install_Project := Active
and Bring_Sources (Project)
and not Project.Externally_Built;
if not Opt.Quiet_Output then
if Install_Project then
Write_Str ("Install");
elsif Opt.Verbose_Mode then
Write_Str ("Skip");
end if;
if Install_Project or Opt.Verbose_Mode then
Write_Str (" project ");
Write_Str (Get_Name_String (Project.Display_Name));
if Build_Name.all /= "default" then
Write_Str (" - " & Build_Name.all);
end if;
end if;
if not Install_Project and Opt.Verbose_Mode then
if not Active then
Write_Str (" (not active)");
elsif Project.Externally_Built then
Write_Str (" (externally built)");
elsif Project.Source_Dirs = Nil_String then
Write_Str (" (no sources)");
end if;
end if;
if Install_Project or Opt.Verbose_Mode then
Write_Eol;
end if;
end if;
-- If this is not an active project, just return now
if not Install_Project then
return;
end if;
-- What should be copied
Copy :=
(Source => For_Dev,
Object => For_Dev
and then Project.Mains = Nil_String
and then Project.Qualifier /= Library
and then Project.Qualifier /= Aggregate_Library
and then not Project.Library,
Dependency => For_Dev and then Project.Mains = Nil_String,
Library => Project.Library
and then
((For_Dev and then Project.Library_Kind = Static)
or else Project.Library_Kind /= Static),
Executable => Project.Mains /= Nil_String);
-- Copy all files from the project
if Has_Sources (Project) then
Copy_Files;
end if;
-- A project file is only needed in developer mode
if For_Dev then
Create_Project (Project);
end if;
-- Close manifest file if needed
if Is_Open (Man) then
Close (Man);
end if;
-- Handle all projects recursivelly if needed
if Recursive then
declare
L : Project_List := Project.Imported_Projects;
begin
while L /= null loop
Process (Tree, L.Project);
L := L.Next;
end loop;
end;
end if;
end if;
Free (Prefix_Dir);
Free (Sources_Subdir);
Free (Lib_Subdir);
Free (Exec_Subdir);
Free (Project_Subdir);
end Process;
end Gprinstall.Install;
gprbuild-gpl-2014-src/src/gprlib-build_shared_lib.adb 0000644 0000767 0000145 00000003525 12323721731 022127 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R L I B . B U I L D _ S H A R E D _ L I B --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006-2012, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- This is the default body for procedure Build_Shared_Lib, used when shared
-- libraries are not supported. It is an error if this procedure is called.
separate (Gprlib)
procedure Build_Shared_Lib is
begin
Osint.Fail ("Build_Shared_Lib should not have been called");
end Build_Shared_Lib;
gprbuild-gpl-2014-src/src/gprbuild.ads 0000644 0000767 0000145 00000041716 12323721731 017234 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R B U I L D --
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2014, Free Software Foundation, Inc. --
-- --
-- This 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 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
------------------------------------------------------------------------------
-- The following package implements the facilities to compile, bind and/or
-- link a set of Ada and non Ada sources, specified in Project Files.
private with Ada.Unchecked_Deallocation;
private with GNAT.Dynamic_Tables;
private with GNAT.HTable;
private with GNAT.OS_Lib;
private with Makeutl;
with ALI;
with Namet; use Namet;
with Opt;
with Prj; use Prj;
with Table;
with Types; use Types;
package Gprbuild is
-- Everyting private so only accessible to child packages
private
use GNAT.OS_Lib;
use type ALI.ALI_Id, Opt.Verbosity_Level_Type, Opt.Warning_Mode_Type;
Object_Suffix : constant String := Get_Target_Object_Suffix.all;
-- The suffix of object files on this platform
Dash_L : Name_Id;
-- "-L", initialized in procedure Initialize
Main_Project_Dir : String_Access;
-- The absolute path of the project directory of the main project,
-- initialized in procedure Initialize.
Executable_Suffix : constant String_Access := Get_Executable_Suffix;
-- The suffix of executables on this platforms
Main_Index : Int := 0;
Project_Tree : constant Project_Tree_Ref :=
new Project_Tree_Data (Is_Root_Tree => True);
-- The project tree
Copyright_Output : Boolean := False;
Usage_Output : Boolean := False;
-- Flags to avoid multiple displays of Copyright notice and of Usage
Usage_Needed : Boolean := False;
-- Set by swith -h: usage will be displayed after all command line
-- switches have been scanned.
Display_Paths : Boolean := False;
-- Set by switch --display-paths: config project path and user project path
-- will be displayed after all command lines witches have been scanned.
Output_File_Name : String_Access := null;
-- The name given after a switch -o
Output_File_Name_Expected : Boolean := False;
-- True when last switch was -o
Project_File_Name_Expected : Boolean := False;
-- True when last switch was -P
Search_Project_Dir_Expected : Boolean := False;
-- True when last switch was -aP
Object_Checked : Boolean := True;
-- False when switch --no-object-check is used. When True, presence of
-- the object file and its time stamp are checked to decide if a file needs
-- to be compiled. Also set to False when switch --codepeer is used.
Map_File : String_Access := null;
-- Value of switch --create-map-file
Indirect_Imports : Boolean := True;
-- False when switch --no-indirect-imports is used. Sources are only
-- allowed to import from the projects that are directly withed.
Recursive : Boolean := False;
Unique_Compile : Boolean := False;
-- Set to True if -u or -U or a project file with no main is used
Unique_Compile_All_Projects : Boolean := False;
-- Set to True if -U is used
Always_Compile : Boolean := False;
-- Set to True when gprbuid is called with -f -u and at least one source
-- on the command line.
Builder_Switches_Lang : Name_Id := No_Name;
-- Used to decide to what compiler the Builder'Default_Switches that
-- are not recognized by gprbuild should be given.
package All_Language_Builder_Compiling_Options is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name =>
"Makegpr.All_Language_Builder_Compiling_Options");
-- Table to store the options for all compilers, that is those that
-- follow the switch "-cargs" without any mention of language in the
-- Builder switches.
package All_Language_Compiling_Options is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Makegpr.All_Language_Compiling_Options");
-- Table to store the options for all compilers, that is those that
-- follow the switch "-cargs" without any mention of language on the
-- command line.
package Builder_Compiling_Options is new GNAT.Dynamic_Tables
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100);
-- Tables to store the options for the compilers of the different
-- languages, that is those after switch "-cargs:", in the Builder
-- switches.
package Compiling_Options is new GNAT.Dynamic_Tables
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100);
-- Tables to store the options for the compilers of the different
-- languages, that is those after switch "-cargs:", on the command
-- line.
type Boolean_Array is array (Positive range <>) of Boolean;
type Booleans is access Boolean_Array;
procedure Free is new Ada.Unchecked_Deallocation (Boolean_Array, Booleans);
Initial_Number_Of_Options : constant Natural := 10;
type Options_Data is record
Options : String_List_Access :=
new String_List (1 .. Initial_Number_Of_Options);
Visible : Booleans :=
new Boolean_Array (1 .. Initial_Number_Of_Options);
Simple_Name : Booleans :=
new Boolean_Array (1 .. Initial_Number_Of_Options);
Last : Natural := 0;
end record;
-- A record type to keep different options with a boolean for each that
-- indicates if it should be displayed.
All_Options : Options_Data;
-- A cache for all options, to avoid too many allocations
Compilation_Options : Options_Data;
-- The compilation options coming from package Compiler
type Comp_Option_Table_Ref is access Compiling_Options.Instance;
No_Comp_Option_Table : constant Comp_Option_Table_Ref := null;
Current_Comp_Option_Table : Comp_Option_Table_Ref := No_Comp_Option_Table;
type Builder_Comp_Option_Table_Ref is
access Builder_Compiling_Options.Instance;
No_Builder_Comp_Option_Table : constant Builder_Comp_Option_Table_Ref :=
null;
package Compiling_Options_HTable is new GNAT.HTable.Simple_HTable
(Header_Num => Prj.Header_Num,
Element => Comp_Option_Table_Ref,
No_Element => No_Comp_Option_Table,
Key => Name_Id,
Hash => Prj.Hash,
Equal => "=");
-- A hash table to get the command line compilation option table from the
-- language name.
package Builder_Compiling_Options_HTable is new GNAT.HTable.Simple_HTable
(Header_Num => Prj.Header_Num,
Element => Builder_Comp_Option_Table_Ref,
No_Element => No_Builder_Comp_Option_Table,
Key => Name_Id,
Hash => Prj.Hash,
Equal => "=");
-- A hash table to get the builder compilation option table from the
-- language name.
package All_Language_Binder_Options is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Makegpr.All_Language_Binder_Options");
-- Table to store the options for all binders, that is those that
-- follow the switch "-bargs" without any mention of language.
package Binder_Options is new GNAT.Dynamic_Tables
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100);
-- Tables to store the options for the binders of the different
-- languages, that is those after switch "-bargs:".
type Bind_Option_Table_Ref is access Binder_Options.Instance;
No_Bind_Option_Table : constant Bind_Option_Table_Ref := null;
Current_Bind_Option_Table : Bind_Option_Table_Ref := No_Bind_Option_Table;
package Binder_Options_HTable is new GNAT.HTable.Simple_HTable
(Header_Num => Prj.Header_Num,
Element => Bind_Option_Table_Ref,
No_Element => No_Bind_Option_Table,
Key => Name_Id,
Hash => Prj.Hash,
Equal => "=");
-- A hash table to get the compilation option table from the language name
package Binding_Options is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 20,
Table_Increment => 100,
Table_Name => "Makegpr.Binding_Options");
-- Table to store the linking options coming from the binder
package Command_Line_Linker_Options is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 20,
Table_Increment => 100,
Table_Name => "Makegpr.Command_Line_Linker_Options");
-- Table to store the linking options
type Linker_Options_Data is record
Project : Project_Id;
Options : String_List_Id;
end record;
package Linker_Opts is new Table.Table
(Table_Component_Type => Linker_Options_Data,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 20,
Table_Increment => 100,
Table_Name => "Makegpr.Linker_Opts");
-- Table to store the Linker'Linker_Options in the project files
Project_Of_Current_Object_Directory : Project_Id := No_Project;
-- The object directory of the project for the last binding. Avoid
-- calling Change_Dir if the current working directory is already this
-- directory.
-- Archive builder name, path and options
Archive_Builder_Name : String_Access := null;
Archive_Builder_Path : String_Access := null;
Archive_Builder_Opts : Options_Data;
Archive_Builder_Append_Opts : Options_Data;
-- Archive indexer name, path and options
Archive_Indexer_Name : String_Access := null;
Archive_Indexer_Path : String_Access := null;
Archive_Indexer_Opts : Options_Data;
-- Libraries
type Library_Project is record
Proj : Project_Id;
Is_Aggregated : Boolean;
end record;
package Library_Projs is new Table.Table (
Table_Component_Type => Library_Project,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 10,
Table_Name => "Buildgpr.Library_Projs");
-- Library projects imported directly or indirectly
package Non_Library_Projs is new Table.Table (
Table_Component_Type => Project_Id,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 10,
Table_Name => "Buildgpr.Non_Library_Projs");
-- Non library projects imported directly or indirectly
procedure Add_Option
(Value : String;
To : in out Options_Data;
Display : Boolean;
Simple_Name : Boolean := False);
procedure Add_Option
(Value : Name_Id;
To : in out Options_Data;
Display : Boolean;
Simple_Name : Boolean := False);
procedure Add_Options
(Value : String_List_Id;
To : in out Options_Data;
Display_All : Boolean;
Display_First : Boolean;
Simple_Name : Boolean := False);
-- Add one or several options to a list of options. Increase the size
-- of the list, if necessary.
function Get_Option (Option : Name_Id) return String_Access;
-- Get a string access corresponding to Option. Either find the string
-- access in the All_Options cache, or create a new entry in All_Options.
procedure Test_If_Relative_Path
(Switch : in out String_Access;
Parent : String;
Including_Switch : Name_Id);
procedure Add_Option_Internal
(Value : String_Access;
To : in out Options_Data;
Display : Boolean;
Simple_Name : Boolean := False);
-- Add an option in a specific list of options
procedure Add_Option_Internal_Codepeer
(Value : String_Access;
To : in out Options_Data;
Display : Boolean;
Simple_Name : Boolean := False);
-- Similar to procedure Add_Option_Internal, except that in CodePeer
-- mode, options -mxxx are not added.
procedure Process_Imported_Libraries
(For_Project : Project_Id;
There_Are_SALs : out Boolean;
And_Project_Itself : Boolean := False);
-- Get the imported library project ids in table Library_Projs
procedure Process_Imported_Non_Libraries (For_Project : Project_Id);
-- Get the imported non library project ids in table Non_Library_Projs
function Create_Path_From_Dirs return String_Access;
-- Concatenate all directories in the Directories table into a path.
-- Caller is responsible for freeing the result
procedure Check_Archive_Builder;
-- Check if the archive builder (ar) is there
function Archive_Suffix (For_Project : Project_Id) return String;
-- Return the archive suffix for the project, if defined, otherwise
-- return ".a".
procedure Change_To_Object_Directory (Project : Project_Id);
-- Change to the object directory of project Project, if this is not
-- already the current working directory.
use Makeutl;
package Bad_Processes is new Table.Table
(Table_Component_Type => Main_Info,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Gprbuild.Bad_Processes");
-- Info for all the mains where binding fails
Outstanding_Processes : Natural := 0;
-- The number of bind jobs currently spawned
Stop_Spawning : Boolean := False;
-- True when one bind process failed and switch -k was not used
procedure Record_Failure (Main : Main_Info);
-- Add Main to table Bad_Binds and set Stop_Binding to True if switch -k is
-- not used.
type Process_Kind is (None, Binding, Linking);
type Process_Data (Kind : Process_Kind := None) is record
Process : Process_Id := Invalid_Pid;
Main : Main_Info := No_Main_Info;
case Kind is
when Linking =>
Response_1 : Path_Name_Type := No_Path;
Response_2 : Path_Name_Type := No_Path;
when others =>
null;
end case;
end record;
No_Process_Data : constant Process_Data :=
(None, Invalid_Pid, No_Main_Info);
type Header_Num is range 0 .. 2047;
function Hash (Pid : Process_Id) return Header_Num;
-- Used for Process_Htable below
package Process_Htable is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
Element => Process_Data,
No_Element => No_Process_Data,
Key => Process_Id,
Hash => Hash,
Equal => "=");
-- Hash table to keep data for all spawned jobs
procedure Add_Process (Process : Process_Id; Data : Process_Data);
-- Add process in the Process_Htable
procedure Await_Process (Data : out Process_Data; OK : out Boolean);
-- Wait for the end of a bind job
procedure Display_Processes (Name : String);
-- When -jnn, -v and -vP2 are used, display the number of currently spawned
-- processes.
end Gprbuild;
gprbuild-gpl-2014-src/src/gprbuild_dummies.c 0000644 0000767 0000145 00000003204 12323721732 020421 0 ustar gnatmail gnat /****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* G P R B U I L D _ D U M M I E S *
* *
* C Implementation File *
* *
* Copyright (C) 2006-2012, Free Software Foundation, Inc. *
*
* This 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 3, or (at your option) any later ver- *
* sion. This software is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- *
* TABILITY 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 this software; see file *
* COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy *
* of the license. *
****************************************************************************/
#include
void set_std_prefix (void) {
abort ();
}
void update_path (void) {
abort ();
}
gprbuild-gpl-2014-src/known-problems-100 0000644 0000767 0000145 00000010276 11260747162 017344 0 ustar gnatmail gnat ========================================
Known problems in GPRBUILD version 1.0.0
========================================
Copyright (c) 2008, 2009 AdaCore
The following is a listing of known problems in release 1.0.0. Except where
specifically noted, all these problems have been corrected in the development
tree of the 1.1 technology. This means they are corrected in any 1.1.0w
wavefront issued subsequent to the date specified (in ISO format YYYY-MM-DD) in
the status line. This can be used to determine if a given wavefront has the fix
identified in the entry.
KP-100-H115-007 gprbuild fails to build archives with many object files
Problem: gprbuild may fail to build archives (for static library or the
global archive) when the number of object files is too large.
Status: This was fixed in 1.1.0 on 2008-01-16
Workaround: Either reduce the number of object files, using one or
several static libraries, or reduce the absolute paths of
the project files.
KP-100-H124-002 Missing objects from externally built projects
Problem: When an externally built projects does not contain sources
for bodies, but only for some specs, some of the object files
may be missing in the global archive.
Status: This was fixed in 1.1.0 on 2008-03-06
Workaround: Convert the externally built project into an externally
built static library project.
KP-100-H208-029 -bargs and -largs not allowed in package Builder
Problem: Switches -bargs, -bargs: and -largs are not accepted
in the switch attributes of package Builder.
Status: This was fixed in 1.1.0 on 2008-02-09
Workaround: Use these switches only on the command line.
KP-100-H216-002 gprbuild crashes with limited with cycle
Problem: gprbuild may crash if there are cycles in the project tree
using limited withs.
Status: This was fixed in 1.1.0 on 2008-02-17
Workaround: Do not use limited withs.
KP-100-H226-027 Missing gprclean switch -eL
Problem: The switch -eL, to follow symbolic links when processing
project files, is missing for gprclean.
Status: This was fixed in 1.1.0 on 2008-02-26
Workaround: Do not use symbolic links.
KP-100-H303-021 Linker switches not relative to project directory
Problem: When using switches in package Linker that include relative
paths, the paths are relative to the object directory, not to
the project directory as is done for gnatmake.
Status: This was fixed in 1.1.0 on 2008-03-04
Workaround: Use only absolute paths.
KP-100-H218-008 Wrong executable name generated
Problem: When the body suffix of the main includes several dots,
gprbuild does not generate the proper executable name.
Status: This was fixed in 1.1.0 on 2008-02-18
Workaround: Specify the executable name in the project file.
KP-100-GC29-007 Importing an externally buit library with an empty object dir
Problem: Building a Stand-Alone Library that imports an externally built
library where the object directory does not contain any ALI file
fails.
Status: This was fixed in 1.1.0 on 2007-12-29
Workaround: Copy the ALI files in the object directory.
KP-100-GC29-003 SALs with capital letter names on Windows
Problem: Stand-Alone Libraries with capital letters in their names are
not build correctly on Windows.
Status: This was fixed in 1.1.0 on 2007-12-29
Workaround: Use only library names with small letters.
KP-100-GC12-012 Failure to build a library that imports other libraries
Problem: When a library project imports several other library projects,
gprbuild will fail to build the library.
Status: This was fixed in 1.1.0 on 2007-12-16
Workaround: Reduce the number of libraries.
KP-100-GC12-009 Autoconfiguration fails when object dir not present
Problem: When the object dir of the main project file is not present
autoconfiguration fails, even when gprbuild is called with -p.
Status: This was fixed in 1.1.0 on 2007-12-18
Workaround: Create manually the object dir of the main project.
gprbuild-gpl-2014-src/features-20 0000644 0000767 0000145 00000005220 12144662113 016111 0 ustar gnatmail gnat ==============================
GPRBUILD 2.0 NEW FEATURES LIST
==============================
Copyright (C) 2013, AdaCore
This file contains a complete list of new features in version 2.0 of GPRBUILD.
A full description of all GPRBUILD features can be found in the GPRBUILD
User's Guide.
NF-20-M121-032 Switches --RTS for gprclean (2013-01-21)
gprclean may now be called with switches --RTS= or --RTS:=. The
runtimes specified with these switches are taken into account in the
invocation of gprconfig in auto-configuration. This allows gprclean to
have more accurate file names to delete, for example when the executable
extension depends on the runtime.
NF-20-LA23-043 Unconditionally create --autoconf= path (2012-10-26)
gprbuild now creates unconditionally the directory of the configuration
project file specified with --autoconf= when this directory does not exist.
NF-20-L924-049 Add support for arbitrary runtimes for GNAT (2012-09-30)
The names of the runtimes for GNAT are no longer limited to a restricted
list.
NF-20-L918-009 Add support for Windows resources (2012-10-03)
Support for compiling Windows resources file with the binutils's
windres compiler has been added.
NF-20-L908-003 Add aggregate project support for gprinstall (2012-09-08)
gprinstall can now be used to install aggregate projects.
NF-20-L906-035 Add aggregate library project support to gprinstall (2012-09-08)
gprinstall can now be used to install aggregate library projects.
NF-20-L126-014 Verbosity when linking shared SALs (2012-01-26)
In default mode (not verbose and not quiet), the base name of gnatbind and
of the compiler when binding and compiling the binder generated file is now
output, instead of the full path names. Also, when the command line is long,
only the beginning is output.
NF-20-KC19-034 Support for VxWorks Linux (2012-04-11)
gprbuild now support VxWorks Linux targets.
NF-20-K623-010 New switch --validate for gprconfig (2012-01-04)
This switch can be used to validate the XML files from the gprconfig
knowledge base. It should be used when you add your own XML files.
NF-20-JC09-030 New package Clean in project file (2012-03-30)
A new package Clean is added in project files. It can contain declarations
of attributes Source_Artifact_Extensions and Object_Artifact_Extensions,
that specify the extensions of files whose names are derived from source or
object file names, that reside in the object directory and that are to be
cleaned by gprclean.
NF-20-H729-014 New tool named gprinstall (2012-05-18)
A new tool named gprinstall has been implemeted and can be used to
install a standard or a library project.
gprbuild-gpl-2014-src/Makefile.in 0000644 0000767 0000145 00000014677 12255333627 016226 0 ustar gnatmail gnat SHELL=/bin/sh
INSTALL=@INSTALL@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
INSTALL_DATA=@INSTALL_DATA@
host=@host@
target=@target@
build=@build@
IS_WINDOWS=@is_windows@
# Relative to the gnat/ subdirectory (or absolute path)
GNAT_SOURCE_DIR=../gnat_src
ifeq ($(IS_WINDOWS),true)
LN=cp -p
EXEXT=.exe
else
LN=ln -s -f
EXEXT=
endif
CP=cp -p
MKDIR=mkdir -p
BUILD=production
prefix=@prefix@
srcdir=@srcdir@
root_objdir=@objdir@
exec_prefix=@exec_prefix@
datarootdir=@datarootdir@
datadir=@datadir@
bindir=@bindir@
libdir=@libdir@
libexecdir=@libexecdir@
docdir=${datadir}/doc/@PACKAGE_TARNAME@
# Are xmlada sources in our source tree
xmlada_build_target=@xmlada_build_target@
xmlada_prj_flags=@xmlada_prj_flags@
# How do we want to use XML/Ada ?
LIBRARY_TYPE=static
export LIBRARY_TYPE
objdir=obj
ifeq ($(BUILD), debug)
objdir=obj-debug
endif
ifeq ($(BUILD), coverage)
objdir=obj-cov
endif
ifeq ($(BUILD), profiling)
objdir=obj-prof
endif
dummy:=$(shell $(MKDIR) $(objdir))
PROCESSORS ?= 0
GNATMAKE=gnatmake -p -m -j${PROCESSORS}
ifeq ($(strip $(filter-out %vms%,$(host))),)
GNATMAKE=${GNATMAKE} -XOS=vms
endif
ADA_GEN_SUBDIR=gnat
.PHONY: all distall gprbuild gprconfig gprclean gprinstall \
copy_gnat_src complete bootstrap
all: $(xmlada_build_target) $(ADA_GEN_SUBDIR)/stamp-snames
${GNATMAKE} $(xmlada_prj_flags) -Pgprbuild -XBUILD=${BUILD}
distall:
make GNATMAKE="$(GNATMAKE)" BUILD="$(BUILD)"
make BUILD="$(BUILD)" install
if [ "$(IS_WINDOWS)" = "false" ]; then \
$(CP) $(srcdir)/doinstall $(prefix) && \
chmod a+x $(prefix)/doinstall; \
fi
ifeq ($(BUILD), production)
strip $(prefix)/bin/gprbuild$(EXEXT)
strip $(prefix)/bin/gprclean$(EXEXT)
strip $(prefix)/bin/gprconfig$(EXEXT)
strip $(prefix)/bin/gprinstall$(EXEXT)
strip $(prefix)/bin/gprslave$(EXEXT)
strip $(prefix)/libexec/gprbuild/gprbind$(EXEXT)
strip $(prefix)/libexec/gprbuild/gprlib$(EXEXT)
endif
all gprconfig gprbuild gprclean: $(objdir)/gprbuild_dummies.o $(objdir)/link.o force
MOVE_IF_CHANGE=mv -f
-include $(srcdir)/gnat/Make-generated.in
copy_gnat_src: force
-cd $(ADA_GEN_SUBDIR); \
$(foreach f,$(shell cat $(ADA_GEN_SUBDIR)/MANIFEST.GPRBUILD), \
$(LN) $(GNAT_SOURCE_DIR)/$(f) . ;\
)
complete: copy_gnat_src all install
gprbuild:
${GNATMAKE} -Pgprbuild -XBUILD=${BUILD} gprbuild-main.adb
gprinstall:
${GNATMAKE} -Pgprbuild -XBUILD=${BUILD} gprinstall-main.adb
gprclean:
${GNATMAKE} -Pgprbuild -XBUILD=${BUILD} gprclean-main.adb
gprconfig:
${GNATMAKE} -Pgprbuild -XBUILD=${BUILD} gprconfig-main
bootstrap: gprconfig gprbuild
echo
echo "=== Bootstraping grpbuild"
make install prefix=bootstrap/install
-${MKDIR} bootstrap/${objdir}
bootstrap/install/bin/gprbuild -Pgprbuild -XBUILD=${BUILD} \
-XBUILD_TOOL=gprbuild
.PHONY: install clean distclean bootstrap-clean
bootstrap-clean:
bootstrap/install/bin/gprclean -Pgprbuild -XBUILD=${BUILD} \
-XBUILD_TOOL=gprbuild
install: install.data install.bin
-${MKDIR} ${datadir}/gpr
$(RM) -r ${datadir}/examples/gprbuild
-${MKDIR} ${datadir}/examples/gprbuild
${CP} -r examples/* ${datadir}/examples/gprbuild
${RM} -r ${datadir}/doc/gprbuild
-${MKDIR} ${datadir}/doc/gprbuild
for format in html txt pdf info; do \
if [ -d doc/$$format ] ; then \
${MKDIR} ${datadir}/doc/gprbuild/$$format; \
${CP} doc/$$format/* ${datadir}/doc/gprbuild/$$format; \
if [ $$format = html ] ; then \
${CP} doc/*.png ${datadir}/doc/gprbuild/html; \
sed -e "s/.*//" doc/gprbuild_gps.xml \
> ${datadir}/doc/gprbuild/html/gps_index.xml; \
fi; \
fi; \
done
install.data: force
-${MKDIR} ${datadir}/gprconfig
${CP} share/gprconfig/*.xml ${datadir}/gprconfig
${CP} share/gprconfig/gprconfig.xsd ${datadir}/gprconfig
-${MKDIR} ${datadir}/gpr
${CP} share/_default.gpr ${datadir}/gpr
install.bin: force
-${MKDIR} ${bindir}
${INSTALL_PROGRAM} gprconfig${EXEXT} ${bindir}
${INSTALL_PROGRAM} gprbuild${EXEXT} ${bindir}
${INSTALL_PROGRAM} gprclean${EXEXT} ${bindir}
${INSTALL_PROGRAM} gprinstall${EXEXT} ${bindir}
ifeq ($(IS_WINDOWS),true)
${CP} src/gprinstall.exe.manifest ${bindir}
chmod +x ${bindir}/gprinstall.exe.manifest
endif
${INSTALL_PROGRAM} gprslave${EXEXT} ${bindir}
-${MKDIR} ${libexecdir}/gprbuild
${INSTALL_PROGRAM} gprbind${EXEXT} ${libexecdir}/gprbuild/
${INSTALL_PROGRAM} gprlib${EXEXT} ${libexecdir}/gprbuild/
$(objdir)/gprbuild_dummies.o: src/gprbuild_dummies.c
gcc -c -o $@ $<
$(objdir)/link.o: gnat/link.c
gcc -c -o $@ $<
.PHONY: build_xmlada
build_xmlada:
cd $(srcdir)/xmlada && ./configure --build=$(build) \
--prefix=$(root_objdir)/xmlada/install
cd $(srcdir)/xmlada && make LIBRARY_TYPE=static static install_static
clean:
gnat clean -q -r -Pgprbuild
distclean:
gnat clean -q -r -Pgprbuild
@${RM} config.log config.status src/gprconfig-sdefault.ads
@${RM} Makefile
@${RM} $(objdir)/*
@${RM} -r bootstrap
make -C doc clean
make -C examples clean
.PHONY: doc install-doc tests examples force
doc:
make -C doc
install-doc:
-$(MKDIR) ${docdir}/html
${CP} doc/*.html ${docdir}/html
tests: force
cd internal/gprtests_python; python ./run-gprconfig-test.py
cd internal/gprtests_python; python ./run-gprbuild-test.py
######################
# Running tests locally
# Run tests with the locally compiled gprbuild (no "make install" necessary)
# You can set test_names and test_config from the command line to restrict
# the tests that are run. When running all the tests, only show the failing
# tests to make them more obvious. But when running a specific set of tests,
# display all results.
# Adds "~/.local/bin" to the PATH, in case gnatpython was installed with --user.
# Adds "." to the PATH, since some of the tests expect it.
######################
test_names=
test_config=
ifneq (${test_config},)
test_config_switch:=--config=${test_config}
else
test_config_switch=
endif
LOCAL_SETUP = cd internal/gprtests_python; PATH=${HOME}/.local/bin:${shell pwd}/install/bin:${PATH}:.
LOCAL_GPRCONFIG_TEST=${LOCAL_SETUP}; python ./run-gprconfig-test.py --diffs --enable-color -j${PROCESSORS} ${test_config_switch}
LOCAL_GPRBUILD_TEST=${LOCAL_SETUP}; python ./run-gprbuild-test.py --diffs --enable-color -j${PROCESSORS} ${test_config_switch}
install_local: force
@make prefix=${shell pwd}/install install
tests_local: install_local
ifeq (${test_names},)
@${LOCAL_GPRCONFIG_TEST} --loglevel=ERROR
@${LOCAL_GPRBUILD_TEST} --loglevel=ERROR
else
@${LOCAL_GPRCONFIG_TEST} --loglevel=INFO ${test_names}
@${LOCAL_GPRBUILD_TEST} --loglevel=INFO ${test_names}
endif
examples: force
make -C examples
force:
gprbuild-gpl-2014-src/COPYING3 0000644 0000767 0000145 00000104513 12242550044 015252 0 ustar gnatmail gnat GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc.
Copyright (C)
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT 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
along with this program. If not, see Copyright (C)
This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, your program's commands
might be different; for a GUI interface, you would use an "about box".
You should also get your employer (if you work as a programmer) or school,
if any, to sign a "copyright disclaimer" for the program, if necessary.
For more information on this, and how to apply and follow the GNU GPL, see
.
gprbuild-gpl-2014-src/obj/ 0000755 0000767 0000145 00000000000 12317234553 014711 5 ustar gnatmail gnat gprbuild-gpl-2014-src/features-15 0000644 0000767 0000145 00000006340 11452325114 016117 0 ustar gnatmail gnat ==============================
GPRBUILD 1.5 NEW FEATURES LIST
==============================
Copyright (C) 2009-2010, AdaCore
This file contains a complete list of new features in version 1.5 of GPRBUILD.
A full description of all GPRBUILD features can be found in the GPRBUILD
User's Guide.
An ISO date (YYYY-MM-DD) appears in parentheses after the description line.
This date shows the implementation date of the feature. Any 1.5.0w
wavefront subsequent to this date will contain the indicated feature, as
will any subsequent releases.
NF-15-J928-007 Indexed variables in knowledge base (2010-10-04)
To avoid an ambiguity in the nodes when multiple
compilers are selected, the substitution variables need to be indexed by
the language of the corresponding compiler.
NF-15-J915-016 No linking with GNAT libs with -nostdlib (2010-09-17)
When a shared library is linked and -nostdlib is in the library options, then
the GNAT libraries are not used for the link.
NF-15-J614-021 New command line switch --source-info= (2010-06-29)
A new command line switch is added to gprbuild, to read a source info file,
instead of looking for sources. If the source info file does not exist, it is
created, so that subsequent invocation of gprbuild may use it.
NF-15-J614-004 Recompilation if ALI file newer than object file (2010-06-15)
If the gprbuild finds that an ALI file is newer than the corresponding
object file, then the corresponding source is recompiled, as the object
file was not produced at the same time the ALI file was produced.
NF-15-J325-005 New attributes for leading options (2010-04-12)
New attributes Leading_Library_Options and Linker'Leading_Switches are
added.
NF-15-IC02-005 New switch -x (2009-12-07)
gprbuild no longer create an include path file to the compiler, except when
the new switch -x is used. This is to improve performances.
NF-15-IB26-022 New switch -R (2009-11-26)
gprbuid now recognizes the gnatmake switch -R. When this switch is specified,
no run path option is used when linking executables and shared libraries.
NF-15-IB20-033 New switch --no-object-check (2009-11-23)
A new switch --no-object-check is added to gprbuild. When this switch is
used, the object files are not checked, the switch files are not checked even
when switch -s is used and there is no binding or linking.
NF-15-IA18-001 No shared libgnat by default with C++ (2009-10-20)
When Ada and C++ are used, the shared versions of the GNAT libraries
are no longer used by default. However, the shared version of libgcc
is always used.
NF-15-I713-006 Relative paths in the run path option (2009-10-21)
For platforms where the linker supports -z origin and $ORIGIN in the run
path option, use paths relative to the exec directory in the run path
option.
NF-15-I416-017 Builder switches when there is no main (2010-06-02)
When there is no main specified and there is only one compiled language
in the main project, gprbuild now takes into account the builder switches
for this language in package Builder of the main project.
NF-15-HA09-027 Gprbuild support for GNAAMP (2010-05-07)
Gprbuild has been adapted for use with GNAAMP and will now properly invoke
the gnaamp compiler and related tools.
gprbuild-gpl-2014-src/known-problems-202 0000644 0000767 0000145 00000012133 12262541374 017341 0 ustar gnatmail gnat ========================================
Known problems in GPRBUILD version 2.0.2
========================================
Copyright (C) 2013, AdaCore
The following is a listing of known problems in release 2.0.2. Except where
specifically noted, all these problems have been corrected in the development
tree of the 2.1 technology. This means they are corrected in any 2.1.0w
wavefront issued subsequent to the date specified (in ISO format YYYY-MM-DD) in
the status line. This can be used to determine if a given wavefront has the fix
identified in the entry.
KP-202-MA30-007 Aggregated projects with same name
Problem: When gprbuild is invoked with an aggregate project and some of
the aggregated projects have a common name, linking some
executables may fail in one or several of these aggregated
projects.
Status: This was fixed in 2.1 on 2013-10-30
Workaround: Use diffrent project names for the aggregated projects.
KP-202-MA15-017 gprclean crashes cleaning a library project without object dir
Problem: gprclean crashes with an exception when invoked to clean a
library project with a specified object directory that does not
exist.
Status: This was fixed in 2.1 on 2013-10-15
Workaround: Make sure that all object directories exist before invoking
gprclean.
KP-202-MA11-007 Aggregate projects and mains with no suffix
Problem: When the main project is an aggregate project, gprbuild does
not recognize mains specified without suffix, including in
attributes Main in aggregated projects.
Status: This was fixed in 2.1 on 1013-10-11
Workaround: Use full source file names for mains.
KP-202-M913-037 Several compilations of the same source with aggregated project
Problem: When gprbuild is invoked with an aggregate project and the same
project A belongs to several project trees rooted at the
aggregated projects, sources of project A may be compiled or
recompiled several times.
Status: This was fixed in 2.1 on 2013-09-15
Workaround: Invoke gprbuild individually on the aggregated projects.
KP-202-M910-024 None dependency kind and non empty dependency switches
Problem: gprbuild may crash or behave incorrectly when the Dependency_Kind
for a language is "None" and the Dependency_Switches is declared
as a non empty list.
Status: This was fixed in 2.1 on 2013-09-10
Workaround: Make sure that when Dependency_Kind is "None",
Dependency_Switches is not declared or is declared with an empty
list value, including in the configuration project file.
KP-202-M903-002 Incorrect link with gprbuild -l
Problem: When gprbuild is invoked with -l to link an executable and
there are non Ada object files to be put in the global archive
gprbuild may crash or link incorrectly the executable.
Status: This was fixed in 2.1 on 2013-09-04
Workaround: Invoke gprbuild without switch -l.
KP-202-M625-043 Minimal recompilation and preprocessed sources
Problem: When gprbuild is invoked with -m (minimal recompilation) and
a source that need preprocessing is checked for its checksum
to decide if it needs to be recompiled, gprbuild may behave
incorrectly, either reporting "preprocessor not active" errors
or even crashing.
Status: This was fixed in 2.1 on 2013-06-26
Workaround: Invoke gprbuild without switch -m.
KP-202-M617-043 --single-compile-per-obj-dir in package Builder
Problem: When switches --single-compile-per-obj-dir is specified in
package Builder of the main project, it has no effect for
simultaneous compilations.
Status: This was fixed in 2.1 on 2013-08-08
Workaround: Use --single-compile-per-obj-dir on the command line.
KP-202-M417-023 Deeply extended library projects
Problem: When a library A project extends a project B that itself extends
a project C, object files for sources that are not immediate
sources of projects A or B are not included in the library file.
Status: This was fixed in 2.1 on 2013-04-17
Workaround: Do not extend an already extending library project.
KP-202-M116-027 aggregated projects sharing extended projects
Problem: gprbuild refuses aggregate projects where several aggregated
project trees share a project that is extended at least once.
Status: This was fixed in 2.1 on 2013-01-18
Workaround: Do not aggregate projects that share an extended project.
KP-202-KC15-051 gprconfig should not parse twice the same knowledge base
Problem: gprconfig, in some circumstances, may parse several times the
same knowledge base directory. This may result in an invalid
configuration project file, for example the same string type
may be declared several times.
Status: This was fixed in 2.1 on 2013-02-04
Workaround: Avoid parsing several times the same knowledge base directory.
gprbuild-gpl-2014-src/known-problems-140 0000644 0000767 0000145 00000005124 11343556011 017335 0 ustar gnatmail gnat ========================================
Known problems in GPRBUILD version 1.4.0
========================================
Copyright (c) 2009,2010 AdaCore
The following is a listing of known problems in release 1.4.0. All these
problems have been corrected in the release 1.4.1 and in any wavefront
issued subsequent to the date specified (in ISO format YYYY-MM-DD) in the
status line. This can be used to determine if a given wavefront has the fix
identified in the entry.
KP-140-IC10-043 No switches file created when -s in Builder switches
Problem: When gprbuild switch -s is specified in the Builder switches of
the main project, but not on the command line, no switches fie
is created, resulting in recompilation of all sources each time
gprbuild is invoked.
Status: This was fixed in 1.5.0 on 2009-12-10
Workaround: Specify -s on the command line.
KP-140-IC09-017 Bad compilation options
Problem: When there are empty compilation options, these options are
replaced by random values, which may lead to compilation errors.
Status: This was fixed in 1.5.0 on 2009-12-09
Workaround: Avoid empty compilation options
KP-140-IC03-003 gprbind cannot bind with Binder option -C
Problem: When there is an option -C in the Binder package, the binding
of Ada executables fail.
Status: This was fixed in 1.5.0 on 2009-12-03
Workaround: Do not specify Binder option -C.
KP-140-IC02-002 Library not rebuilt when source is recompiled
Problem: When in a library project a modified source is recompiled, the
library is not always rebuilt.
Status: This was fixed in 1.5.0 on 2009-12-02
Workaround: Invoke gprbuild twice: the library will be rebuilt for the second
invocation.
KP-140-IA29-033 Library built with different symbolic links
Problem: When a library has been built in a setup where there are
symbolic links and it is part of another setup with different
or no symbolic links, gprbuild always attempts to rebuild
the library.
Status: This was fixed in 1.5.0 on 2009-11-04
Workaround: Always invoke gprbuild with -eL.
KP-140-IA27-015 Static library built in chunks contains duplicate object files
Problem: When static libraries (archives) are built in chunks and are
rebuilt, they may contains duplicate object files, including
old object files that should have been replaced.
Status: This was fixed in 1.5.0 on 2009-10-27
Workaround: Delete the archive before rebuilding it.
gprbuild-gpl-2014-src/gprbuild.gpr 0000644 0000767 0000145 00000014677 12323721731 016474 0 ustar gnatmail gnat with "xmlada";
project Gprbuild is
type OS_Type is ("unix", "avms", "ivms", "Windows_NT");
OS : OS_Type := external ("OS", "unix");
type Build_Type is ("debug", "production", "coverage", "profiling");
Bld : Build_Type := external ("BUILD", "debug");
type Build_Tool_Type is ("gnatmake", "gprbuild");
Build_Tool : Build_Tool_Type := external ("BUILD_TOOL", "gnatmake");
type VCS_Type is ("Subversion", "Git", "auto");
VCS_Kind : VCS_Type := external ("PRJ_VCS", "Subversion");
Processors := external ("PROCESSORS", "1");
for Main use
("gprconfig-main.adb",
"gprbuild-main.adb",
"gprbind.adb",
"gprlib.adb",
"gprclean-main.adb",
"gprinstall-main.adb",
"gprslave.adb");
for Source_Dirs use ("src", "gnat");
case Build_Tool is
when "gprbuild" =>
case Bld is
when "production" => for Object_Dir use "bootstrap/obj";
when "coverage" => for Object_Dir use "bootstrap/obj-cov";
when "profiling" => for Object_Dir use "bootstrap/obj-prof";
when "debug" => for Object_Dir use "bootstrap/obj-debug";
end case;
for Exec_Dir use "bootstrap";
when "gnatmake" =>
case Bld is
when "production" => for Object_Dir use "obj";
when "coverage" => for Object_Dir use "obj-cov";
when "profiling" => for Object_Dir use "obj-prof";
when "debug" => for Object_Dir use "obj-debug";
end case;
for Exec_Dir use ".";
end case;
case Build_Tool is
when "gprbuild" =>
for Languages use ("Ada", "C");
when "gnatmake" =>
for Languages use ("Ada", "C");
-- We only build the Ada part with projects so that we do not
-- have boostrap issues with gprbuild.
end case;
package Builder is
for Executable ("gprconfig-main.adb") use "gprconfig";
for Executable ("gprbuild-main.adb") use "gprbuild";
for Executable ("gprclean-main.adb") use "gprclean";
for Executable ("gprinstall-main.adb") use "gprinstall";
for Default_Switches ("Ada") use ("-m", "-j" & Processors);
for Switches ("Ada") use ();
end Builder;
package Compiler is
common_switches := ("-gnat12", "-gnaty", "-gnatQ");
case Bld is
when "debug" =>
for Default_Switches ("Ada") use common_switches &
("-g", "-gnata", "-gnatVa", "-gnatwaCJI"
, "-gnatwe"
, "-gnatyg"
);
for Local_Configuration_Pragmas use "debug.adc";
when "coverage" =>
for Default_Switches ("Ada") use common_switches &
("-ftest-coverage", "-fprofile-arcs");
when "profiling" =>
for Default_Switches ("Ada") use common_switches &
("-pg", "-g");
when "production" =>
for Default_Switches ("Ada") use common_switches &
("-O2", "-gnatpn", "-gnatws");
end case;
end Compiler;
package Binder is
common_switches := ("-E", "-static");
case Bld is
when "debug" =>
for Default_Switches ("Ada") use common_switches
& ("-Sin")
;
when "coverage" | "profiling" | "production" =>
for Default_Switches ("Ada") use common_switches;
end case;
end Binder;
package Linker is
Common_Switches := (project'Object_Dir & "/gprbuild_dummies.o",
project'Object_Dir & "/link.o");
-- We use project'Object_Dir here instead of GprBuild'Object_Dir
-- for compatibility with GNAT Pro 6.0.2.
Common_Switches_VMS :=
(project'Object_Dir & "/gprbuild_dummies.obj",
project'Object_Dir & "/link.obj");
case Build_Tool is
when "gnatmake" =>
-- Link manually the C part
case Bld is
when "production" | "debug" =>
case OS is
when "avms" | "ivms" =>
for Default_Switches ("Ada") use Common_Switches_VMS;
when others =>
for Default_Switches ("Ada") use Common_Switches;
end case;
when "coverage" =>
case OS is
when "avms" | "ivms" =>
for Default_Switches ("Ada") use Common_Switches_VMS;
when others =>
for Default_Switches ("Ada") use
Common_Switches & ("-lgcov");
end case;
when "profiling" =>
for Default_Switches ("Ada") use Common_Switches & ("-pg", "-g");
end case;
when "gprbuild" =>
null;
end case;
end Linker;
Common_Excluded_Source_Files :=
("gprlib-build_shared_lib.adb",
"gprlib-build_shared_lib-nosymbols.adb",
"gprlib-build_shared_lib-vms.adb",
"mlib-tgt-specific.adb",
"mlib-tgt-vms-alpha.adb",
"mlib-tgt-vms-ia64.adb");
case Build_Tool is
when "gprbuild" =>
case OS is
when "unix" | "Windows_NT" =>
for Locally_Removed_Files
use Common_Excluded_Source_Files &
("mlib-tgt-vms.ads", "mlib-tgt-vms.adb");
-- Excluded_Source_File not supported by GNAT Pro 6.0.2
when "avms" | "ivms" =>
for Locally_Removed_Files
use Common_Excluded_Source_Files;
-- Excluded_Source_File not supported by GNAT Pro 6.0.2
end case;
when "gnatmake" =>
null;
end case;
package Naming is
case OS is
when "unix" | "Windows_NT" =>
for Body ("gprlib.build_shared_lib")
use "gprlib-build_shared_lib-nosymbols.adb";
for Body ("mlib.tgt.specific")
use "mlib-tgt-specific.adb";
when "avms" =>
for Body ("gprlib.build_shared_lib")
use "gprlib-build_shared_lib-vms.adb";
for Body ("mlib.tgt.specific")
use "mlib-tgt-specific-vms-alpha.adb";
when "ivms" =>
for Body ("gprlib.build_shared_lib")
use "gprlib-build_shared_lib-vms.adb";
for Body ("mlib.tgt.specific")
use "mlib-tgt-specific-vms-ia64.adb";
end case;
end Naming;
package IDE is
for VCS_Kind use VCS_Kind;
end IDE;
end Gprbuild;
gprbuild-gpl-2014-src/obj-cov/ 0000755 0000767 0000145 00000000000 12317234553 015476 5 ustar gnatmail gnat gprbuild-gpl-2014-src/install-sh 0000755 0000767 0000145 00000011245 10517620563 016146 0 ustar gnatmail gnat #! /bin/sh
#
# install - install a program, script, or datafile
# This comes from X11R5.
#
# Calling this script install-sh is preferred over install.sh, to prevent
# `make' implicit rules from creating a file called install from it
# when there is no Makefile.
#
# This script is compatible with the BSD install script, but was written
# from scratch.
#
# set DOITPROG to echo to test this script
# Don't use :- since 4.3BSD and earlier shells don't like it.
doit="${DOITPROG-}"
# put in absolute paths if you don't have them in your path; or use env. vars.
mvprog="${MVPROG-mv}"
cpprog="${CPPROG-cp}"
chmodprog="${CHMODPROG-chmod}"
chownprog="${CHOWNPROG-chown}"
chgrpprog="${CHGRPPROG-chgrp}"
stripprog="${STRIPPROG-strip}"
rmprog="${RMPROG-rm}"
mkdirprog="${MKDIRPROG-mkdir}"
transformbasename=""
transform_arg=""
instcmd="$mvprog"
chmodcmd="$chmodprog 0755"
chowncmd=""
chgrpcmd=""
stripcmd=""
rmcmd="$rmprog -f"
mvcmd="$mvprog"
src=""
dst=""
dir_arg=""
while [ x"$1" != x ]; do
case $1 in
-c) instcmd="$cpprog"
shift
continue;;
-d) dir_arg=true
shift
continue;;
-m) chmodcmd="$chmodprog $2"
shift
shift
continue;;
-o) chowncmd="$chownprog $2"
shift
shift
continue;;
-g) chgrpcmd="$chgrpprog $2"
shift
shift
continue;;
-s) stripcmd="$stripprog"
shift
continue;;
-t=*) transformarg=`echo $1 | sed 's/-t=//'`
shift
continue;;
-b=*) transformbasename=`echo $1 | sed 's/-b=//'`
shift
continue;;
*) if [ x"$src" = x ]
then
src=$1
else
# this colon is to work around a 386BSD /bin/sh bug
:
dst=$1
fi
shift
continue;;
esac
done
if [ x"$src" = x ]
then
echo "install: no input file specified"
exit 1
else
true
fi
if [ x"$dir_arg" != x ]; then
dst=$src
src=""
if [ -d $dst ]; then
instcmd=:
else
instcmd=mkdir
fi
else
# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
# might cause directories to be created, which would be especially bad
# if $src (and thus $dsttmp) contains '*'.
if [ -f $src -o -d $src ]
then
true
else
echo "install: $src does not exist"
exit 1
fi
if [ x"$dst" = x ]
then
echo "install: no destination specified"
exit 1
else
true
fi
# If destination is a directory, append the input filename; if your system
# does not like double slashes in filenames, you may need to add some logic
if [ -d $dst ]
then
dst="$dst"/`basename $src`
else
true
fi
fi
## this sed command emulates the dirname command
dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
# Make sure that the destination directory exists.
# this part is taken from Noah Friedman's mkinstalldirs script
# Skip lots of stat calls in the usual case.
if [ ! -d "$dstdir" ]; then
defaultIFS='
'
IFS="${IFS-${defaultIFS}}"
oIFS="${IFS}"
# Some sh's can't handle IFS=/ for some reason.
IFS='%'
set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
IFS="${oIFS}"
pathcomp=''
while [ $# -ne 0 ] ; do
pathcomp="${pathcomp}${1}"
shift
if [ ! -d "${pathcomp}" ] ;
then
$mkdirprog "${pathcomp}"
else
true
fi
pathcomp="${pathcomp}/"
done
fi
if [ x"$dir_arg" != x ]
then
$doit $instcmd $dst &&
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
else
# If we're going to rename the final executable, determine the name now.
if [ x"$transformarg" = x ]
then
dstfile=`basename $dst`
else
dstfile=`basename $dst $transformbasename |
sed $transformarg`$transformbasename
fi
# don't allow the sed command to completely eliminate the filename
if [ x"$dstfile" = x ]
then
dstfile=`basename $dst`
else
true
fi
# Make a temp file name in the proper directory.
dsttmp=$dstdir/#inst.$$#
# Move or copy the file name to the temp name
$doit $instcmd $src $dsttmp &&
trap "rm -f ${dsttmp}" 0 &&
# and set any options; do chmod last to preserve setuid bits
# If any of these fail, we abort the whole thing. If we want to
# ignore errors from any of these, just make sure not to ignore
# errors from the above "$doit $instcmd $src $dsttmp" command.
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
# Now rename the file to the real destination.
$doit $rmcmd -f $dstdir/$dstfile &&
$doit $mvcmd $dsttmp $dstdir/$dstfile
fi &&
exit 0
gprbuild-gpl-2014-src/README 0000644 0000767 0000145 00000006050 12313645070 015014 0 ustar gnatmail gnat Preliminary note for Windows users
==================================
The build instructions for gprbuild may have a slight UNIX flavor but they
can be used on Windows platforms with a full CYGWIN installation. The latter
makes it simpler to build gprbuild but is not required to use it.
Configuring
===========
Configuring is usually done simply as:
./configure
Two parameters may be worth specifying: --prefix for specifying the
installation root and --build for specifying the build host.
In particular, on Windows, when using cygwin to build, it is necessary to
configure with --build=i686-pc-mingw32 if one wants to use 32 bit mingw based
compilers such as GNAT Pro or GNAT GPL, and with --build=x86_64-pc-mingw32 for
64 bit compilers. Here are examples of such commands:
./configure --build=i686-pc-mingw32 --prefix=$HOME/local
./configure --build=x86_64-pc-mingw32 --prefix=$HOME/local
Using alternate GNAT Sources
============================
Gprbuild uses some sources of the GNAT package. They are expected by default
to be located in the gnat/ subdirectory of Gprbuild. Only some of the GNAT
sources are required, but note that having all of the GNAT sources present
in the gnat/ subdirectory will result in build failure.
In order to use GNAT sources from another location, create a link named
gnat_src and call the Makefile target copy_gnat_src:
ln -s gnat_src
make copy_gnat_src
That will place links into the gnat/ subdirectory for each of the required
GNAT source files.
On Windows with Cygwin, the files must be copied because symbolic links do not
work. The definition of GNAT_SOURCE_DIR in the Makefile needs to be modified so
that it specifies the path to the GNAT sources. For example:
GNAT_SOURCE_DIR=$(HOME)/gnat
Then call the Makefile target copy_gnat_src:
make copy_gnat_src
The Makefile will recognize the use of Windows and will therefore place a
copy of the required files into the gnat/ subdirectory.
Alternatively you can specify GNAT_SOURCE_DIR on the command line when invoking
the makefile target:
make copy_gnat_src GNAT_SOURCE_DIR=
Note that target "copy_gnat_src" is invoked automatically by target "complete".
Building and Installing
=======================
XML/Ada must be installed before building.
Building the main executables is done simply with
make all
When compiling, you can choose whether you want to link statically with
XML/Ada (the default), or dynamically. To compile dynamically, you should
run
make LIBRARY_TYPE=relocatable all
instead of the above.
Installation is done with
make install
Doc & Examples
==============
The documention is provided in various formats in the doc subdirectory.
It refers to concrete examples that are to be found in the
examples subdirectory. Each example can be built easily using the
simple attached Makefile:
make all # build the example
make run # run the executable(s)
make clean # cleanup
All the examples can be built/run/cleaned using the same targets and
the toplevel examples Makefile.
gprbuild-gpl-2014-src/features-22 0000644 0000767 0000145 00000004436 12313013502 016111 0 ustar gnatmail gnat ==============================
GPRBUILD 2.2 NEW FEATURES LIST
==============================
Copyright (C) 2013-2014, AdaCore
This file contains a complete list of new features in version 2.2 of GPRBUILD.
A full description of all GPRBUILD features can be found in the GPRBUILD
User's Guide.
NF-22-N321-014 Add support for LLVM C compiler (2014-03-21)
This adds support for compiling and linking with the LLVM C compiler (clang).
NF-22-N310-033 Display slaves name for remote compilation errors (2014-03-15)
When a remote compilation fails we now display on which remote computer
this compilation was conducted. This can helps finding remote computers
with incorrect setup for example.
NF-22-N206-046 Advice to use --help for incorrectly invoked tools (2014-02-10)
When a gpr tool (gprbuild, gprconfig, gprclean or gprinstall) is incorrectly
invoked, with at least one argument, the usage will no longer be displayed.
Instead this line will be displayed:
type "gprxxx --help" for more information.
NF-22-N130-015 Check distributed build consistency (2014-02-03)
A check is now done to ensure that build slaves, used on a distributed
compilation farm, are all of the same version as the build master.
NF-22-N121-005 Check for clock drift in distributed mode (2014-01-29)
A clock check is done between the slaves and the build master before
starting a distributed compilation. A warning is issued if a clock drift
is detected. It is important to have the clock properly synchronized to
avoid unneeded recompilation.
NF-22-N115-029 GPRinstall supports listing of installed packages (2014-03-13)
A new mode, enabled with the option --list, can be used in GPRinstall to
display the installed packages. Used with --stat a set of statistics are
also displayed like the number of installed files and the total size on disk.
NF-22-N108-032 Add support for grouping installs with gprinstall (2014-01-22)
A new option named --install-name can be used to group installations
under a single name. It makes it possible to uninstall with a single
command the multiple installations. This can be handy when a library
comes with some tools for example, both built with different projects files.
Yet, the library and the executables are tightly related and part of the
same application.
gprbuild-gpl-2014-src/known-problems-201 0000644 0000767 0000145 00000001572 12150651123 017333 0 ustar gnatmail gnat ========================================
Known problems in GPRBUILD version 2.0.1
========================================
Copyright (C) 2013, AdaCore
The following is a listing of known problems in release 2.0.1. Except where
specifically noted, all these problems have been corrected in the development
tree of the 2.1 technology. This means they are corrected in any 2.1.0w
wavefront issued subsequent to the date specified (in ISO format YYYY-MM-DD) in
the status line. This can be used to determine if a given wavefront has the fix
identified in the entry.
KP-201-M125-039 Library version on IA64 HP-UX
Problem: On IA64 HP-UX, gprbuild fails to build a shared library when
attribute Library_Version is declared.
Status: This was fixed in 2.1 on 2013-01-25
This was fixed in 2.0.2 on 2013-05-27
Workaround: Do not specify Library_Version.
gprbuild-gpl-2014-src/known-problems-160 0000644 0000767 0000145 00000002320 12032613023 017323 0 ustar gnatmail gnat ========================================
Known problems in GPRBUILD version 1.6.0
========================================
Copyright (C) 2011-2012, AdaCore
The following is a listing of known problems in release 1.6.0. Except where
specifically noted, all these problems have been corrected in the development
tree of the 2.0 technology. This means they are corrected in any 1.7.0w/2.0.0w
wavefront issued subsequent to the date specified (in ISO format YYYY-MM-DD) in
the status line. This can be used to determine if a given wavefront has the fix
identified in the entry.
KP-160-K917-002 Ignore compilers when variables cannot be computed
Problem: In gprconfig, if a compiler description includes the computation
of extra variables (like "gcc_version" for GNAT) and this
variable cannot be computed, the compiler should simply be
ignored. Instead, gprconfig stops working. In particular,
gprconfig failed if a .NET compiler for Ada was installed on the
machine.
Status: This was fixed in 1.6.1 on 2011-10-24
Workaround: Use the command line switches to specify the compilers to use,
rather than let gprconfig auto-detect them.
gprbuild-gpl-2014-src/doinstall 0000755 0000767 0000145 00000006160 11765654220 016064 0 ustar gnatmail gnat #!/bin/sh
prefix=''
has_gnatpro=n
machine=''
ggd_prefix=''
if [ "x$ggd_prefix" = "x" ]; then
ggd_prog="gnatmake"
else
ggd_prog="$ggd_prefix-gnatmake"
fi
if type $ggd_prog > /dev/null 2>&1 &&
$ggd_prog -v 2>&1 | grep GNATMAKE | grep -q Pro;
then
has_gnatpro=y
prefix=`type $ggd_prog | cut -d' ' -f3 | sed 's%/bin.*$%%'`
machine=`$prefix/bin/gcc -dumpmachine || true`
fi
gprbuild="gprbuild"
clear
cat << EOF
This script is provided to simplify the installation of the
$machine
binary distribution of $gprbuild - the multi languages project builder.
For information on commercial support, please contact sales@adacore.com.
This script will ask a few questions regarding the $gprbuild installation.
Confirmation is required before any write action is taken.
Please press RETURN to continue.
EOF
read x
# --------------------- Select installation option --------------------
clear
cat << EOF
There are 2 options for installation:
EOF
if [ "$has_gnatpro" = "y" ]; then
cat <"), the attribute is not taken
into account.
Status: This was fixed in 1.6.0 on 2011-02-28
Workaround: Use language names in lower case.
KP-151-K223-005 Bad handling of pragmas Linker_Options and Link_With
Problem: On Windows, the stack for executables with tasking is incorrectly
specified to the linker.
Status: This was fixed in 1.6.0 on 2011-02-24
Workaround: Use gnatmake instead of gprbuild for linking.
KP-151-K209-050 Crash when main is an excluded file
Problem: When one of the main is also an excluded source file, gprbuild
crashes when attempting to check if the main needs to be
compiled.
Status: This was fixed in 1.6.0 on 2011-02-10
Workaround: Remove the main from the list of excluded source files.
KP-151-K125-041 No binding of locally removed sources
Problem: When the main is not in Ada and there are no Roots specified,
an attempt is made to bind locally removed Ada sources, resulting
in a gprbuild crash.
Status: This was fixed in 1.5.2 on 2011-02-02
Workaround: Remove the sources instead of declaring them locally removed.
KP-151-JC23-006 Link time error on big projects with powerpc-elf
Problem: When linking projects with a sufficiently big number of units the
link phase fails with missing symbol errors. This is a command
line limitation error when gprbuild calls the linker.
Status: This was fixed in 1.6.0 on 2011-03-16
Workaround: force the use of a response file by using the following
attributes in package Linker:
for Max_Command_Line_Length use "8000";
for Response_File_Format use "GNU";
gprbuild-gpl-2014-src/debug.adc 0000755 0000767 0000145 00000000033 12323721731 015671 0 ustar gnatmail gnat pragma Initialize_Scalars;
gprbuild-gpl-2014-src/features-11 0000644 0000767 0000145 00000004755 11001654624 016124 0 ustar gnatmail gnat =========================================================
GPRBUILD 1.1 NEW FEATURES LIST Current as of Mar 04, 2008
=========================================================
Copyright (c) 2008, AdaCore
This file contains a complete list of new features in version 1.1 of GPRBUILD.
A full description of all GPRBUILD features can be found in the GPRBUILD
User's Guide.
An ISO date (YYYY-MM-DD) appears in parentheses after the description line.
This date shows the implementation date of the feature. Any 1.1.0w
wavefront subsequent to this date will contain the indicated feature, as
will any subsequent releases.
NF-11-H402-020 Static lib projects may import standard projects (2008-04-02)
The restriction that static library projects could only import library
projects has been lifted. Shared library projects are still allowed to
import only shared library projects.
NF-11-H324-006 Restricted imports of sources (2008-04-01)
New functionalities have been added to restrict the set of sources or
header files that can be inported:
- switch --direct-import-only forbid sources of a projects to imports
sources or header files of a project that is not directly withed.
- attribute Interfaces lists the sources and header files that are allowed
to be imported from sources of an importing project.
NF-11-H312-002 Languages with no compilers (2008-03-12)
When the Compiler'Driver for a language is specified as the empty string,
gprbuild is silently ignoring all of it sources. This is tru, by default,
for language "Project File", when using automatic configuration.
NF-11-H226-001 All lib projects may import project without sources (2008-02-26)
All library projects, including shared library projects, are allowed to
import projects without any sources, even when this is not declared
explicitly.
NF-11-H212-018 New attribute Inherit_Source_Path (2008-02-13)
A new attribute Inherit_Source_Path allows sources of a language to import
source or header file from another language. Example:
for Inherit_Source_Path ("C++") use ("C");
allows C++ sources to be compiled with a source search path that include
all source directories of imported projects with C declared as a language.
NF-11-H117-025 Unrecognized gprbuild switches passed to compiler (2008-01-19)
When gprbuild takes into account attribute Builder'Default_Switches ()
any switch it does not recognizes is passed to the compiler of language
for all sources of language in all projects.
gprbuild-gpl-2014-src/gnat/ 0000755 0000767 0000145 00000000000 12323721724 015066 5 ustar gnatmail gnat gprbuild-gpl-2014-src/gnat/xsnamest.adb 0000644 0000767 0000145 00000023770 12323721731 017407 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT SYSTEM UTILITIES --
-- --
-- X S N A M E S T --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This utility is used to make a new version of the Snames package when new
-- names are added. This version reads a template file from snames.ads-tmpl in
-- which the numbers are all written as $, and generates a new version of the
-- spec file snames.ads (written to snames.ns). It also reads snames.adb-tmpl
-- and generates an updated body (written to snames.nb), and snames.h-tmpl and
-- generates an updated C header file (written to snames.nh).
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
with Ada.Strings.Maps; use Ada.Strings.Maps;
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
with GNAT.Spitbol; use GNAT.Spitbol;
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
with XUtil; use XUtil;
procedure XSnamesT is
subtype VString is GNAT.Spitbol.VString;
InS : Ada.Text_IO.File_Type;
InB : Ada.Text_IO.File_Type;
InH : Ada.Text_IO.File_Type;
OutS : Ada.Streams.Stream_IO.File_Type;
OutB : Ada.Streams.Stream_IO.File_Type;
OutH : Ada.Streams.Stream_IO.File_Type;
A, B : VString := Nul;
Line : VString := Nul;
Name0 : VString := Nul;
Name1 : VString := Nul;
Oval : VString := Nul;
Restl : VString := Nul;
Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name0
& Span (' ') * B
& ": constant Name_Id := N + $;"
& Rest * Restl;
Get_Name : constant Pattern := "Name_" & Rest * Name1;
Chk_Low : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
Findu : constant Pattern := Span ('u') * A;
Val : Natural;
Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_");
M : Match_Result;
type Header_Symbol is (None, Name, Attr, Conv, Prag);
-- A symbol in the header file
procedure Output_Header_Line (S : Header_Symbol);
-- Output header line
Header_Name : aliased String := "Name";
Header_Attr : aliased String := "Attr";
Header_Conv : aliased String := "Convention";
Header_Prag : aliased String := "Pragma";
-- Prefixes used in the header file
type String_Ptr is access all String;
Header_Prefix : constant array (Header_Symbol) of String_Ptr :=
(null,
Header_Name'Access,
Header_Attr'Access,
Header_Conv'Access,
Header_Prag'Access);
-- Patterns used in the spec file
Get_Attr : constant Pattern := Span (' ') & "Attribute_"
& Break (",)") * Name1;
Get_Conv : constant Pattern := Span (' ') & "Convention_"
& Break (",)") * Name1;
Get_Prag : constant Pattern := Span (' ') & "Pragma_"
& Break (",)") * Name1;
type Header_Symbol_Counter is array (Header_Symbol) of Natural;
Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0, 0);
Header_Current_Symbol : Header_Symbol := None;
Header_Pending_Line : VString := Nul;
------------------------
-- Output_Header_Line --
------------------------
procedure Output_Header_Line (S : Header_Symbol) is
function Make_Value (V : Integer) return String;
-- Build the definition for the current macro (Names are integers
-- offset to N, while other items are enumeration values).
----------------
-- Make_Value --
----------------
function Make_Value (V : Integer) return String is
begin
if S = Name then
return "(First_Name_Id + 256 + " & V & ")";
else
return "" & V;
end if;
end Make_Value;
-- Start of processing for Output_Header_Line
begin
-- Skip all the #define for S-prefixed symbols in the header.
-- Of course we are making implicit assumptions:
-- (1) No newline between symbols with the same prefix.
-- (2) Prefix order is the same as in snames.ads.
if Header_Current_Symbol /= S then
declare
Name2 : VString;
Pat : constant Pattern := "#define "
& Header_Prefix (S).all
& Break (' ') * Name2;
In_Pat : Boolean := False;
begin
if Header_Current_Symbol /= None then
Put_Line (OutH, Header_Pending_Line);
end if;
loop
Line := Get_Line (InH);
if Match (Line, Pat) then
In_Pat := True;
elsif In_Pat then
Header_Pending_Line := Line;
exit;
else
Put_Line (OutH, Line);
end if;
end loop;
Header_Current_Symbol := S;
end;
end if;
-- Now output the line
-- Note that we must ensure at least one space between macro name and
-- parens, otherwise the parenthesized value gets treated as an argument
-- specification.
Put_Line (OutH, "#define " & Header_Prefix (S).all
& "_" & Name1
& (30 - Natural'Min (29, Length (Name1))) * ' '
& Make_Value (Header_Counter (S)));
Header_Counter (S) := Header_Counter (S) + 1;
end Output_Header_Line;
-- Start of processing for XSnames
begin
Open (InS, In_File, "snames.ads-tmpl");
Open (InB, In_File, "snames.adb-tmpl");
Open (InH, In_File, "snames.h-tmpl");
-- Note that we do not generate snames.{ads,adb,h} directly. Instead
-- we output them to snames.n{s,b,h} so that Makefiles can use
-- move-if-change to not touch previously generated files if the
-- new ones are identical.
Create (OutS, Out_File, "snames.ns");
Create (OutB, Out_File, "snames.nb");
Create (OutH, Out_File, "snames.nh");
Put_Line (OutH, "#ifdef __cplusplus");
Put_Line (OutH, "extern ""C"" {");
Put_Line (OutH, "#endif");
Anchored_Mode := True;
Val := 0;
loop
Line := Get_Line (InB);
exit when Match (Line, " Preset_Names");
Put_Line (OutB, Line);
end loop;
Put_Line (OutB, Line);
LoopN : while not End_Of_File (InS) loop
Line := Get_Line (InS);
if not Match (Line, Name_Ref) then
Put_Line (OutS, Line);
if Match (Line, Get_Attr) then
Output_Header_Line (Attr);
elsif Match (Line, Get_Conv) then
Output_Header_Line (Conv);
elsif Match (Line, Get_Prag) then
Output_Header_Line (Prag);
end if;
else
if Match (Name0, "Last_") then
Oval := Lpad (V (Val - 1), 3, '0');
else
Oval := Lpad (V (Val), 3, '0');
end if;
Put_Line
(OutS, A & Name0 & B & ": constant Name_Id := N + "
& Oval & ';' & Restl);
if Match (Name0, Get_Name) then
Name0 := Name1;
Val := Val + 1;
if Match (Name0, Findu, M) then
Replace (M, Translate (A, Xlate_U_Und));
Translate (Name0, Lower_Case_Map);
elsif not Match (Name0, "Op_", "") then
Translate (Name0, Lower_Case_Map);
else
Name0 := 'O' & Translate (Name0, Lower_Case_Map);
end if;
if not Match (Name0, Chk_Low) then
Put_Line (OutB, " """ & Name0 & "#"" &");
end if;
Output_Header_Line (Name);
end if;
end if;
end loop LoopN;
loop
Line := Get_Line (InB);
exit when Match (Line, " ""#"";");
end loop;
Put_Line (OutB, Line);
while not End_Of_File (InB) loop
Line := Get_Line (InB);
Put_Line (OutB, Line);
end loop;
Put_Line (OutH, Header_Pending_Line);
while not End_Of_File (InH) loop
Line := Get_Line (InH);
Put_Line (OutH, Line);
end loop;
Put_Line (OutH, "#ifdef __cplusplus");
Put_Line (OutH, "}");
Put_Line (OutH, "#endif");
end XSnamesT;
gprbuild-gpl-2014-src/gnat/atree.ads 0000644 0000767 0000145 00000420544 12323721731 016666 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- A T R E E --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, 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 3, 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. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- , etc).
procedure Set_All_Upper_Case;
pragma Inline (Set_All_Upper_Case);
-- This procedure is called with an identifier name stored in Name_Buffer.
-- On return, the identifier is converted to all upper case. The call is
-- equivalent to Set_Casing (All_Upper_Case).
function Determine_Casing (Ident : Text_Buffer) return Casing_Type;
-- Determines the casing of the identifier/keyword string Ident. A special
-- test is made for SPARK_Mode which is considered to be mixed case, since
-- this gives a better general behavior.
end Casing;
gprbuild-gpl-2014-src/gnat/butil.ads 0000644 0000767 0000145 00000006126 12323721731 016701 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- B U T I L --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2007, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Namet; use Namet;
package Butil is
-- This package contains utility routines for the binder
function Is_Predefined_Unit return Boolean;
-- Given a unit name stored in Name_Buffer with length in Name_Len,
-- returns True if this is the name of a predefined unit or a child of
-- a predefined unit (including the obsolescent renamings). This is used
-- in the preference selection (see Better_Choice in body of Binde).
function Is_Internal_Unit return Boolean;
-- Given a unit name stored in Name_Buffer with length in Name_Len,
-- returns True if this is the name of an internal unit or a child of
-- an internal. Similar in usage to Is_Predefined_Unit.
-- Note: the following functions duplicate functionality in Uname, but
-- we want to avoid bringing Uname into the binder since it generates
-- to many unnecessary dependencies, and makes the binder too large.
function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean;
-- Determines if the unit name U1 is alphabetically before U2
procedure Write_Unit_Name (U : Unit_Name_Type);
-- Output unit name with (body) or (spec) after as required. On return
-- Name_Len is set to the number of characters which were output.
end Butil;
gprbuild-gpl-2014-src/gnat/switch.ads 0000644 0000767 0000145 00000014313 12323721731 017060 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S W I T C H --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2012, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package together with a child package appropriate to the client tool
-- scans switches. Note that the body of the appropriate Usage package must be
-- coordinated with the switches that are recognized by this package. These
-- Usage packages also act as the official documentation for the switches
-- that are recognized. In addition, package Debug documents the otherwise
-- undocumented debug switches that are also recognized.
with Gnatvsn;
with Types; use Types;
------------
-- Switch --
------------
package Switch is
-- Common switches for GNU tools
Version_Switch : constant String := "--version";
Help_Switch : constant String := "--help";
-----------------
-- Subprograms --
-----------------
generic
with procedure Usage;
-- Print tool-specific part of --help message
procedure Check_Version_And_Help_G
(Tool_Name : String;
Initial_Year : String;
Version_String : String := Gnatvsn.Gnat_Version_String);
-- Check if switches --version or --help is used. If one of this switch is
-- used, issue the proper messages and end the process.
procedure Display_Version
(Tool_Name : String;
Initial_Year : String;
Version_String : String := Gnatvsn.Gnat_Version_String);
-- Display version of a tool when switch --version is used
procedure Display_Usage_Version_And_Help;
-- Output the two lines of usage for switches --version and --help
function Is_Switch (Switch_Chars : String) return Boolean;
-- Returns True iff Switch_Chars is at least two characters long, and the
-- first character is an hyphen ('-').
function Is_Front_End_Switch (Switch_Chars : String) return Boolean;
-- Returns True iff Switch_Chars represents a front-end switch, i.e. it
-- starts with -I, -gnat or -?RTS.
function Is_Internal_GCC_Switch (Switch_Chars : String) return Boolean;
-- Returns True iff Switch_Chars represents an internal GCC switch to be
-- followed by a single argument, such as -dumpbase, --param or -auxbase.
-- Even though passed by the "gcc" driver, these need not be stored in ALI
-- files and may safely be ignored by non GCC back-ends.
function Switch_Last (Switch_Chars : String) return Natural;
-- Index in Switch_Chars of the last relevant character for later string
-- comparison purposes. This is typically 'Last, minus one if there is a
-- terminating ASCII.NUL.
private
-- This section contains some common routines used by the tool dependent
-- child packages (there is one such child package for each tool that uses
-- Switches to scan switches - Compiler/gnatbind/gnatmake/.
Switch_Max_Value : constant := 999_999;
-- Maximum value permitted in switches that take a value
function Nat_Present
(Switch_Chars : String;
Max : Integer;
Ptr : Integer) return Boolean;
-- Returns True if an integer is at the current scan location or an equal
-- sign. This is used as a guard for calling Scan_Nat. Switch_Chars is the
-- string containing the switch, and Ptr points just past the switch
-- character. Max is the maximum allowed value of Ptr.
procedure Scan_Nat
(Switch_Chars : String;
Max : Integer;
Ptr : in out Integer;
Result : out Nat;
Switch : Character);
-- Scan natural integer parameter for switch. On entry, Ptr points just
-- past the switch character, on exit it points past the last digit of the
-- integer value. Max is the maximum allowed value of Ptr, so the scan is
-- restricted to Switch_Chars (Ptr .. Max). It is possible for Ptr to be
-- one greater than Max on return if the entire string is digits. Scan_Nat
-- will skip an optional equal sign if it is present. Nat_Present must be
-- True, or an error will be signalled.
procedure Scan_Pos
(Switch_Chars : String;
Max : Integer;
Ptr : in out Integer;
Result : out Pos;
Switch : Character);
-- Scan positive integer parameter for switch. Identical to Scan_Nat with
-- same parameters except that zero is considered out of range.
procedure Bad_Switch (Switch : Character);
procedure Bad_Switch (Switch : String);
pragma No_Return (Bad_Switch);
-- Fail with an appropriate message when a switch is not recognized
end Switch;
gprbuild-gpl-2014-src/gnat/stylesw.ads 0000644 0000767 0000145 00000037530 12323721731 017277 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S T Y L E S W --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package contains the style switches used for setting style options.
-- The only clients of this package are the body of Style and the body of
-- Switches. All other style checking issues are handled using the public
-- interfaces in the spec of Style.
with Types; use Types;
package Stylesw is
--------------------------
-- Style Check Switches --
--------------------------
-- These flags are used to control the details of the style checking
-- options. The default values shown here correspond to no style checking.
-- If any of these values is set to a non-default value, then
-- Opt.Style_Check is set True to activate calls to this package.
-- The actual mechanism for setting these switches to other than default
-- values is via the Set_Style_Check_Options procedure or through a call to
-- Set_Default_Style_Check_Options. They should not be set directly in any
-- other manner.
Style_Check_Array_Attribute_Index : Boolean := False;
-- This can be set True by using the -gnatyA switch. If it is True then
-- index numbers for array attributes (like Length) are required to be
-- absent for one-dimensional arrays and present for multi-dimensional
-- array attribute references.
Style_Check_Attribute_Casing : Boolean := False;
-- This can be set True by using the -gnatya switch. If it is True, then
-- attribute names (including keywords such as digits used as attribute
-- names) must be in mixed case.
Style_Check_Blanks_At_End : Boolean := False;
-- This can be set True by using the -gnatyb switch. If it is True, then
-- spaces at the end of lines are not permitted.
Style_Check_Blank_Lines : Boolean := False;
-- This can be set True by using the -gnatyu switch. If it is True, then
-- multiple blank lines are not permitted, and there may not be a blank
-- line at the end of the file.
Style_Check_Boolean_And_Or : Boolean := False;
-- This can be set True by using the -gnatyB switch. If it is True, then
-- the use of AND THEN/OR ELSE rather than AND/OR is required except for
-- the following cases:
--
-- a) Both operands are simple Boolean constants or variables
-- b) Both operands are of a modular type
-- c) Both operands are of an array type
Style_Check_Comments : Boolean := False;
-- This can be set True by using the -gnatyc switch. If it is True, then
-- comments are style checked as follows:
--
-- All comments must be at the start of the line, or the first minus must
-- be preceded by at least one space.
--
-- For a comment that is not at the start of a line, the only requirement
-- is that a space follow the comment characters.
--
-- For a comment that is at the start of the line, one of the following
-- conditions must hold:
--
-- The comment characters are the only non-blank characters on the line
--
-- The comment characters are followed by an exclamation point (the
-- sequence --! is used by gnatprep for marking deleted lines).
--
-- The comment characters are followed by two space characters if
-- Comment_Spacing = 2, else by one character if Comment_Spacing = 1.
--
-- The line consists entirely of minus signs
--
-- The comment characters are followed by a single space, and the last
-- two characters on the line are also comment characters.
--
-- Note: the reason for the last two conditions is to allow "boxed"
-- comments where only a single space separates the comment characters.
Style_Check_Comments_Spacing : Nat range 1 .. 2;
-- Spacing required for comments, valid only if Style_Check_Comments true.
Style_Check_DOS_Line_Terminator : Boolean := False;
-- This can be set true by using the -gnatyd switch. If it is True, then
-- the line terminator must be a single LF, without an associated CR (e.g.
-- DOS line terminator sequence CR/LF not allowed).
Style_Check_End_Labels : Boolean := False;
-- This can be set True by using the -gnatye switch. If it is True, then
-- optional END labels must always be present.
Style_Check_Form_Feeds : Boolean := False;
-- This can be set True by using the -gnatyf switch. If it is True, then
-- form feeds and vertical tabs are not allowed in the source text.
Style_Check_Horizontal_Tabs : Boolean := False;
-- This can be set True by using the -gnatyh switch. If it is True, then
-- horizontal tabs are not allowed in source text.
Style_Check_If_Then_Layout : Boolean := False;
-- This can be set True by using the -gnatyi switch. If it is True, then a
-- THEN keyword must either appear on the same line as the IF, or on a line
-- all on its own.
--
-- This permits one of two styles for IF-THEN layout. Either the IF and
-- THEN keywords are on the same line, where the condition is short enough,
-- or the conditions are continued over to the lines following the IF and
-- the THEN stands on its own. For example:
--
-- if X > Y then
--
-- if X > Y
-- and then Y < Z
-- then
--
-- if X > Y and then Z > 0
-- then
--
-- are allowed, but
--
-- if X > Y
-- and then B > C then
--
-- is not allowed.
Style_Check_Indentation : Column_Number range 0 .. 9 := 0;
-- This can be set non-zero by using the -gnaty? (? a digit) switch. If
-- it is non-zero it activates indentation checking with the indicated
-- indentation value. A value of zero turns off checking. The requirement
-- is that any new statement, line comment, declaration or keyword such
-- as END, start on a column that is a multiple of the indentation value.
Style_Check_Keyword_Casing : Boolean := False;
-- This can be set True by using the -gnatyk switch. If it is True, then
-- keywords are required to be in all lower case. This rule does not apply
-- to keywords such as digits appearing as an attribute name.
Style_Check_Layout : Boolean := False;
-- This can be set True by using the -gnatyl switch. If it is True, it
-- activates checks that constructs are indented as suggested by the
-- examples in the RM syntax, e.g. that the ELSE keyword must line up
-- with the IF keyword.
Style_Check_Max_Line_Length : Boolean := False;
-- This can be set True by using the -gnatym/M switches. 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_Missing_Overriding : Boolean := False;
-- This can be set True by using the -gnatyO switch. If it is True, then
-- "overriding" is required in subprogram declarations and bodies where
-- appropriate. Note that "not overriding" is never required.
Style_Check_Mode_In : Boolean := False;
-- This can be set True by using -gnatyI. If True, it activates checking
-- that mode IN is not used on its own (since it is the default).
Style_Check_Order_Subprograms : Boolean := False;
-- This can be set True by using the -gnatyo switch. If it is True, then
-- names of subprogram bodies must be in alphabetical order (not taking
-- casing into account).
Style_Check_Pragma_Casing : Boolean := False;
-- This can be set True by using the -gnatyp switch. If it is True, then
-- pragma names must use mixed case.
Style_Check_References : Boolean := False;
-- This can be set True by using the -gnatyr switch. If it is True, then
-- all references to declared identifiers are checked. The requirement
-- is that casing of the reference be the same as the casing of the
-- corresponding declaration.
Style_Check_Separate_Stmt_Lines : Boolean := False;
-- This can be set True by using the -gnatyS switch. If it is TRUE,
-- then for the case of keywords THEN (not preceded by AND) or ELSE (not
-- preceded by OR) which introduce a conditionally executed statement
-- sequence, there must be no tokens on the same line as the keyword, so
-- that coverage testing can clearly identify execution of the statement
-- sequence. A comment is permitted, as is THEN ABORT or a PRAGMA keyword
-- after ELSE (a common style to specify the condition for the ELSE).
Style_Check_Specs : Boolean := False;
-- This can be set True by using the -gnatys switches. If it is True, then
-- separate specs are required to be present for all procedures except
-- parameterless library level procedures. The exception means that typical
-- main programs do not require separate specs.
Style_Check_Standard : Boolean := False;
-- This can be set True by using the -gnatyn switch. If it is True, then
-- any references to names in Standard have to be cased in a manner that
-- is consistent with the Ada RM (usually Mixed case, as in Long_Integer)
-- but there are some exceptions (e.g. NUL, ASCII).
Style_Check_Tokens : Boolean := False;
-- This can be set True by using the -gnatyt switch. If it is True, then
-- the style check that requires canonical spacing between various
-- punctuation tokens as follows:
--
-- ABS and NOT must be followed by a space
--
-- => must be surrounded by spaces
--
-- <> must be preceded by a space or left paren
--
-- Binary operators other than ** must be surrounded by spaces.
--
-- There is no restriction on the layout of the ** binary operator.
--
-- Colon must be surrounded by spaces
--
-- Colon-equal (assignment) must be surrounded by spaces
--
-- Comma must be the first non-blank character on the line, or be
-- immediately preceded by a non-blank character, and must be followed
-- by a blank.
--
-- A space must precede a left paren following a digit or letter, and a
-- right paren must not be followed by a space (it can be at the end of
-- the line).
--
-- A right paren must either be the first non-blank character on a line,
-- or it must be preceded by a non-blank character.
--
-- A semicolon must not be preceded by a blank, and must not be followed
-- by a non-blank character.
--
-- A unary plus or minus may not be followed by a space
--
-- There must be one blank (and no other white space) between NOT and IN
--
-- A vertical bar must be surrounded by spaces
--
-- Note that a requirement that a token be preceded by a space is met by
-- placing the token at the start of the line, and similarly a requirement
-- that a token be followed by a space is met by placing the token at
-- the end of the line. Note that in the case where horizontal tabs are
-- permitted, a horizontal tab is acceptable for meeting the requirement
-- for a space.
Style_Check_Xtra_Parens : Boolean := False;
-- This can be set True by using the -gnatyx switch. If true, then it is
-- not allowed to enclose entire expressions in tests in parentheses
-- (C style), e.g. if (x = y) then ... is not allowed.
Style_Max_Line_Length : Int := 0;
-- Value used to check maximum line length. Gets reset as a result of
-- use of -gnatym or -gnatyMnnn switches. 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 --
-----------------
function RM_Column_Check return Boolean;
-- Determines whether style checking is active and the RM column check
-- mode is set requiring checking of RM format layout.
procedure Set_Default_Style_Check_Options;
-- This procedure is called to set the default style checking options in
-- response to a -gnaty switch with no suboptions or from -gnatyy.
procedure Set_GNAT_Style_Check_Options;
-- This procedure is called to set the default style checking options for
-- GNAT units (as set by -gnatg or -gnatyg).
Style_Msg_Buf : String (1 .. 80);
Style_Msg_Len : Natural;
-- Used to return
procedure Set_Style_Check_Options
(Options : String;
OK : out Boolean;
Err_Col : out Natural);
-- This procedure is called to set the style check options that correspond
-- to the characters in the given Options string. If all options are valid,
-- they are set in an additive manner: any previous options are retained
-- unless overridden, unless a minus is encountered, and then subsequent
-- style switches are subtracted from the current set.
--
-- If all options given are valid, then OK is True, Err_Col is set to
-- Options'Last + 1, and Style_Msg_Buf/Style_Msg_Len are unchanged.
--
-- If an invalid character is found, then OK is False on exit, and Err_Col
-- is the index in options of the bad character. In this case Style_Msg_Len
-- is set and Style_Msg_Buf (1 .. Style_Msg_Len) has a detailed message
-- describing the error.
procedure Set_Style_Check_Options (Options : String);
-- Like the above procedure, but used when the Options string is known to
-- be valid. This is for example appropriate for calls where the string was
-- obtained by Save_Style_Check_Options.
procedure Reset_Style_Check_Options;
-- Sets all style check options to off
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);
-- Sets Options to represent current selection of options. This set can be
-- restored by first calling Reset_Style_Check_Options, and then calling
-- Set_Style_Check_Options with the Options string.
end Stylesw;
gprbuild-gpl-2014-src/gnat/lib-list.adb 0000644 0000767 0000145 00000011455 12323721731 017261 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- L I B . L I S T --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, 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 3, 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. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- appearing in
-- a name is replaced by .... This
-- is used in the fixed bugs run to minimize system and version
-- dependency in filed -gnatD or -gnatG output.
-- dJ Generate debugging trace output for the JGNAT back end. This
-- consists of symbolic Java Byte Code sequences for all generated
-- classes plus additional information to indicate local variables
-- and methods.
-- dK Kill all error messages. This debug flag suppresses the output
-- of all error messages. It is used in regression tests where the
-- error messages are target dependent and irrelevant.
-- dL Output trace information on elaboration checking. This debug
-- switch causes output to be generated showing each call or
-- instantiation as it is checked, and the progress of the recursive
-- trace through calls at elaboration time.
-- dM Assume all variables have been modified, and ignore current value
-- indications. This debug flag disconnects the tracking of constant
-- values (see Exp_Ch2.Expand_Current_Value).
-- dN Do not generate file name information in exception messages
-- dO Output immediate error messages. This causes error messages to
-- be output as soon as they are generated (disconnecting several
-- circuits for improvement of messages, deletion of duplicate
-- messages etc). Useful to diagnose compiler bombs caused by
-- erroneous handling of error situations
-- dP Do not check for controlled objects in preelaborable packages.
-- RM 10.2.1(9) forbids the use of library level controlled objects
-- in preelaborable packages, but this restriction is a huge pain,
-- especially in the predefined library units.
-- dQ Enable inlining in GNATprove mode. Although expansion is not set in
-- GNATprove mode, inlining is useful for improving the precision of
-- formal verification. Under a debug flag until fully reliable.
-- dR Bypass the check for a proper version of s-rpc being present
-- to use the -gnatz? switch. This allows debugging of the use
-- of stubs generation without needing to have GLADE (or some
-- other PCS installed).
-- dS Omit conversion of fpt numbers to exact machine numbers in
-- non-static evaluation contexts (see Check_Non_Static_Context).
-- This is intended for testing out timing problems with this
-- conversion circuit.
-- dT Similar to dS, but omits the conversions only in the case where
-- the parent is not a constant declaration.
-- dU Enable garbage collection of unreachable entities. This enables
-- both the reachability analysis and changing the Is_Public and
-- Is_Eliminated flags.
-- dV Enable viewing of all symbols in debugger. Causes debug information
-- to be generated for all symbols, including internal symbols. This
-- is enabled by default for -gnatD, but this switch allows this to
-- be enabled without generating modified source files. Note that the
-- use of -gnatdV ensures in the dwarf/elf case that all symbols that
-- are present in the elf tables are also in the dwarf tables (which
-- seems to be required by some tools). Another effect of dV is to
-- generate full qualified names, including internal names generated
-- for blocks and loops.
-- dW Disable warnings when a possibly uninitialized scalar value is
-- passed to an IN OUT parameter of a procedure. This usage is a
-- quite improper bounded error [erroneous in Ada 83] situation,
-- and would normally generate a warning. However, to ease the
-- task of transitioning incorrect legacy code, we provide this
-- undocumented feature for suppressing these warnings.
-- dY Enable configurable run-time mode, just as though the System file
-- had Configurable_Run_Time_Mode set to True. This is useful in
-- testing high integrity mode.
-- dZ Generate listing showing the contents of the dispatch tables. Each
-- line has an internally generated number used for references between
-- tagged types and primitives. For each primitive the output has the
-- following fields:
--
-- - Letter 'P' or letter 's': The former indicates that this
-- primitive will be located in a primary dispatch table. The
-- latter indicates that it will be located in a secondary
-- dispatch table.
--
-- - Name of the primitive. In case of predefined Ada primitives
-- the text "(predefined)" is added before the name, and these
-- acronyms are used: SR (Stream_Read), SW (Stream_Write), SI
-- (Stream_Input), SO (Stream_Output), DA (Deep_Adjust), DF
-- (Deep_Finalize). In addition Oeq identifies the equality
-- operator, and "_assign" the assignment.
--
-- - If the primitive covers interface types, two extra fields
-- referencing other primitives are generated: "Alias" references
-- the primitive of the tagged type that covers an interface
-- primitive, and "AI_Alias" references the covered interface
-- primitive.
--
-- - The expression "at #xx" indicates the slot of the dispatch
-- table occupied by such primitive in its corresponding primary
-- or secondary dispatch table.
--
-- - In case of abstract subprograms the text "is abstract" is
-- added at the end of the line.
-- d.a Force Target_Strict_Alignment to True, even on targets where it
-- would normally be false. Can be used for testing strict alignment
-- circuitry in the compiler.
-- d.b Dump back end types. During Create_Standard, the back end is
-- queried for all available types. This option shows them.
-- d.c Generate inline concatenation, instead of calling one of the
-- System.Concat_n.Str_Concat_n routines in cases where the latter
-- routines would normally be called.
-- d.d Disable atomic synchronization for all atomic variable references.
-- Pragma Enable_Atomic_Synchronization is ignored.
-- d.e Enable atomic synchronization for all atomic variable references.
-- Pragma Disable_Atomic_Synchronization is ignored, and also the
-- compiler switch -gnated is ignored.
-- d.f Suppress folding of static expressions. This of course results
-- in seriously non-conforming behavior, but is useful sometimes
-- when tracking down handling of complex expressions.
-- d.g Enables conversion of a raise statement into a goto when the
-- relevant handler is statically determinable. For now we only try
-- this if this debug flag is set. Later we will enable this more
-- generally by default.
-- d.i Ignore all occurrences of pragma Warnings in the sources. This can
-- be used in particular to disable Warnings (Off) to check if any of
-- these statements are inappropriate.
-- d.j Generate listing of frontend inlined calls and inline calls passed
-- to the backend. This is useful to locate skipped calls that must be
-- inlined by the frontend.
-- d.k Enable new semantics of frontend inlining. This is useful to test
-- this new feature in all the platforms. What *is* this new semantics
-- which doesn't seem to be documented anywhere???
-- d.l Use Ada 95 semantics for limited function returns. This may be
-- used to work around the incompatibility introduced by AI-318-2.
-- It is useful only in -gnat05 mode.
-- d.m When -gnatl is used, the normal output includes full listings of
-- all files in the extended main source (body/spec/subunits). If this
-- debug switch is used, then the full listing is given only for the
-- main source (this corresponds to a previous behavior of -gnatl and
-- is used for running the ACATS tests).
-- d.n Print source file names as they are loaded. This is useful if the
-- compiler has a bug -- these are the files that need to be included
-- in a bug report.
-- d.o Generate listing showing the IL instructions generated by the .NET
-- compiler for each subprogram.
-- d.p Enable the .NET CIL verifier. During development the verifier is
-- disabled by default and this flag is used to enable it. In the
-- future we will reverse this functionality.
-- d.r Forces the flag OK_To_Reorder_Components to be set in all record
-- base types that have no discriminants.
-- d.s Normally the compiler expands slice moves into loops if overlap
-- might be possible. This debug flag inhibits that expansion, and
-- the back end is expected to use an appropriate routine to handle
-- overlap, based on Forward_OK and Backwards_OK flags.
-- d.t The compiler has been modified (a fairly extensive modification)
-- to generate static dispatch tables for library level tagged types.
-- This debug switch disables this modification and reverts to the
-- previous dynamic construction of tables. It is there as a possible
-- work around if we run into trouble with the new implementation.
-- d.u Sets Modify_Tree_For_C mode in which tree is modified to make it
-- easier to generate code using a C compiler.
-- d.v Forces the flag OK_To_Reorder_Components to be set in all record
-- base types that have at least one discriminant (v = variant).
-- d.w This flag turns off the scanning of loops to detect possible
-- infinite loops.
-- d.x No exception handlers in generated code. This causes exception
-- handlers to be eliminated from the generated code. They are still
-- fully compiled and analyzed, they just get eliminated from the
-- code generation step.
-- d.A There seems to be a problem with ASIS if we activate the circuit
-- for reading and writing the aspect specification hash table, so
-- for now, this is controlled by the debug flag d.A. The hash table
-- is only written and read if this flag is set.
-- d.C Generate call to System.Concat_n.Str_Concat_n routines in cases
-- where we would normally generate inline concatenation code.
-- d.E Turn selected errors into warnings. This debug switch causes a
-- specific set of error messages into warnings. Setting this switch
-- causes Opt.Error_To_Warning to be set to True. The intention is
-- that this be used for messages representing upwards incompatible
-- changes to Ada 2012 that cause previously correct programs to be
-- treated as illegal now. The following cases are affected:
--
-- Errors relating to overlapping subprogram parameters for cases
-- other than IN OUT parameters to functions.
--
-- Errors relating to the new rules about not defining equality
-- too late so that composition of equality can be assured.
--
-- Errors relating to overriding indicators on protected subprogram
-- bodies (not an Ada 2012 incompatibility, but might cause errors
-- for existing programs assuming they were legal because GNAT
-- formerly allowed them).
-- d.F Sets GNATprove_Mode to True. This allows debugging the frontend in
-- the special mode used by GNATprove.
-- d.G Previously the compiler ignored calls via generic formal parameters
-- when doing the analysis for the static elaboration model. This is
-- now fixed, but we provide this debug flag to revert to the previous
-- situation of ignoring such calls to aid in transition.
-- d.I Do not ignore enum representation clauses in CodePeer mode.
-- The default of ignoring representation clauses for enumeration
-- types in CodePeer is good for the majority of Ada code, but in some
-- cases being able to change this default might be useful to remove
-- some false positives.
-- d.J Disable parallel SCIL generation. Normally SCIL file generation is
-- done in parallel to speed processing. This switch disables this
-- behavior.
-- d.L Normally the front end generates special expansion for conditional
-- expressions of a limited type. This debug flag removes this special
-- case expansion, leaving it up to the back end to handle conditional
-- expressions correctly.
-- d.M Relaxed RM semantics. This flag sets Opt.Relaxed_RM_Semantics
-- See Opt.Relaxed_RM_Semantics for more details.
-- d.N Enlarge entities by one node (but don't attempt to use this extra
-- node for storage of any flags or fields). This can be used to do
-- experiments on the impact of increasing entity sizes.
-- d.O Dump internal SCO tables. Before outputting the SCO information to
-- the ALI file, the internal SCO tables (SCO_Table/SCO_Unit_Table)
-- are dumped for debugging purposes.
-- d.P Previous non-optimized handling of length comparisons. Setting this
-- flag inhibits the effect of Optimize_Length_Comparison in Exp_Ch4.
-- This is there in case we find a situation where the optimization
-- malfunctions, to provide a work around.
-- d.Q Previous incomplete style checks for binary operators. Style checks
-- for token separation rules were incomplete and have been made
-- compliant with the documentation. For example, no warning was
-- issued for expressions such as 16-One or "A"&"B". Setting this flag
-- inhibits these new checks.
-- d.R As documented in lib-writ.ads, restrictions in the ali file can
-- have two forms, positional and named. The named notation is the
-- current preferred form, but the use of this debug switch will force
-- the use of the obsolescent positional form.
-- d.S Force Optimize_Alignment (Space) mode as the default
-- d.T Force Optimize_Alignment (Time) mode as the default
-- d.U Ignore indirect calls for static elaboration. The static
-- elaboration model is conservative, especially regarding indirect
-- calls. If you say Proc'Access, it will assume you might call
-- Proc. This can cause elaboration cycles at bind time. This flag
-- reverts to the behavior of earlier compilers, which ignored
-- indirect calls.
-- d.V Causes routines in Cprint to be called instead of corresponding
-- routines in Sprint. Used during development of Cprint.
-- d.W Print out debugging information for Walk_Library_Items, including
-- the order in which units are walked. This is primarily for use in
-- debugging CodePeer mode.
-- d1 Error messages have node numbers where possible. Normally error
-- messages have only source locations. This option is useful when
-- debugging errors caused by expanded code, where the source location
-- does not give enough information.
-- d2 Suppress output of the error position flags for verbose form error
-- messages. The messages are still interspersed in the listing, but
-- without any error flags or extra blank lines. Also causes an extra
-- <<< to be output at the right margin. This is intended to be the
-- easiest format for checking conformance of ACATS B tests. This
-- flag also suppresses the additional messages explaining why a
-- non-static expression is non-static (see Sem_Eval.Why_Not_Static).
-- This avoids having to worry about these messages in ACATS testing.
-- d3 Causes Comperr to dump the contents of the node for which an abort
-- was detected (normally only the Node_Id of the node is output).
-- d4 Inhibits automatic krunching of predefined library unit file names.
-- Normally, as described in the spec of package Krunch, such files
-- are automatically krunched to 8 characters, with special treatment
-- of the prefixes Ada, System, and Interfaces. Setting this debug
-- switch disables this special treatment.
-- d5 Causes the tree read/write circuit to output detailed information
-- tracking the data that is read and written element by element.
-- d6 Normally access-to-unconstrained-array types are represented
-- using fat (double) pointers. Using this debug flag causes them
-- to default to thin. This can be used to test the performance
-- implications of using thin pointers, and also to test that the
-- compiler functions correctly with this choice.
-- d7 Normally a -gnatl or -gnatv listing includes the time stamp
-- of the source file. This debug flag suppresses this output,
-- and also suppresses the message with the version number.
-- This is useful in certain regression tests.
-- d8 This forces the packed stuff to generate code assuming the
-- opposite endianness from the actual correct value. Useful in
-- testing out code generation from the packed routines.
-- d9 This allows lock free implementation for protected objects
-- (see Exp_Ch9).
------------------------------------------
-- Documentation for Binder Debug Flags --
------------------------------------------
-- da Normally if there is an elaboration circularity, then in describing
-- the cycle, links involving internal units are omitted, since they
-- are irrelevant and confusing. This debug flag causes all links to
-- be listed, and is useful when diagnosing circularities introduced
-- by incorrect changes to the run-time library itself.
-- db Output debug information from Better_Choice in Binde, which uses
-- various heuristics to determine elaboration order in cases where
-- multiple orders are valid.
-- dc List units as they are chosen. As units are selected for addition to
-- the elaboration order, a line of output is generated showing which
-- unit has been selected.
-- de Similar to the effect of -e (output complete list of elaboration
-- dependencies) except that internal units are included in the
-- listing.
-- di Normally gnatbind calls Read_Ali with Ignore_Errors set to
-- False, since the binder really needs correct version ALI
-- files to do its job. This debug flag causes Ignore_Errors
-- mode to be set for the binder (and is particularly useful
-- for testing ignore errors mode).
-- dn List details of manipulation of Num_Pred values during execution of
-- the algorithm used to determine a correct order of elaboration. This
-- is useful in diagnosing any problems in its behavior.
-- do Use old elaboration order preference. The new preference rules
-- prefer specs with no bodies to specs with bodies, and between two
-- specs with bodies, prefers the one whose body is closer to being
-- able to be elaborated. This is a clear improvement, but we provide
-- this debug flag in case of regressions.
-- du List unit name and file name for each unit as it is read in
-- dx Force the binder to read (and then ignore) the xref information
-- in ali files (used to check that read circuit is working OK).
--------------------------------------------
-- Documentation for gnatmake Debug Flags --
--------------------------------------------
-- df Only output file names, not path names, in log
-- dh Generate listing showing loading of name table hash chains,
-- same as for the compiler.
-- dm Issue a message indicating the maximum number of simultaneous
-- compilations.
-- dn Do not delete temporary files created by gnatmake at the end
-- of execution, such as temporary config pragma files, mapping
-- files or project path files.
-- dp Prints the Q used by routine Make.Compile_Sources every time
-- we go around the main compile loop of Make.Compile_Sources
-- dq Prints source files as they are enqueued and dequeued in the Q
-- used by routine Make.Compile_Sources. Useful to figure out the
-- order in which sources are recompiled.
-- dt When a time stamp mismatch has been found for an ALI file,
-- display the source file name, the time stamp expected and
-- the time stamp found.
-- du List unit name and file name for each unit as it is read in
-- dw Prints the list of units withed by the unit currently explored
-- during the main loop of Make.Compile_Sources.
---------------------------------------------
-- Documentation for gprbuild Debug Flags --
---------------------------------------------
-- dn Do not delete temporary files createed by gprbuild at the end
-- of execution, such as temporary config pragma files, mapping
-- files or project path files.
-- dt When a time stamp mismatch has been found for an ALI file,
-- display the source file name, the time stamp expected and
-- the time stamp found.
--------------------
-- Set_Debug_Flag --
--------------------
procedure Set_Debug_Flag (C : Character; Val : Boolean := True) is
subtype Dig is Character range '1' .. '9';
subtype LLet is Character range 'a' .. 'z';
subtype ULet is Character range 'A' .. 'Z';
begin
if C in Dig then
case Dig (C) is
when '1' =>
Debug_Flag_1 := Val;
when '2' =>
Debug_Flag_2 := Val;
when '3' =>
Debug_Flag_3 := Val;
when '4' =>
Debug_Flag_4 := Val;
when '5' =>
Debug_Flag_5 := Val;
when '6' =>
Debug_Flag_6 := Val;
when '7' =>
Debug_Flag_7 := Val;
when '8' =>
Debug_Flag_8 := Val;
when '9' =>
Debug_Flag_9 := Val;
end case;
elsif C in ULet then
case ULet (C) is
when 'A' =>
Debug_Flag_AA := Val;
when 'B' =>
Debug_Flag_BB := Val;
when 'C' =>
Debug_Flag_CC := Val;
when 'D' =>
Debug_Flag_DD := Val;
when 'E' =>
Debug_Flag_EE := Val;
when 'F' =>
Debug_Flag_FF := Val;
when 'G' =>
Debug_Flag_GG := Val;
when 'H' =>
Debug_Flag_HH := Val;
when 'I' =>
Debug_Flag_II := Val;
when 'J' =>
Debug_Flag_JJ := Val;
when 'K' =>
Debug_Flag_KK := Val;
when 'L' =>
Debug_Flag_LL := Val;
when 'M' =>
Debug_Flag_MM := Val;
when 'N' =>
Debug_Flag_NN := Val;
when 'O' =>
Debug_Flag_OO := Val;
when 'P' =>
Debug_Flag_PP := Val;
when 'Q' =>
Debug_Flag_QQ := Val;
when 'R' =>
Debug_Flag_RR := Val;
when 'S' =>
Debug_Flag_SS := Val;
when 'T' =>
Debug_Flag_TT := Val;
when 'U' =>
Debug_Flag_UU := Val;
when 'V' =>
Debug_Flag_VV := Val;
when 'W' =>
Debug_Flag_WW := Val;
when 'X' =>
Debug_Flag_XX := Val;
when 'Y' =>
Debug_Flag_YY := Val;
when 'Z' =>
Debug_Flag_ZZ := Val;
end case;
else
case LLet (C) is
when 'a' =>
Debug_Flag_A := Val;
when 'b' =>
Debug_Flag_B := Val;
when 'c' =>
Debug_Flag_C := Val;
when 'd' =>
Debug_Flag_D := Val;
when 'e' =>
Debug_Flag_E := Val;
when 'f' =>
Debug_Flag_F := Val;
when 'g' =>
Debug_Flag_G := Val;
when 'h' =>
Debug_Flag_H := Val;
when 'i' =>
Debug_Flag_I := Val;
when 'j' =>
Debug_Flag_J := Val;
when 'k' =>
Debug_Flag_K := Val;
when 'l' =>
Debug_Flag_L := Val;
when 'm' =>
Debug_Flag_M := Val;
when 'n' =>
Debug_Flag_N := Val;
when 'o' =>
Debug_Flag_O := Val;
when 'p' =>
Debug_Flag_P := Val;
when 'q' =>
Debug_Flag_Q := Val;
when 'r' =>
Debug_Flag_R := Val;
when 's' =>
Debug_Flag_S := Val;
when 't' =>
Debug_Flag_T := Val;
when 'u' =>
Debug_Flag_U := Val;
when 'v' =>
Debug_Flag_V := Val;
when 'w' =>
Debug_Flag_W := Val;
when 'x' =>
Debug_Flag_X := Val;
when 'y' =>
Debug_Flag_Y := Val;
when 'z' =>
Debug_Flag_Z := Val;
end case;
end if;
end Set_Debug_Flag;
---------------------------
-- Set_Dotted_Debug_Flag --
---------------------------
procedure Set_Dotted_Debug_Flag (C : Character; Val : Boolean := True) is
subtype Dig is Character range '1' .. '9';
subtype LLet is Character range 'a' .. 'z';
subtype ULet is Character range 'A' .. 'Z';
begin
if C in Dig then
case Dig (C) is
when '1' =>
Debug_Flag_Dot_1 := Val;
when '2' =>
Debug_Flag_Dot_2 := Val;
when '3' =>
Debug_Flag_Dot_3 := Val;
when '4' =>
Debug_Flag_Dot_4 := Val;
when '5' =>
Debug_Flag_Dot_5 := Val;
when '6' =>
Debug_Flag_Dot_6 := Val;
when '7' =>
Debug_Flag_Dot_7 := Val;
when '8' =>
Debug_Flag_Dot_8 := Val;
when '9' =>
Debug_Flag_Dot_9 := Val;
end case;
elsif C in ULet then
case ULet (C) is
when 'A' =>
Debug_Flag_Dot_AA := Val;
when 'B' =>
Debug_Flag_Dot_BB := Val;
when 'C' =>
Debug_Flag_Dot_CC := Val;
when 'D' =>
Debug_Flag_Dot_DD := Val;
when 'E' =>
Debug_Flag_Dot_EE := Val;
when 'F' =>
Debug_Flag_Dot_FF := Val;
when 'G' =>
Debug_Flag_Dot_GG := Val;
when 'H' =>
Debug_Flag_Dot_HH := Val;
when 'I' =>
Debug_Flag_Dot_II := Val;
when 'J' =>
Debug_Flag_Dot_JJ := Val;
when 'K' =>
Debug_Flag_Dot_KK := Val;
when 'L' =>
Debug_Flag_Dot_LL := Val;
when 'M' =>
Debug_Flag_Dot_MM := Val;
when 'N' =>
Debug_Flag_Dot_NN := Val;
when 'O' =>
Debug_Flag_Dot_OO := Val;
when 'P' =>
Debug_Flag_Dot_PP := Val;
when 'Q' =>
Debug_Flag_Dot_QQ := Val;
when 'R' =>
Debug_Flag_Dot_RR := Val;
when 'S' =>
Debug_Flag_Dot_SS := Val;
when 'T' =>
Debug_Flag_Dot_TT := Val;
when 'U' =>
Debug_Flag_Dot_UU := Val;
when 'V' =>
Debug_Flag_Dot_VV := Val;
when 'W' =>
Debug_Flag_Dot_WW := Val;
when 'X' =>
Debug_Flag_Dot_XX := Val;
when 'Y' =>
Debug_Flag_Dot_YY := Val;
when 'Z' =>
Debug_Flag_Dot_ZZ := Val;
end case;
else
case LLet (C) is
when 'a' =>
Debug_Flag_Dot_A := Val;
when 'b' =>
Debug_Flag_Dot_B := Val;
when 'c' =>
Debug_Flag_Dot_C := Val;
when 'd' =>
Debug_Flag_Dot_D := Val;
when 'e' =>
Debug_Flag_Dot_E := Val;
when 'f' =>
Debug_Flag_Dot_F := Val;
when 'g' =>
Debug_Flag_Dot_G := Val;
when 'h' =>
Debug_Flag_Dot_H := Val;
when 'i' =>
Debug_Flag_Dot_I := Val;
when 'j' =>
Debug_Flag_Dot_J := Val;
when 'k' =>
Debug_Flag_Dot_K := Val;
when 'l' =>
Debug_Flag_Dot_L := Val;
when 'm' =>
Debug_Flag_Dot_M := Val;
when 'n' =>
Debug_Flag_Dot_N := Val;
when 'o' =>
Debug_Flag_Dot_O := Val;
when 'p' =>
Debug_Flag_Dot_P := Val;
when 'q' =>
Debug_Flag_Dot_Q := Val;
when 'r' =>
Debug_Flag_Dot_R := Val;
when 's' =>
Debug_Flag_Dot_S := Val;
when 't' =>
Debug_Flag_Dot_T := Val;
when 'u' =>
Debug_Flag_Dot_U := Val;
when 'v' =>
Debug_Flag_Dot_V := Val;
when 'w' =>
Debug_Flag_Dot_W := Val;
when 'x' =>
Debug_Flag_Dot_X := Val;
when 'y' =>
Debug_Flag_Dot_Y := Val;
when 'z' =>
Debug_Flag_Dot_Z := Val;
end case;
end if;
end Set_Dotted_Debug_Flag;
end Debug;
gprbuild-gpl-2014-src/gnat/stand.ads 0000644 0000767 0000145 00000047322 12323721731 016676 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S T A N D --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, 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 3, 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. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- ");
else
Write_Line (" """ & Get_Name_String (Str2) & '"');
end if;
Set_Standard_Output;
end if;
end Debug_Output;
---------------------------
-- Debug_Increase_Indent --
---------------------------
procedure Debug_Increase_Indent
(Str : String := ""; Str2 : Name_Id := No_Name)
is
begin
if Str2 /= No_Name then
Debug_Output (Str, Str2);
else
Debug_Output (Str);
end if;
Debug_Level := Debug_Level + 1;
end Debug_Increase_Indent;
---------------------------
-- Debug_Decrease_Indent --
---------------------------
procedure Debug_Decrease_Indent (Str : String := "") is
begin
if Debug_Level > 0 then
Debug_Level := Debug_Level - 1;
end if;
if Str /= "" then
Debug_Output (Str);
end if;
end Debug_Decrease_Indent;
----------------
-- Debug_Name --
----------------
function Debug_Name (Tree : Project_Tree_Ref) return Name_Id is
P : Project_List;
begin
Name_Len := 0;
Add_Str_To_Name_Buffer ("Tree [");
P := Tree.Projects;
while P /= null loop
if P /= Tree.Projects then
Add_Char_To_Name_Buffer (',');
end if;
Add_Str_To_Name_Buffer (Get_Name_String (P.Project.Name));
P := P.Next;
end loop;
Add_Char_To_Name_Buffer (']');
return Name_Find;
end Debug_Name;
----------
-- Free --
----------
procedure Free (Tree : in out Project_Tree_Appdata) is
pragma Unreferenced (Tree);
begin
null;
end Free;
--------------------------------
-- For_Project_And_Aggregated --
--------------------------------
procedure For_Project_And_Aggregated
(Root_Project : Project_Id;
Root_Tree : Project_Tree_Ref)
is
Agg : Aggregated_Project_List;
begin
Action (Root_Project, Root_Tree);
if Root_Project.Qualifier in Aggregate_Project then
Agg := Root_Project.Aggregated_Projects;
while Agg /= null loop
For_Project_And_Aggregated (Agg.Project, Agg.Tree);
Agg := Agg.Next;
end loop;
end if;
end For_Project_And_Aggregated;
----------------------------------------
-- For_Project_And_Aggregated_Context --
----------------------------------------
procedure For_Project_And_Aggregated_Context
(Root_Project : Project_Id;
Root_Tree : Project_Tree_Ref)
is
procedure Recursive_Process
(Project : Project_Id;
Tree : Project_Tree_Ref;
Context : Project_Context);
-- Process Project and all aggregated projects recursively
-----------------------
-- Recursive_Process --
-----------------------
procedure Recursive_Process
(Project : Project_Id;
Tree : Project_Tree_Ref;
Context : Project_Context)
is
Agg : Aggregated_Project_List;
Ctx : Project_Context;
begin
Action (Project, Tree, Context);
if Project.Qualifier in Aggregate_Project then
Ctx :=
(In_Aggregate_Lib => True,
From_Encapsulated_Lib =>
Context.From_Encapsulated_Lib
or else Project.Standalone_Library = Encapsulated);
Agg := Project.Aggregated_Projects;
while Agg /= null loop
Recursive_Process (Agg.Project, Agg.Tree, Ctx);
Agg := Agg.Next;
end loop;
end if;
end Recursive_Process;
-- Start of processing for For_Project_And_Aggregated_Context
begin
Recursive_Process
(Root_Project, Root_Tree, Project_Context'(False, False));
end For_Project_And_Aggregated_Context;
-- Package initialization for Prj
begin
-- Make sure that the standard config and user project file extensions are
-- compatible with canonical case file naming.
Canonical_Case_File_Name (Config_Project_File_Extension);
Canonical_Case_File_Name (Project_File_Extension);
end Prj;
gprbuild-gpl-2014-src/gnat/Make-generated.in 0000644 0000767 0000145 00000020057 12253553403 020232 0 ustar gnatmail gnat # Dependencies for compiler sources that are generated at build time
# Note: can't use ?= here, not supported by older versions of GNU Make
ifeq ($(origin ADA_GEN_SUBDIR), undefined)
ADA_GEN_SUBDIR=ada
endif
ifeq ($(origin CP), undefined)
CP=cp
endif
ifeq ($(origin MKDIR), undefined)
MKDIR=mkdir -p
endif
ifeq ($(origin MOVE_IF_CHANGE), undefined)
MOVE_IF_CHANGE=mv -f
endif
.PHONY: ada_extra_files
ada_extra_files : $(ADA_GEN_SUBDIR)/treeprs.ads $(ADA_GEN_SUBDIR)/einfo.h $(ADA_GEN_SUBDIR)/sinfo.h $(ADA_GEN_SUBDIR)/nmake.adb \
$(ADA_GEN_SUBDIR)/nmake.ads $(ADA_GEN_SUBDIR)/snames.ads $(ADA_GEN_SUBDIR)/snames.adb $(ADA_GEN_SUBDIR)/snames.h
# We delete the files before copying, below, in case they are read-only.
$(ADA_GEN_SUBDIR)/treeprs.ads : $(ADA_GEN_SUBDIR)/treeprs.adt $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/xtreeprs.adb
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/treeprs
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/treeprs/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/treeprs
(cd $(ADA_GEN_SUBDIR)/bldtools/treeprs; gnatmake -q xtreeprs ; ./xtreeprs treeprs.ads )
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/treeprs/treeprs.ads $(ADA_GEN_SUBDIR)/treeprs.ads
$(ADA_GEN_SUBDIR)/einfo.h : $(ADA_GEN_SUBDIR)/einfo.ads $(ADA_GEN_SUBDIR)/einfo.adb $(ADA_GEN_SUBDIR)/xeinfo.adb $(ADA_GEN_SUBDIR)/ceinfo.adb
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/einfo
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/einfo/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/einfo
(cd $(ADA_GEN_SUBDIR)/bldtools/einfo; gnatmake -q xeinfo ; ./xeinfo einfo.h )
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/einfo/einfo.h $(ADA_GEN_SUBDIR)/einfo.h
$(ADA_GEN_SUBDIR)/sinfo.h : $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/sinfo.adb $(ADA_GEN_SUBDIR)/xsinfo.adb $(ADA_GEN_SUBDIR)/csinfo.adb
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/sinfo
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/sinfo/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/sinfo
(cd $(ADA_GEN_SUBDIR)/bldtools/sinfo; gnatmake -q xsinfo ; ./xsinfo sinfo.h )
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/sinfo/sinfo.h $(ADA_GEN_SUBDIR)/sinfo.h
$(ADA_GEN_SUBDIR)/snames.h $(ADA_GEN_SUBDIR)/snames.ads $(ADA_GEN_SUBDIR)/snames.adb : $(ADA_GEN_SUBDIR)/stamp-snames ; @true
$(ADA_GEN_SUBDIR)/stamp-snames : $(ADA_GEN_SUBDIR)/snames.ads-tmpl $(ADA_GEN_SUBDIR)/snames.adb-tmpl $(ADA_GEN_SUBDIR)/snames.h-tmpl $(ADA_GEN_SUBDIR)/xsnamest.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/snamest
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/snamest/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/snamest
(cd $(ADA_GEN_SUBDIR)/bldtools/snamest; gnatmake -q xsnamest ; ./xsnamest )
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.ns $(ADA_GEN_SUBDIR)/snames.ads
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.nb $(ADA_GEN_SUBDIR)/snames.adb
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/snamest/snames.nh $(ADA_GEN_SUBDIR)/snames.h
touch $(ADA_GEN_SUBDIR)/stamp-snames
$(ADA_GEN_SUBDIR)/nmake.adb $(ADA_GEN_SUBDIR)/nmake.ads: $(ADA_GEN_SUBDIR)/stamp-nmake ; @true
$(ADA_GEN_SUBDIR)/stamp-nmake: $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/nmake.adt $(ADA_GEN_SUBDIR)/xnmake.adb $(ADA_GEN_SUBDIR)/xutil.ads $(ADA_GEN_SUBDIR)/xutil.adb
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/nmake
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/nmake/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/nmake
(cd $(ADA_GEN_SUBDIR)/bldtools/nmake; gnatmake -q xnmake ; ./xnmake -b nmake.adb ; ./xnmake -s nmake.ads)
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/nmake/nmake.ads $(ADA_GEN_SUBDIR)/nmake.ads
$(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/nmake/nmake.adb $(ADA_GEN_SUBDIR)/nmake.adb
touch $(ADA_GEN_SUBDIR)/stamp-nmake
# GCC_FOR_TARGET has paths relative to the gcc directory, so we need to adjust
# for running it from $(ADA_GEN_SUBDIR)/bldtools/oscons.
OSCONS_CC=$(subst ./xgcc,../../../xgcc,$(subst -B./, -B../../../,$(GCC_FOR_TARGET)))
# The main ada source directory must be on the include path for #include "..."
# because s-oscons-tmplt.c requires adaint.h, gsocket.h, and any file included
# by these headers. However note that we must use -iquote, not -I, so that
# ada/types.h does not conflict with a same-named system header (VxWorks
# has a header).
OSCONS_SRCDIR=$${_oscons_srcdir}
OSCONS_CPP=$(OSCONS_CC) $(GNATLIBCFLAGS) -E -C \
-DTARGET=\"$(target)\" -iquote $(OSCONS_SRCDIR) s-oscons-tmplt.c > s-oscons-tmplt.i
OSCONS_EXTRACT=$(OSCONS_CC) -iquote $(OSCONS_SRCDIR) -S s-oscons-tmplt.i
# Note: if you need to build with a non-GNU compiler, you could adapt the
# following definitions (written for VMS DEC-C)
#OSCONS_CPP=../../../$(DECC) -E /comment=as_is -DNATIVE \
# -DTARGET='""$(target)""' -I$(OSCONS_SRCDIR) s-oscons-tmplt.c
#
#OSCONS_EXTRACT=../../../$(DECC) -DNATIVE \
# -DTARGET='""$(target)""' -I$(OSCONS_SRCDIR) s-oscons-tmplt.c ; \
# ld -o s-oscons-tmplt.exe s-oscons-tmplt.obj; \
# ./s-oscons-tmplt.exe > s-oscons-tmplt.s
# Note: the first dependency of s-oscons.ads *must* remain s-oscons-tmplt.c, as
# we use $(tmp-sdefault.adb
$(ECHO) "with Osint; use Osint;" >>tmp-sdefault.adb
$(ECHO) "package body Sdefault is" >>tmp-sdefault.adb
$(ECHO) " S0 : constant String := \"$(prefix)/\";" >>tmp-sdefault.adb
$(ECHO) " S1 : constant String := \"$(ADA_INCLUDE_DIR)/\";" >>tmp-sdefault.adb
$(ECHO) " S2 : constant String := \"$(ADA_RTL_OBJ_DIR)/\";" >>tmp-sdefault.adb
$(ECHO) " S3 : constant String := \"$(target_noncanonical)/\";" >>tmp-sdefault.adb
$(ECHO) " S4 : constant String := \"$(libsubdir)/\";" >>tmp-sdefault.adb
$(ECHO) " function Include_Dir_Default_Name return String_Ptr is" >>tmp-sdefault.adb
$(ECHO) " begin" >>tmp-sdefault.adb
$(ECHO) " return Relocate_Path (S0, S1);" >>tmp-sdefault.adb
$(ECHO) " end Include_Dir_Default_Name;" >>tmp-sdefault.adb
$(ECHO) " function Object_Dir_Default_Name return String_Ptr is" >>tmp-sdefault.adb
$(ECHO) " begin" >>tmp-sdefault.adb
$(ECHO) " return Relocate_Path (S0, S2);" >>tmp-sdefault.adb
$(ECHO) " end Object_Dir_Default_Name;" >>tmp-sdefault.adb
$(ECHO) " function Target_Name return String_Ptr is" >>tmp-sdefault.adb
$(ECHO) " begin" >>tmp-sdefault.adb
$(ECHO) " return new String'(S3);" >>tmp-sdefault.adb
$(ECHO) " end Target_Name;" >>tmp-sdefault.adb
$(ECHO) " function Search_Dir_Prefix return String_Ptr is" >>tmp-sdefault.adb
$(ECHO) " begin" >>tmp-sdefault.adb
$(ECHO) " return Relocate_Path (S0, S4);" >>tmp-sdefault.adb
$(ECHO) " end Search_Dir_Prefix;" >>tmp-sdefault.adb
$(ECHO) "end Sdefault;" >> tmp-sdefault.adb
$(MOVE_IF_CHANGE) tmp-sdefault.adb $(ADA_GEN_SUBDIR)/sdefault.adb
touch $(ADA_GEN_SUBDIR)/stamp-sdefault
$(ADA_GEN_SUBDIR)/gnat.hlp : $(ADA_GEN_SUBDIR)/vms_help.adb $(ADA_GEN_SUBDIR)/vms_cmds.ads $(ADA_GEN_SUBDIR)/gnat.help_in $(ADA_GEN_SUBDIR)/vms_data.ads
-$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/gnat_hlp
$(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/gnat_hlp/,$(notdir $^))
$(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/gnat_hlp
(cd $(ADA_GEN_SUBDIR)/bldtools/gnat_hlp; \
gnatmake -q vms_help; \
./vms_help$(build_exeext) gnat.help_in vms_data.ads ../../gnat.hlp)
gprbuild-gpl-2014-src/gnat/prj-attr-pm.adb 0000644 0000767 0000145 00000006431 12323721731 017715 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . A T T R . P M --
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2009, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body Prj.Attr.PM is
-------------------
-- Add_Attribute --
-------------------
procedure Add_Attribute
(To_Package : Package_Node_Id;
Attribute_Name : Name_Id;
Attribute_Node : out Attribute_Node_Id)
is
begin
-- Only add attribute if package is already defined and is not unknown
if To_Package /= Empty_Package and then
To_Package /= Unknown_Package
then
Attrs.Append (
(Name => Attribute_Name,
Var_Kind => Undefined,
Optional_Index => False,
Attr_Kind => Unknown,
Read_Only => False,
Others_Allowed => False,
Next =>
Package_Attributes.Table (To_Package.Value).First_Attribute));
Package_Attributes.Table (To_Package.Value).First_Attribute :=
Attrs.Last;
Attribute_Node := (Value => Attrs.Last);
end if;
end Add_Attribute;
-------------------------
-- Add_Unknown_Package --
-------------------------
procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id) is
begin
Package_Attributes.Increment_Last;
Id := (Value => Package_Attributes.Last);
Package_Attributes.Table (Id.Value) :=
(Name => Name,
Known => False,
First_Attribute => Empty_Attr);
end Add_Unknown_Package;
end Prj.Attr.PM;
gprbuild-gpl-2014-src/gnat/prj-tree.ads 0000644 0000767 0000145 00000160016 12323721731 017311 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . T R E E --
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2013, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package defines the structure of the Project File tree
with GNAT.Dynamic_HTables;
with GNAT.Dynamic_Tables;
with Table;
with Prj.Attr; use Prj.Attr;
with Prj.Env;
with Prj.Ext;
package Prj.Tree is
-----------------
-- Environment --
-----------------
-- The following record contains the context in which projects are parsed
-- and processed (finding importing project, resolving external values,..).
type Environment is record
External : Prj.Ext.External_References;
-- External references are stored in this hash table (and manipulated
-- through subprograms in prj-ext.ads). External references are
-- project-tree specific so that one can load the same tree twice but
-- have two views of it, for instance.
Project_Path : aliased Prj.Env.Project_Search_Path;
-- The project path is tree specific, since we might want to load
-- simultaneously multiple projects, each with its own search path, in
-- particular when using different compilers with different default
-- search directories.
Flags : Prj.Processing_Flags;
-- Configure errors and warnings
end record;
procedure Initialize
(Self : out Environment;
Flags : Processing_Flags);
-- Initialize a new environment
procedure Initialize_And_Copy
(Self : out Environment;
Copy_From : Environment);
-- Initialize a new environment, copying its values from Copy_From
procedure Free (Self : in out Environment);
-- Free the memory used by Self
procedure Override_Flags
(Self : in out Environment; Flags : Prj.Processing_Flags);
-- Override the subprogram called in case there are parsing errors. This
-- is needed in applications that do their own error handling, since the
-- error handler is likely to be a local subprogram in this case (which
-- can't be stored when the flags are created).
-------------------
-- Project nodes --
-------------------
type Project_Node_Tree_Data;
type Project_Node_Tree_Ref is access all Project_Node_Tree_Data;
-- Type to designate a project node tree, so that several project node
-- trees can coexist in memory.
Project_Nodes_Initial : constant := 1_000;
Project_Nodes_Increment : constant := 100;
-- Allocation parameters for initializing and extending number
-- of nodes in table Tree_Private_Part.Project_Nodes
Project_Node_Low_Bound : constant := 0;
Project_Node_High_Bound : constant := 099_999_999;
-- Range of values for project node id's (in practice infinite)
type Project_Node_Id is range
Project_Node_Low_Bound .. Project_Node_High_Bound;
-- The index of table Tree_Private_Part.Project_Nodes
Empty_Node : constant Project_Node_Id := Project_Node_Low_Bound;
-- Designates no node in table Project_Nodes
First_Node_Id : constant Project_Node_Id := Project_Node_Low_Bound + 1;
subtype Variable_Node_Id is Project_Node_Id;
-- Used to designate a node whose expected kind is one of
-- N_Typed_Variable_Declaration, N_Variable_Declaration or
-- N_Variable_Reference.
subtype Package_Declaration_Id is Project_Node_Id;
-- Used to designate a node whose expected kind is N_Project_Declaration
type Project_Node_Kind is
(N_Project,
N_With_Clause,
N_Project_Declaration,
N_Declarative_Item,
N_Package_Declaration,
N_String_Type_Declaration,
N_Literal_String,
N_Attribute_Declaration,
N_Typed_Variable_Declaration,
N_Variable_Declaration,
N_Expression,
N_Term,
N_Literal_String_List,
N_Variable_Reference,
N_External_Value,
N_Attribute_Reference,
N_Case_Construction,
N_Case_Item,
N_Comment_Zones,
N_Comment);
-- Each node in the tree is of a Project_Node_Kind. For the signification
-- of the fields in each node of Project_Node_Kind, look at package
-- Tree_Private_Part.
function Present (Node : Project_Node_Id) return Boolean;
pragma Inline (Present);
-- Return True if Node /= Empty_Node
function No (Node : Project_Node_Id) return Boolean;
pragma Inline (No);
-- Return True if Node = Empty_Node
procedure Initialize (Tree : Project_Node_Tree_Ref);
-- Initialize the Project File tree: empty the Project_Nodes table
-- and reset the Projects_Htable.
function Default_Project_Node
(In_Tree : Project_Node_Tree_Ref;
Of_Kind : Project_Node_Kind;
And_Expr_Kind : Variable_Kind := Undefined) return Project_Node_Id;
-- Returns a Project_Node_Record with the specified Kind and Expr_Kind. All
-- the other components have default nil values.
-- To create a node for a project itself, see Create_Project below instead
function Hash (N : Project_Node_Id) return Header_Num;
-- Used for hash tables where the key is a Project_Node_Id
function Imported_Or_Extended_Project_Of
(Project : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
With_Name : Name_Id) return Project_Node_Id;
-- Return the node of a project imported or extended by project Project and
-- whose name is With_Name. Return Empty_Node if there is no such project.
--------------
-- Comments --
--------------
type Comment_State is private;
-- A type to store the values of several global variables related to
-- comments.
procedure Save (S : out Comment_State);
-- Save in variable S the comment state. Called before scanning a new
-- project file.
procedure Restore_And_Free (S : in out Comment_State);
-- Restore the comment state to a previously saved value. Called after
-- scanning a project file. Frees the memory occupied by S
procedure Reset_State;
-- Set the comment state to its initial value. Called before scanning a
-- new project file.
function There_Are_Unkept_Comments return Boolean;
-- Indicates that some of the comments in a project file could not be
-- stored in the parse tree.
procedure Set_Previous_Line_Node (To : Project_Node_Id);
-- Indicate the node on the previous line. If there are comments
-- immediately following this line, then they should be associated with
-- this node.
procedure Set_Previous_End_Node (To : Project_Node_Id);
-- Indicate that on the previous line the "end" belongs to node To.
-- If there are comments immediately following this "end" line, they
-- should be associated with this node.
procedure Set_End_Of_Line (To : Project_Node_Id);
-- Indicate the node on the current line. If there is an end of line
-- comment, then it should be associated with this node.
procedure Set_Next_End_Node (To : Project_Node_Id);
-- Put node To on the top of the end node stack. When an END line is found
-- with this node on the top of the end node stack, the comments, if any,
-- immediately preceding this "end" line will be associated with this node.
procedure Remove_Next_End_Node;
-- Remove the top of the end node stack
------------------------
-- Comment Processing --
------------------------
type Comment_Data is record
Value : Name_Id := No_Name;
Follows_Empty_Line : Boolean := False;
Is_Followed_By_Empty_Line : Boolean := False;
end record;
-- Component type for Comments Table below
package Comments is new Table.Table
(Table_Component_Type => Comment_Data,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Prj.Tree.Comments");
-- A table to store the comments that may be stored is the tree
procedure Scan (In_Tree : Project_Node_Tree_Ref);
-- Scan the tokens and accumulate comments
type Comment_Location is
(Before, After, Before_End, After_End, End_Of_Line);
-- Used in call to Add_Comments below
procedure Add_Comments
(To : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
Where : Comment_Location);
-- Add comments to this node
----------------------
-- Access Functions --
----------------------
-- The following query functions are part of the abstract interface
-- of the Project File tree. They provide access to fields of a project.
-- The access functions should be called only with valid arguments.
-- For each function the condition of validity is specified. If an access
-- function is called with invalid arguments, then exception
-- Assertion_Error is raised if assertions are enabled, otherwise the
-- behaviour is not defined and may result in a crash.
function Name_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Name_Id;
pragma Inline (Name_Of);
-- Valid for all non empty nodes. May return No_Name for nodes that have
-- no names.
function Kind_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Kind;
pragma Inline (Kind_Of);
-- Valid for all non empty nodes
function Location_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Source_Ptr;
pragma Inline (Location_Of);
-- Valid for all non empty nodes
function First_Comment_After
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
-- Valid only for N_Comment_Zones nodes
function First_Comment_After_End
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
-- Valid only for N_Comment_Zones nodes
function First_Comment_Before
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
-- Valid only for N_Comment_Zones nodes
function First_Comment_Before_End
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
-- Valid only for N_Comment_Zones nodes
function Next_Comment
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
-- Valid only for N_Comment nodes
function End_Of_Line_Comment
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Name_Id;
-- Valid only for non empty nodes
function Follows_Empty_Line
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Boolean;
-- Valid only for N_Comment nodes
function Is_Followed_By_Empty_Line
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Boolean;
-- Valid only for N_Comment nodes
function Parent_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Parent_Project_Of);
-- Valid only for N_Project nodes
function Project_File_Includes_Unkept_Comments
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Boolean;
-- Valid only for N_Project nodes
function Directory_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Path_Name_Type;
pragma Inline (Directory_Of);
-- Returns the directory that contains the project file. This always ends
-- with a directory separator. Only valid for N_Project nodes.
function Expression_Kind_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Variable_Kind;
pragma Inline (Expression_Kind_Of);
-- Only valid for N_Literal_String, N_Attribute_Declaration,
-- N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression,
-- N_Term, N_Variable_Reference, N_Attribute_Reference nodes or
-- N_External_Value.
function Is_Extending_All
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Boolean;
pragma Inline (Is_Extending_All);
-- Only valid for N_Project and N_With_Clause
function Is_Not_Last_In_List
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Boolean;
pragma Inline (Is_Not_Last_In_List);
-- Only valid for N_With_Clause
function First_Variable_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Variable_Node_Id;
pragma Inline (First_Variable_Of);
-- Only valid for N_Project or N_Package_Declaration nodes
function First_Package_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Package_Declaration_Id;
pragma Inline (First_Package_Of);
-- Only valid for N_Project nodes
function Package_Id_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Package_Node_Id;
pragma Inline (Package_Id_Of);
-- Only valid for N_Package_Declaration nodes
function Path_Name_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Path_Name_Type;
pragma Inline (Path_Name_Of);
-- Only valid for N_Project and N_With_Clause nodes
function String_Value_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Name_Id;
pragma Inline (String_Value_Of);
-- Only valid for N_With_Clause, N_Literal_String nodes or N_Comment.
-- For a N_With_Clause created automatically for a virtual extending
-- project, No_Name is returned.
function Source_Index_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Int;
pragma Inline (Source_Index_Of);
-- Only valid for N_Literal_String and N_Attribute_Declaration nodes
function First_With_Clause_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (First_With_Clause_Of);
-- Only valid for N_Project nodes
function Project_Declaration_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Project_Declaration_Of);
-- Only valid for N_Project nodes
function Project_Qualifier_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Qualifier;
pragma Inline (Project_Qualifier_Of);
-- Only valid for N_Project nodes
function Extending_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Extending_Project_Of);
-- Only valid for N_Project_Declaration nodes
function First_String_Type_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (First_String_Type_Of);
-- Only valid for N_Project nodes
function Extended_Project_Path_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Path_Name_Type;
pragma Inline (Extended_Project_Path_Of);
-- Only valid for N_With_Clause nodes
function Project_Node_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Project_Node_Of);
-- Only valid for N_With_Clause, N_Variable_Reference and
-- N_Attribute_Reference nodes.
function Non_Limited_Project_Node_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Non_Limited_Project_Node_Of);
-- Only valid for N_With_Clause nodes. Returns Empty_Node for limited
-- imported project files, otherwise returns the same result as
-- Project_Node_Of.
function Next_With_Clause_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Next_With_Clause_Of);
-- Only valid for N_With_Clause nodes
function First_Declarative_Item_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (First_Declarative_Item_Of);
-- Only valid for N_Project_Declaration, N_Case_Item and
-- N_Package_Declaration.
function Extended_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Extended_Project_Of);
-- Only valid for N_Project_Declaration nodes
function Current_Item_Node
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Current_Item_Node);
-- Only valid for N_Declarative_Item nodes
function Next_Declarative_Item
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Next_Declarative_Item);
-- Only valid for N_Declarative_Item node
function Project_Of_Renamed_Package_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Project_Of_Renamed_Package_Of);
-- Only valid for N_Package_Declaration nodes. May return Empty_Node.
function Next_Package_In_Project
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Next_Package_In_Project);
-- Only valid for N_Package_Declaration nodes
function First_Literal_String
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (First_Literal_String);
-- Only valid for N_String_Type_Declaration nodes
function Next_String_Type
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Next_String_Type);
-- Only valid for N_String_Type_Declaration nodes
function Next_Literal_String
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Next_Literal_String);
-- Only valid for N_Literal_String nodes
function Expression_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Expression_Of);
-- Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration
-- or N_Variable_Declaration nodes
function Associative_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref)
return Project_Node_Id;
pragma Inline (Associative_Project_Of);
-- Only valid for N_Attribute_Declaration nodes
function Associative_Package_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref)
return Project_Node_Id;
pragma Inline (Associative_Package_Of);
-- Only valid for N_Attribute_Declaration nodes
function Value_Is_Valid
(For_Typed_Variable : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
Value : Name_Id) return Boolean;
pragma Inline (Value_Is_Valid);
-- Only valid for N_Typed_Variable_Declaration. Returns True if Value is
-- in the list of allowed strings for For_Typed_Variable. False otherwise.
function Associative_Array_Index_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Name_Id;
pragma Inline (Associative_Array_Index_Of);
-- Only valid for N_Attribute_Declaration and N_Attribute_Reference.
-- Returns No_Name for non associative array attributes.
function Next_Variable
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Next_Variable);
-- Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration
-- nodes.
function First_Term
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (First_Term);
-- Only valid for N_Expression nodes
function Next_Expression_In_List
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Next_Expression_In_List);
-- Only valid for N_Expression nodes
function Current_Term
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Current_Term);
-- Only valid for N_Term nodes
function Next_Term
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Next_Term);
-- Only valid for N_Term nodes
function First_Expression_In_List
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (First_Expression_In_List);
-- Only valid for N_Literal_String_List nodes
function Package_Node_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Package_Node_Of);
-- Only valid for N_Variable_Reference or N_Attribute_Reference nodes.
-- May return Empty_Node.
function String_Type_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (String_Type_Of);
-- Only valid for N_Variable_Reference or N_Typed_Variable_Declaration
-- nodes.
function External_Reference_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (External_Reference_Of);
-- Only valid for N_External_Value nodes
function External_Default_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (External_Default_Of);
-- Only valid for N_External_Value nodes
function Case_Variable_Reference_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Case_Variable_Reference_Of);
-- Only valid for N_Case_Construction nodes
function First_Case_Item_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (First_Case_Item_Of);
-- Only valid for N_Case_Construction nodes
function First_Choice_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (First_Choice_Of);
-- Only valid for N_Case_Item nodes. Return the first choice in a
-- N_Case_Item, or Empty_Node if this is when others.
function Next_Case_Item
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
pragma Inline (Next_Case_Item);
-- Only valid for N_Case_Item nodes
function Case_Insensitive
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Boolean;
-- Only valid for N_Attribute_Declaration and N_Attribute_Reference nodes
-----------------------
-- Create procedures --
-----------------------
-- The following procedures are used to edit a project file tree. They are
-- slightly higher-level than the Set_* procedures below
function Create_Project
(In_Tree : Project_Node_Tree_Ref;
Name : Name_Id;
Full_Path : Path_Name_Type;
Is_Config_File : Boolean := False) return Project_Node_Id;
-- Create a new node for a project and register it in the tree so that it
-- can be retrieved later on.
function Create_Package
(Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id;
Pkg : String) return Project_Node_Id;
-- Create a new package in Project. If the package already exists, it is
-- returned. The name of the package *must* be lower-cases, or none of its
-- attributes will be recognized.
function Create_Attribute
(Tree : Project_Node_Tree_Ref;
Prj_Or_Pkg : Project_Node_Id;
Name : Name_Id;
Index_Name : Name_Id := No_Name;
Kind : Variable_Kind := List;
At_Index : Integer := 0;
Value : Project_Node_Id := Empty_Node) return Project_Node_Id;
-- Create a new attribute. The new declaration is added at the end of the
-- declarative item list for Prj_Or_Pkg (a project or a package), but
-- before any package declaration). No addition is done if Prj_Or_Pkg is
-- Empty_Node. If Index_Name is not "", then if creates an attribute value
-- for a specific index. At_Index is used for the " at " in the naming
-- exceptions.
--
-- To set the value of the attribute, either provide a value for Value, or
-- use Set_Expression_Of to set the value of the attribute (in which case
-- Enclose_In_Expression might be useful). The former is recommended since
-- it will more correctly handle cases where the index needs to be set on
-- the expression rather than on the index of the attribute (i.e. 'for
-- Specification ("unit") use "file" at 3', versus 'for Executable ("file"
-- at 3) use "name"'). Value must be a N_String_Literal if an index will be
-- added to it.
function Create_Literal_String
(Str : Namet.Name_Id;
Tree : Project_Node_Tree_Ref) return Project_Node_Id;
-- Create a literal string whose value is Str
procedure Add_At_End
(Tree : Project_Node_Tree_Ref;
Parent : Project_Node_Id;
Expr : Project_Node_Id;
Add_Before_First_Pkg : Boolean := False;
Add_Before_First_Case : Boolean := False);
-- Add a new declarative item in the list in Parent. This new declarative
-- item will contain Expr (unless Expr is already a declarative item, in
-- which case it is added directly to the list). The new item is inserted
-- at the end of the list, unless Add_Before_First_Pkg is True. In the
-- latter case, it is added just before the first case construction is
-- seen, or before the first package (this assumes that all packages are
-- found at the end of the project, which isn't true in the general case
-- unless you have normalized the project to match this description).
function Enclose_In_Expression
(Node : Project_Node_Id;
Tree : Project_Node_Tree_Ref) return Project_Node_Id;
-- Enclose the Node inside a N_Expression node, and return this expression.
-- This does nothing if Node is already a N_Expression.
--------------------
-- Set Procedures --
--------------------
-- The following procedures are part of the abstract interface of the
-- Project File tree.
-- Foe each Set_* procedure the condition of validity is specified. If an
-- access function is called with invalid arguments, then exception
-- Assertion_Error is raised if assertions are enabled, otherwise the
-- behaviour is not defined and may result in a crash.
-- These are very low-level, and manipulate the tree itself directly. You
-- should look at the Create_* procedure instead if you want to use higher
-- level constructs
procedure Set_Name_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Name_Id);
pragma Inline (Set_Name_Of);
-- Valid for all non empty nodes.
procedure Set_Kind_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Kind);
pragma Inline (Set_Kind_Of);
-- Valid for all non empty nodes
procedure Set_Location_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Source_Ptr);
pragma Inline (Set_Location_Of);
-- Valid for all non empty nodes
procedure Set_First_Comment_After
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_First_Comment_After);
-- Valid only for N_Comment_Zones nodes
procedure Set_First_Comment_After_End
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_First_Comment_After_End);
-- Valid only for N_Comment_Zones nodes
procedure Set_First_Comment_Before
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_First_Comment_Before);
-- Valid only for N_Comment_Zones nodes
procedure Set_First_Comment_Before_End
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_First_Comment_Before_End);
-- Valid only for N_Comment_Zones nodes
procedure Set_Next_Comment
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Next_Comment);
-- Valid only for N_Comment nodes
procedure Set_Parent_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
-- Valid only for N_Project nodes
procedure Set_Project_File_Includes_Unkept_Comments
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Boolean);
-- Valid only for N_Project nodes
procedure Set_Directory_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Path_Name_Type);
pragma Inline (Set_Directory_Of);
-- Valid only for N_Project nodes
procedure Set_Expression_Kind_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Variable_Kind);
pragma Inline (Set_Expression_Kind_Of);
-- Only valid for N_Literal_String, N_Attribute_Declaration,
-- N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression,
-- N_Term, N_Variable_Reference, N_Attribute_Reference or N_External_Value
-- nodes.
procedure Set_Is_Extending_All
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref);
pragma Inline (Set_Is_Extending_All);
-- Only valid for N_Project and N_With_Clause
procedure Set_Is_Not_Last_In_List
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref);
pragma Inline (Set_Is_Not_Last_In_List);
-- Only valid for N_With_Clause
procedure Set_First_Variable_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Variable_Node_Id);
pragma Inline (Set_First_Variable_Of);
-- Only valid for N_Project or N_Package_Declaration nodes
procedure Set_First_Package_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Package_Declaration_Id);
pragma Inline (Set_First_Package_Of);
-- Only valid for N_Project nodes
procedure Set_Package_Id_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Package_Node_Id);
pragma Inline (Set_Package_Id_Of);
-- Only valid for N_Package_Declaration nodes
procedure Set_Path_Name_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Path_Name_Type);
pragma Inline (Set_Path_Name_Of);
-- Only valid for N_Project and N_With_Clause nodes
procedure Set_String_Value_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Name_Id);
pragma Inline (Set_String_Value_Of);
-- Only valid for N_With_Clause, N_Literal_String nodes or N_Comment.
procedure Set_Source_Index_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Int);
pragma Inline (Set_Source_Index_Of);
-- Only valid for N_Literal_String and N_Attribute_Declaration nodes. For
-- N_Literal_String, set the source index of the literal string. For
-- N_Attribute_Declaration, set the source index of the index of the
-- associative array element.
procedure Set_First_With_Clause_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_First_With_Clause_Of);
-- Only valid for N_Project nodes
procedure Set_Project_Declaration_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Project_Declaration_Of);
-- Only valid for N_Project nodes
procedure Set_Project_Qualifier_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Qualifier);
pragma Inline (Set_Project_Qualifier_Of);
-- Only valid for N_Project nodes
procedure Set_Extending_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Extending_Project_Of);
-- Only valid for N_Project_Declaration nodes
procedure Set_First_String_Type_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_First_String_Type_Of);
-- Only valid for N_Project nodes
procedure Set_Extended_Project_Path_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Path_Name_Type);
pragma Inline (Set_Extended_Project_Path_Of);
-- Only valid for N_With_Clause nodes
procedure Set_Project_Node_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id;
Limited_With : Boolean := False);
pragma Inline (Set_Project_Node_Of);
-- Only valid for N_With_Clause, N_Variable_Reference and
-- N_Attribute_Reference nodes.
procedure Set_Next_With_Clause_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Next_With_Clause_Of);
-- Only valid for N_With_Clause nodes
procedure Set_First_Declarative_Item_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_First_Declarative_Item_Of);
-- Only valid for N_Project_Declaration, N_Case_Item and
-- N_Package_Declaration.
procedure Set_Extended_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Extended_Project_Of);
-- Only valid for N_Project_Declaration nodes
procedure Set_Current_Item_Node
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Current_Item_Node);
-- Only valid for N_Declarative_Item nodes
procedure Set_Next_Declarative_Item
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Next_Declarative_Item);
-- Only valid for N_Declarative_Item node
procedure Set_Project_Of_Renamed_Package_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Project_Of_Renamed_Package_Of);
-- Only valid for N_Package_Declaration nodes.
procedure Set_Next_Package_In_Project
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Next_Package_In_Project);
-- Only valid for N_Package_Declaration nodes
procedure Set_First_Literal_String
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_First_Literal_String);
-- Only valid for N_String_Type_Declaration nodes
procedure Set_Next_String_Type
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Next_String_Type);
-- Only valid for N_String_Type_Declaration nodes
procedure Set_Next_Literal_String
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Next_Literal_String);
-- Only valid for N_Literal_String nodes
procedure Set_Expression_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Expression_Of);
-- Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration
-- or N_Variable_Declaration nodes
procedure Set_Associative_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Associative_Project_Of);
-- Only valid for N_Attribute_Declaration nodes
procedure Set_Associative_Package_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Associative_Package_Of);
-- Only valid for N_Attribute_Declaration nodes
procedure Set_Associative_Array_Index_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Name_Id);
pragma Inline (Set_Associative_Array_Index_Of);
-- Only valid for N_Attribute_Declaration and N_Attribute_Reference.
procedure Set_Next_Variable
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Next_Variable);
-- Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration
-- nodes.
procedure Set_First_Term
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_First_Term);
-- Only valid for N_Expression nodes
procedure Set_Next_Expression_In_List
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Next_Expression_In_List);
-- Only valid for N_Expression nodes
procedure Set_Current_Term
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Current_Term);
-- Only valid for N_Term nodes
procedure Set_Next_Term
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Next_Term);
-- Only valid for N_Term nodes
procedure Set_First_Expression_In_List
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_First_Expression_In_List);
-- Only valid for N_Literal_String_List nodes
procedure Set_Package_Node_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Package_Node_Of);
-- Only valid for N_Variable_Reference or N_Attribute_Reference nodes.
procedure Set_String_Type_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_String_Type_Of);
-- Only valid for N_Variable_Reference or N_Typed_Variable_Declaration
-- nodes.
procedure Set_External_Reference_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_External_Reference_Of);
-- Only valid for N_External_Value nodes
procedure Set_External_Default_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_External_Default_Of);
-- Only valid for N_External_Value nodes
procedure Set_Case_Variable_Reference_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Case_Variable_Reference_Of);
-- Only valid for N_Case_Construction nodes
procedure Set_First_Case_Item_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_First_Case_Item_Of);
-- Only valid for N_Case_Construction nodes
procedure Set_First_Choice_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_First_Choice_Of);
-- Only valid for N_Case_Item nodes.
procedure Set_Next_Case_Item
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id);
pragma Inline (Set_Next_Case_Item);
-- Only valid for N_Case_Item nodes.
procedure Set_Case_Insensitive
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Boolean);
-- Only valid for N_Attribute_Declaration and N_Attribute_Reference nodes
-------------------------------
-- Restricted Access Section --
-------------------------------
package Tree_Private_Part is
-- This is conceptually in the private part. However, for efficiency,
-- some packages are accessing it directly.
type Project_Node_Record is record
Kind : Project_Node_Kind;
Qualifier : Project_Qualifier := Unspecified;
Location : Source_Ptr := No_Location;
Directory : Path_Name_Type := No_Path;
-- Only for N_Project
Expr_Kind : Variable_Kind := Undefined;
-- See below for what Project_Node_Kind it is used
Variables : Variable_Node_Id := Empty_Node;
-- First variable in a project or a package
Packages : Package_Declaration_Id := Empty_Node;
-- First package declaration in a project
Pkg_Id : Package_Node_Id := Empty_Package;
-- Only used for N_Package_Declaration
--
-- The component Pkg_Id is an entry into the table Package_Attributes
-- (in Prj.Attr). It is used to indicate all the attributes of the
-- package with their characteristics.
--
-- The tables Prj.Attr.Attributes and Prj.Attr.Package_Attributes
-- are built once and for all through a call (from Prj.Initialize)
-- to procedure Prj.Attr.Initialize. It is never modified after that.
Name : Name_Id := No_Name;
-- See below for what Project_Node_Kind it is used
Src_Index : Int := 0;
-- Index of a unit in a multi-unit source.
-- Only for some N_Attribute_Declaration and N_Literal_String.
Path_Name : Path_Name_Type := No_Path;
-- See below for what Project_Node_Kind it is used
Value : Name_Id := No_Name;
-- See below for what Project_Node_Kind it is used
Field1 : Project_Node_Id := Empty_Node;
-- See below the meaning for each Project_Node_Kind
Field2 : Project_Node_Id := Empty_Node;
-- See below the meaning for each Project_Node_Kind
Field3 : Project_Node_Id := Empty_Node;
-- See below the meaning for each Project_Node_Kind
Field4 : Project_Node_Id := Empty_Node;
-- See below the meaning for each Project_Node_Kind
Flag1 : Boolean := False;
-- This flag is significant only for:
--
-- N_Attribute_Declaration and N_Attribute_Reference
-- Indicates for an associative array attribute, that the
-- index is case insensitive.
--
-- N_Comment
-- Indicates that the comment is preceded by an empty line.
--
-- N_Project
-- Indicates that there are comments in the project source that
-- cannot be kept in the tree.
--
-- N_Project_Declaration
-- Indicates that there are unkept comments in the project.
--
-- N_With_Clause
-- Indicates that this is not the last with in a with clause.
-- Set for "A", but not for "B" in with "B"; and with "A", "B";
Flag2 : Boolean := False;
-- This flag is significant only for:
--
-- N_Project
-- Indicates that the project "extends all" another project.
--
-- N_Comment
-- Indicates that the comment is followed by an empty line.
--
-- N_With_Clause
-- Indicates that the originally imported project is an extending
-- all project.
Comments : Project_Node_Id := Empty_Node;
-- For nodes other that N_Comment_Zones or N_Comment, designates the
-- comment zones associated with the node.
--
-- For N_Comment_Zones, designates the comment after the "end" of
-- the construct.
--
-- For N_Comment, designates the next comment, if any.
end record;
-- type Project_Node_Kind is
-- (N_Project,
-- -- Name: project name
-- -- Path_Name: project path name
-- -- Expr_Kind: Undefined
-- -- Field1: first with clause
-- -- Field2: project declaration
-- -- Field3: first string type
-- -- Field4: parent project, if any
-- -- Value: extended project path name (if any)
-- N_With_Clause,
-- -- Name: imported project name
-- -- Path_Name: imported project path name
-- -- Expr_Kind: Undefined
-- -- Field1: project node
-- -- Field2: next with clause
-- -- Field3: project node or empty if "limited with"
-- -- Field4: not used
-- -- Value: literal string withed
-- N_Project_Declaration,
-- -- Name: not used
-- -- Path_Name: not used
-- -- Expr_Kind: Undefined
-- -- Field1: first declarative item
-- -- Field2: extended project
-- -- Field3: extending project
-- -- Field4: not used
-- -- Value: not used
-- N_Declarative_Item,
-- -- Name: not used
-- -- Path_Name: not used
-- -- Expr_Kind: Undefined
-- -- Field1: current item node
-- -- Field2: next declarative item
-- -- Field3: not used
-- -- Field4: not used
-- -- Value: not used
-- N_Package_Declaration,
-- -- Name: package name
-- -- Path_Name: not used
-- -- Expr_Kind: Undefined
-- -- Field1: project of renamed package (if any)
-- -- Field2: first declarative item
-- -- Field3: next package in project
-- -- Field4: not used
-- -- Value: not used
-- N_String_Type_Declaration,
-- -- Name: type name
-- -- Path_Name: not used
-- -- Expr_Kind: Undefined
-- -- Field1: first literal string
-- -- Field2: next string type
-- -- Field3: not used
-- -- Field4: not used
-- -- Value: not used
-- N_Literal_String,
-- -- Name: not used
-- -- Path_Name: not used
-- -- Expr_Kind: Single
-- -- Field1: next literal string
-- -- Field2: not used
-- -- Field3: not used
-- -- Field4: not used
-- -- Value: string value
-- N_Attribute_Declaration,
-- -- Name: attribute name
-- -- Path_Name: not used
-- -- Expr_Kind: attribute kind
-- -- Field1: expression
-- -- Field2: project of full associative array
-- -- Field3: package of full associative array
-- -- Field4: not used
-- -- Value: associative array index
-- -- (if an associative array element)
-- N_Typed_Variable_Declaration,
-- -- Name: variable name
-- -- Path_Name: not used
-- -- Expr_Kind: Single
-- -- Field1: expression
-- -- Field2: type of variable (N_String_Type_Declaration)
-- -- Field3: next variable
-- -- Field4: not used
-- -- Value: not used
-- N_Variable_Declaration,
-- -- Name: variable name
-- -- Path_Name: not used
-- -- Expr_Kind: variable kind
-- -- Field1: expression
-- -- Field2: not used
-- -- Field3 is used for next variable, instead of Field2,
-- -- so that it is the same field for
-- -- N_Variable_Declaration and
-- -- N_Typed_Variable_Declaration
-- -- Field3: next variable
-- -- Field4: not used
-- -- Value: not used
-- N_Expression,
-- -- Name: not used
-- -- Path_Name: not used
-- -- Expr_Kind: expression kind
-- -- Field1: first term
-- -- Field2: next expression in list
-- -- Field3: not used
-- -- Value: not used
-- N_Term,
-- -- Name: not used
-- -- Path_Name: not used
-- -- Expr_Kind: term kind
-- -- Field1: current term
-- -- Field2: next term in the expression
-- -- Field3: not used
-- -- Field4: not used
-- -- Value: not used
-- N_Literal_String_List,
-- -- Designates a list of string expressions between brackets
-- -- separated by commas. The string expressions are not necessarily
-- -- literal strings.
-- -- Name: not used
-- -- Path_Name: not used
-- -- Expr_Kind: List
-- -- Field1: first expression
-- -- Field2: not used
-- -- Field3: not used
-- -- Field4: not used
-- -- Value: not used
-- N_Variable_Reference,
-- -- Name: variable name
-- -- Path_Name: not used
-- -- Expr_Kind: variable kind
-- -- Field1: project (if specified)
-- -- Field2: package (if specified)
-- -- Field3: type of variable (N_String_Type_Declaration), if any
-- -- Field4: not used
-- -- Value: not used
-- N_External_Value,
-- -- Name: not used
-- -- Path_Name: not used
-- -- Expr_Kind: Single
-- -- Field1: Name of the external reference (literal string)
-- -- Field2: Default (literal string)
-- -- Field3: not used
-- -- Value: not used
-- N_Attribute_Reference,
-- -- Name: attribute name
-- -- Path_Name: not used
-- -- Expr_Kind: attribute kind
-- -- Field1: project
-- -- Field2: package (if attribute of a package)
-- -- Field3: not used
-- -- Field4: not used
-- -- Value: associative array index
-- -- (if an associative array element)
-- N_Case_Construction,
-- -- Name: not used
-- -- Path_Name: not used
-- -- Expr_Kind: Undefined
-- -- Field1: case variable reference
-- -- Field2: first case item
-- -- Field3: not used
-- -- Field4: not used
-- -- Value: not used
-- N_Case_Item
-- -- Name: not used
-- -- Path_Name: not used
-- -- Expr_Kind: not used
-- -- Field1: first choice (literal string), or Empty_Node
-- -- for when others
-- -- Field2: first declarative item
-- -- Field3: next case item
-- -- Field4: not used
-- -- Value: not used
-- N_Comment_zones
-- -- Name: not used
-- -- Path_Name: not used
-- -- Expr_Kind: not used
-- -- Field1: comment before the construct
-- -- Field2: comment after the construct
-- -- Field3: comment before the "end" of the construct
-- -- Value: end of line comment
-- -- Field4: not used
-- -- Comments: comment after the "end" of the construct
-- N_Comment
-- -- Name: not used
-- -- Path_Name: not used
-- -- Expr_Kind: not used
-- -- Field1: not used
-- -- Field2: not used
-- -- Field3: not used
-- -- Field4: not used
-- -- Value: comment
-- -- Flag1: comment is preceded by an empty line
-- -- Flag2: comment is followed by an empty line
-- -- Comments: next comment
package Project_Node_Table is new
GNAT.Dynamic_Tables
(Table_Component_Type => Project_Node_Record,
Table_Index_Type => Project_Node_Id,
Table_Low_Bound => First_Node_Id,
Table_Initial => Project_Nodes_Initial,
Table_Increment => Project_Nodes_Increment);
-- Table contains the syntactic tree of project data from project files
type Project_Name_And_Node is record
Name : Name_Id;
-- Name of the project
Display_Name : Name_Id;
-- The name of the project as it appears in the .gpr file
Node : Project_Node_Id;
-- Node of the project in table Project_Nodes
Resolved_Path : Path_Name_Type;
-- Resolved and canonical path of a real project file.
-- No_Name in case of virtual projects.
Extended : Boolean;
-- True when the project is being extended by another project
From_Extended : Boolean;
-- True when the project is only imported by projects that are
-- extended.
Proj_Qualifier : Project_Qualifier;
-- The project qualifier of the project, if any
end record;
No_Project_Name_And_Node : constant Project_Name_And_Node :=
(Name => No_Name,
Display_Name => No_Name,
Node => Empty_Node,
Resolved_Path => No_Path,
Extended => True,
From_Extended => False,
Proj_Qualifier => Unspecified);
package Projects_Htable is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => Header_Num,
Element => Project_Name_And_Node,
No_Element => No_Project_Name_And_Node,
Key => Name_Id,
Hash => Hash,
Equal => "=");
-- This hash table contains a mapping of project names to project nodes.
-- Note that this hash table contains only the nodes whose Kind is
-- N_Project. It is used to find the node of a project from its name,
-- and to verify if a project has already been parsed, knowing its name.
end Tree_Private_Part;
type Project_Node_Tree_Data is record
Project_Nodes : Tree_Private_Part.Project_Node_Table.Instance;
Projects_HT : Tree_Private_Part.Projects_Htable.Instance;
Incomplete_With : Boolean := False;
-- Set to True if the projects were loaded with the flag
-- Ignore_Missing_With set to True, and there were indeed some with
-- statements that could not be resolved
end record;
procedure Free (Proj : in out Project_Node_Tree_Ref);
-- Free memory used by Prj
private
type Comment_Array is array (Positive range <>) of Comment_Data;
type Comments_Ptr is access Comment_Array;
type Comment_State is record
End_Of_Line_Node : Project_Node_Id := Empty_Node;
Previous_Line_Node : Project_Node_Id := Empty_Node;
Previous_End_Node : Project_Node_Id := Empty_Node;
Unkept_Comments : Boolean := False;
Comments : Comments_Ptr := null;
end record;
end Prj.Tree;
gprbuild-gpl-2014-src/gnat/tempdir.adb 0000644 0000767 0000145 00000012300 12323721731 017174 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- T E M P D I R --
-- --
-- B o d y --
-- --
-- Copyright (C) 2003-2013, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Hostparm; use Hostparm;
with Opt; use Opt;
with Output; use Output;
package body Tempdir is
Tmpdir_Needs_To_Be_Displayed : Boolean := True;
Tmpdir : constant String := "TMPDIR";
Gnutmpdir : constant String := "GNUTMPDIR";
Temp_Dir : String_Access := new String'("");
----------------------
-- Create_Temp_File --
----------------------
procedure Create_Temp_File
(FD : out File_Descriptor;
Name : out Path_Name_Type)
is
File_Name : String_Access;
Current_Dir : constant String := Get_Current_Dir;
function Directory return String;
-- Returns Temp_Dir.all if not empty, else return current directory
---------------
-- Directory --
---------------
function Directory return String is
begin
if Temp_Dir'Length /= 0 then
return Temp_Dir.all;
else
return Current_Dir;
end if;
end Directory;
-- Start of processing Tempdir
begin
if Temp_Dir'Length /= 0 then
-- In verbose mode, display once the value of TMPDIR, so that
-- if temp files cannot be created, it is easier to understand
-- where temp files are supposed to be created.
if Verbose_Mode and then Tmpdir_Needs_To_Be_Displayed then
Write_Str ("TMPDIR = """);
Write_Str (Temp_Dir.all);
Write_Line ("""");
Tmpdir_Needs_To_Be_Displayed := False;
end if;
-- Change directory to TMPDIR before creating the temp file,
-- then change back immediately to the previous directory.
Change_Dir (Temp_Dir.all);
Create_Temp_File (FD, File_Name);
Change_Dir (Current_Dir);
else
Create_Temp_File (FD, File_Name);
end if;
if FD = Invalid_FD then
Write_Line ("could not create temporary file in " & Directory);
Name := No_Path;
else
declare
Path_Name : constant String :=
Normalize_Pathname
(Directory & Directory_Separator & File_Name.all);
begin
Name_Len := Path_Name'Length;
Name_Buffer (1 .. Name_Len) := Path_Name;
Name := Name_Find;
Free (File_Name);
end;
end if;
end Create_Temp_File;
------------------
-- Use_Temp_Dir --
------------------
procedure Use_Temp_Dir (Status : Boolean) is
Dir : String_Access;
begin
if Status then
-- On VMS, if GNUTMPDIR is defined, use it
if OpenVMS then
Dir := Getenv (Gnutmpdir);
-- Otherwise, if GNUTMPDIR is not defined, try TMPDIR
if Dir'Length = 0 then
Dir := Getenv (Tmpdir);
end if;
else
Dir := Getenv (Tmpdir);
end if;
end if;
Free (Temp_Dir);
if Dir /= null
and then Dir'Length > 0
and then Is_Absolute_Path (Dir.all)
and then Is_Directory (Dir.all)
then
Temp_Dir := new String'(Normalize_Pathname (Dir.all));
else
Temp_Dir := new String'("");
end if;
Free (Dir);
end Use_Temp_Dir;
-- Start of elaboration for package Tempdir
begin
Use_Temp_Dir (Status => True);
end Tempdir;
gprbuild-gpl-2014-src/gnat/mlib-tgt-specific.ads 0000644 0000767 0000145 00000004353 12323721731 021064 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M L I B . T G T . S P E C I F I C --
-- --
-- S p e c --
-- --
-- Copyright (C) 2007, AdaCore --
-- --
-- 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This child package of package MLib.Tgt has no interface.
-- For each platform, there is a specific body that defines the subprogram
-- that are different from the default defined in the body of MLib.Tgt,
-- and modify the corresponding access to subprogram value in the private
-- part of MLib.Tgt.
package MLib.Tgt.Specific is
pragma Elaborate_Body;
end MLib.Tgt.Specific;
gprbuild-gpl-2014-src/gnat/mlib-utl.adb 0000644 0000767 0000145 00000047632 12323721731 017275 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M L I B . U T L --
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2013, AdaCore --
-- --
-- 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with MLib.Fil; use MLib.Fil;
with MLib.Tgt; use MLib.Tgt;
with Opt;
with Osint;
with Output; use Output;
with Interfaces.C.Strings; use Interfaces.C.Strings;
package body MLib.Utl is
Adalib_Path : String_Access := null;
-- Path of the GNAT adalib directory, specified in procedure
-- Specify_Adalib_Dir. Used in function Lib_Directory.
Gcc_Name : String_Access;
-- Default value of the "gcc" executable used in procedure Gcc
Gcc_Exec : String_Access;
-- The full path name of the "gcc" executable
Ar_Name : String_Access;
-- The name of the archive builder for the platform, set when procedure Ar
-- is called for the first time.
Ar_Exec : String_Access;
-- The full path name of the archive builder
Ar_Options : String_List_Access;
-- The minimum options used when invoking the archive builder
Ar_Append_Options : String_List_Access;
-- The options to be used when invoking the archive builder to add chunks
-- of object files, when building the archive in chunks.
Opt_Length : Natural := 0;
-- The max number of options for the Archive_Builder
Initial_Size : Natural := 0;
-- The minimum number of bytes for the invocation of the Archive Builder
-- (without name of the archive or object files).
Ranlib_Name : String_Access;
-- The name of the archive indexer for the platform, if there is one
Ranlib_Exec : String_Access := null;
-- The full path name of the archive indexer
Ranlib_Options : String_List_Access := null;
-- The options to be used when invoking the archive indexer, if any
--------
-- Ar --
--------
procedure Ar (Output_File : String; Objects : Argument_List) is
Full_Output_File : constant String :=
Ext_To (Output_File, Archive_Ext);
Arguments : Argument_List_Access;
Last_Arg : Natural := 0;
Success : Boolean;
Line_Length : Natural := 0;
Maximum_Size : Integer;
pragma Import (C, Maximum_Size, "__gnat_link_max");
-- Maximum number of bytes to put in an invocation of the
-- Archive_Builder.
Size : Integer;
-- The number of bytes for the invocation of the archive builder
Current_Object : Natural;
procedure Display;
-- Display an invocation of the Archive Builder
-------------
-- Display --
-------------
procedure Display is
begin
if not Opt.Quiet_Output then
Write_Str (Ar_Name.all);
Line_Length := Ar_Name'Length;
for J in 1 .. Last_Arg loop
-- Make sure the Output buffer does not overflow
if Line_Length + 1 + Arguments (J)'Length > Buffer_Max then
Write_Eol;
Line_Length := 0;
end if;
Write_Char (' ');
-- Only output the first object files when not in verbose mode
if (not Opt.Verbose_Mode) and then J = Opt_Length + 3 then
Write_Str ("...");
exit;
end if;
Write_Str (Arguments (J).all);
Line_Length := Line_Length + 1 + Arguments (J)'Length;
end loop;
Write_Eol;
end if;
end Display;
begin
if Ar_Exec = null then
Ar_Name := Osint.Program_Name (Archive_Builder, "gnatmake");
Ar_Exec := Locate_Exec_On_Path (Ar_Name.all);
if Ar_Exec = null then
Free (Ar_Name);
Ar_Name := new String'(Archive_Builder);
Ar_Exec := Locate_Exec_On_Path (Ar_Name.all);
end if;
if Ar_Exec = null then
Fail (Ar_Name.all & " not found in path");
elsif Opt.Verbose_Mode then
Write_Str ("found ");
Write_Line (Ar_Exec.all);
end if;
Ar_Options := Archive_Builder_Options;
Initial_Size := 0;
for J in Ar_Options'Range loop
Initial_Size := Initial_Size + Ar_Options (J)'Length + 1;
end loop;
Ar_Append_Options := Archive_Builder_Append_Options;
Opt_Length := Ar_Options'Length;
if Ar_Append_Options /= null then
Opt_Length := Natural'Max (Ar_Append_Options'Length, Opt_Length);
Size := 0;
for J in Ar_Append_Options'Range loop
Size := Size + Ar_Append_Options (J)'Length + 1;
end loop;
Initial_Size := Integer'Max (Initial_Size, Size);
end if;
-- ranlib
Ranlib_Name := Osint.Program_Name (Archive_Indexer, "gnatmake");
if Ranlib_Name'Length > 0 then
Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all);
if Ranlib_Exec = null then
Free (Ranlib_Name);
Ranlib_Name := new String'(Archive_Indexer);
Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all);
end if;
if Ranlib_Exec /= null and then Opt.Verbose_Mode then
Write_Str ("found ");
Write_Line (Ranlib_Exec.all);
end if;
end if;
Ranlib_Options := Archive_Indexer_Options;
end if;
Arguments :=
new String_List (1 .. 1 + Opt_Length + Objects'Length);
Arguments (1 .. Ar_Options'Length) := Ar_Options.all; -- "ar cr ..."
Arguments (Ar_Options'Length + 1) := new String'(Full_Output_File);
Delete_File (Full_Output_File);
Size := Initial_Size + Full_Output_File'Length + 1;
-- Check the full size of a call of the archive builder with all the
-- object files.
for J in Objects'Range loop
Size := Size + Objects (J)'Length + 1;
end loop;
-- If the size is not too large or if it is not possible to build the
-- archive in chunks, build the archive in a single invocation.
if Size <= Maximum_Size or else Ar_Append_Options = null then
Last_Arg := Ar_Options'Length + 1 + Objects'Length;
Arguments (Ar_Options'Length + 2 .. Last_Arg) := Objects;
Display;
Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
else
-- Build the archive in several invocation, making sure to not
-- go over the maximum size for each invocation.
Last_Arg := Ar_Options'Length + 1;
Current_Object := Objects'First;
Size := Initial_Size + Full_Output_File'Length + 1;
-- First invocation
while Current_Object <= Objects'Last loop
Size := Size + Objects (Current_Object)'Length + 1;
exit when Size > Maximum_Size;
Last_Arg := Last_Arg + 1;
Arguments (Last_Arg) := Objects (Current_Object);
Current_Object := Current_Object + 1;
end loop;
Display;
Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
Arguments (1 .. Ar_Append_Options'Length) := Ar_Append_Options.all;
Arguments
(Ar_Append_Options'Length + 1) := new String'(Full_Output_File);
-- Appending invocation(s)
Big_Loop : while Success and then Current_Object <= Objects'Last loop
Last_Arg := Ar_Append_Options'Length + 1;
Size := Initial_Size + Full_Output_File'Length + 1;
Inner_Loop : while Current_Object <= Objects'Last loop
Size := Size + Objects (Current_Object)'Length + 1;
exit Inner_Loop when Size > Maximum_Size;
Last_Arg := Last_Arg + 1;
Arguments (Last_Arg) := Objects (Current_Object);
Current_Object := Current_Object + 1;
end loop Inner_Loop;
Display;
Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
end loop Big_Loop;
end if;
if not Success then
Fail (Ar_Name.all & " execution error.");
end if;
-- If we have found ranlib, run it over the library
if Ranlib_Exec /= null then
if not Opt.Quiet_Output then
Write_Str (Ranlib_Name.all);
Write_Char (' ');
Write_Line (Arguments (Ar_Options'Length + 1).all);
end if;
Spawn
(Ranlib_Exec.all,
Ranlib_Options.all & (Arguments (Ar_Options'Length + 1)),
Success);
if not Success then
Fail (Ranlib_Name.all & " execution error.");
end if;
end if;
end Ar;
-----------------
-- Delete_File --
-----------------
procedure Delete_File (Filename : String) is
File : constant String := Filename & ASCII.NUL;
Success : Boolean;
begin
Delete_File (File'Address, Success);
if Opt.Verbose_Mode then
if Success then
Write_Str ("deleted ");
else
Write_Str ("could not delete ");
end if;
Write_Line (Filename);
end if;
end Delete_File;
---------
-- Gcc --
---------
procedure Gcc
(Output_File : String;
Objects : Argument_List;
Options : Argument_List;
Options_2 : Argument_List;
Driver_Name : Name_Id := No_Name)
is
Link_Bytes : Integer := 0;
-- Projected number of bytes for the linker command line
Link_Max : Integer;
pragma Import (C, Link_Max, "__gnat_link_max");
-- Maximum number of bytes on the command line supported by the OS
-- linker. Passed this limit the response file mechanism must be used
-- if supported.
Object_List_File_Supported : Boolean;
for Object_List_File_Supported'Size use Character'Size;
pragma Import
(C, Object_List_File_Supported, "__gnat_objlist_file_supported");
-- Predicate indicating whether the linker has an option whereby the
-- names of object files can be passed to the linker in a file.
Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr;
pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option");
-- Pointer to a string representing the linker option which specifies
-- the response file.
Object_File_Option : constant String := Value (Object_File_Option_Ptr);
-- The linker option which specifies the response file as a string
Using_GNU_response_file : constant Boolean :=
Object_File_Option'Length > 0
and then
Object_File_Option
(Object_File_Option'Last) = '@';
-- Whether a GNU response file is used
Tname : String_Access;
Tname_FD : File_Descriptor := Invalid_FD;
-- Temporary file used by linker to pass list of object files on
-- certain systems with limitations on size of arguments.
Closing_Status : Boolean;
-- For call to Close
Arguments :
Argument_List
(1 .. 7 + Objects'Length + Options'Length + Options_2'Length);
A : Natural := 0;
Success : Boolean;
Out_Opt : constant String_Access := new String'("-o");
Out_V : constant String_Access := new String'(Output_File);
Lib_Dir : constant String_Access := new String'("-L" & Lib_Directory);
Lib_Opt : constant String_Access := new String'(Dynamic_Option);
Driver : String_Access;
type Object_Position is (First, Second, Last);
Position : Object_Position;
procedure Write_RF (S : String);
-- Write a string to the response file and check if it was successful.
-- Fail the program if it was not successful (disk full).
--------------
-- Write_RF --
--------------
procedure Write_RF (S : String) is
Success : Boolean := True;
Back_Slash : constant Character := '\';
begin
-- If a GNU response file is used, space and backslash need to be
-- escaped because they are interpreted as a string separator and
-- an escape character respectively by the underlying mechanism.
-- On the other hand, quote and double-quote are not escaped since
-- they are interpreted as string delimiters on both sides.
if Using_GNU_response_file then
for J in S'Range loop
if S (J) = ' ' or else S (J) = '\' then
if Write (Tname_FD, Back_Slash'Address, 1) /= 1 then
Success := False;
end if;
end if;
if Write (Tname_FD, S (J)'Address, 1) /= 1 then
Success := False;
end if;
end loop;
else
if Write (Tname_FD, S'Address, S'Length) /= S'Length then
Success := False;
end if;
end if;
if Write (Tname_FD, ASCII.LF'Address, 1) /= 1 then
Success := False;
end if;
if not Success then
Fail ("cannot generate response file to link library: disk full");
end if;
end Write_RF;
-- Start of processing for Gcc
begin
if Driver_Name = No_Name then
if Gcc_Exec = null then
if Gcc_Name = null then
Gcc_Name := Osint.Program_Name ("gcc", "gnatmake");
end if;
Gcc_Exec := Locate_Exec_On_Path (Gcc_Name.all);
if Gcc_Exec = null then
Fail (Gcc_Name.all & " not found in path");
end if;
end if;
Driver := Gcc_Exec;
else
Driver := Locate_Exec_On_Path (Get_Name_String (Driver_Name));
if Driver = null then
Fail (Get_Name_String (Driver_Name) & " not found in path");
end if;
end if;
Link_Bytes := 0;
if Lib_Opt'Length /= 0 then
A := A + 1;
Arguments (A) := Lib_Opt;
Link_Bytes := Link_Bytes + Lib_Opt'Length + 1;
end if;
A := A + 1;
Arguments (A) := Out_Opt;
Link_Bytes := Link_Bytes + Out_Opt'Length + 1;
A := A + 1;
Arguments (A) := Out_V;
Link_Bytes := Link_Bytes + Out_V'Length + 1;
A := A + 1;
Arguments (A) := Lib_Dir;
Link_Bytes := Link_Bytes + Lib_Dir'Length + 1;
A := A + Options'Length;
Arguments (A - Options'Length + 1 .. A) := Options;
for J in Options'Range loop
Link_Bytes := Link_Bytes + Options (J)'Length + 1;
end loop;
if not Opt.Quiet_Output then
if Opt.Verbose_Mode then
Write_Str (Driver.all);
elsif Driver_Name /= No_Name then
Write_Str (Get_Name_String (Driver_Name));
else
Write_Str (Gcc_Name.all);
end if;
for J in 1 .. A loop
if Opt.Verbose_Mode or else J < 4 then
Write_Char (' ');
Write_Str (Arguments (J).all);
else
Write_Str (" ...");
exit;
end if;
end loop;
-- Do not display all the object files if not in verbose mode, only
-- the first one.
Position := First;
for J in Objects'Range loop
if Opt.Verbose_Mode or else Position = First then
Write_Char (' ');
Write_Str (Objects (J).all);
Position := Second;
elsif Position = Second then
Write_Str (" ...");
Position := Last;
exit;
end if;
end loop;
for J in Options_2'Range loop
if not Opt.Verbose_Mode then
if Position = Second then
Write_Str (" ...");
end if;
exit;
end if;
Write_Char (' ');
Write_Str (Options_2 (J).all);
end loop;
Write_Eol;
end if;
for J in Objects'Range loop
Link_Bytes := Link_Bytes + Objects (J)'Length + 1;
end loop;
for J in Options_2'Range loop
Link_Bytes := Link_Bytes + Options_2 (J)'Length + 1;
end loop;
if Object_List_File_Supported and then Link_Bytes > Link_Max then
-- Create a temporary file containing the object files, one object
-- file per line for maximal compatibility with linkers supporting
-- this option.
Create_Temp_File (Tname_FD, Tname);
for J in Objects'Range loop
Write_RF (Objects (J).all);
end loop;
Close (Tname_FD, Closing_Status);
if not Closing_Status then
Fail ("cannot generate response file to link library: disk full");
end if;
A := A + 1;
Arguments (A) := new String'(Object_File_Option & Tname.all);
else
A := A + Objects'Length;
Arguments (A - Objects'Length + 1 .. A) := Objects;
end if;
A := A + Options_2'Length;
Arguments (A - Options_2'Length + 1 .. A) := Options_2;
Spawn (Driver.all, Arguments (1 .. A), Success);
if Success then
-- Delete the temporary file used in conjunction with linking
-- if one was created.
if Tname_FD /= Invalid_FD then
Delete_File (Tname.all);
end if;
else
if Driver_Name = No_Name then
Fail (Gcc_Name.all & " execution error");
else
Fail (Get_Name_String (Driver_Name) & " execution error");
end if;
end if;
end Gcc;
-------------------
-- Lib_Directory --
-------------------
function Lib_Directory return String is
Libgnat : constant String := Tgt.Libgnat;
begin
-- If procedure Specify_Adalib_Dir has been called, used the specified
-- value.
if Adalib_Path /= null then
return Adalib_Path.all;
end if;
Name_Len := Libgnat'Length;
Name_Buffer (1 .. Name_Len) := Libgnat;
Get_Name_String (Osint.Find_File (Name_Enter, Osint.Library));
-- Remove libgnat.a
return Name_Buffer (1 .. Name_Len - Libgnat'Length);
end Lib_Directory;
------------------------
-- Specify_Adalib_Dir --
------------------------
procedure Specify_Adalib_Dir (Path : String) is
begin
if Path'Length = 0 then
Adalib_Path := null;
else
Adalib_Path := new String'(Path);
end if;
end Specify_Adalib_Dir;
end MLib.Utl;
gprbuild-gpl-2014-src/gnat/prj-err.ads 0000644 0000767 0000145 00000011007 12323721731 017135 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . E R R --
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2010, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package contains the routines to output error messages and the scanner
-- for the project files. It replaces Errout and Scn. It is not dependent on
-- the GNAT tree packages (Atree, Sinfo, ...). It uses exactly the same global
-- variables as Errout, located in package Err_Vars. Like Errout, it also uses
-- the common variables and routines in package Erroutc.
--
-- Parameters are set through Err_Vars.Error_Msg_File_* or
-- Err_Vars.Error_Msg_Name_*, and replaced automatically in the messages
-- ("{{" for files, "%%" for names).
--
-- However, in this package you can configure the error messages to be sent
-- to your own callback by setting Report_Error in the flags. This ensures
-- that applications can control where error messages are displayed.
with Scng;
with Errutil;
package Prj.Err is
---------------------------------------------------------
-- Error Message Text and Message Insertion Characters --
---------------------------------------------------------
-- See errutil.ads
-----------------------------------------------------
-- Format of Messages and Manual Quotation Control --
-----------------------------------------------------
-- See errutil.ads
------------------------------
-- Error Output Subprograms --
------------------------------
procedure Initialize renames Errutil.Initialize;
-- Initializes for output of error messages. Must be called for each
-- file before using any of the other routines in the package.
procedure Finalize (Source_Type : String := "project")
renames Errutil.Finalize;
-- Finalize processing of error messages for one file and output message
-- indicating the number of detected errors.
procedure Error_Msg
(Flags : Processing_Flags;
Msg : String;
Location : Source_Ptr := No_Location;
Project : Project_Id := null);
-- Output an error message, either through Flags.Error_Report or through
-- Errutil. The location defaults to the project's location ("project"
-- in the source code). If Msg starts with "?", this is a warning, and
-- Warning: is added at the beginning. If Msg starts with "<", see comment
-- for Err_Vars.Error_Msg_Warn.
-------------
-- Scanner --
-------------
procedure Post_Scan;
-- Convert an Ada operator symbol into a standard string
package Scanner is new Scng
(Post_Scan => Post_Scan,
Error_Msg => Errutil.Error_Msg,
Error_Msg_S => Errutil.Error_Msg_S,
Error_Msg_SC => Errutil.Error_Msg_SC,
Error_Msg_SP => Errutil.Error_Msg_SP,
Style => Errutil.Style);
-- Instantiation of the generic scanner
end Prj.Err;
gprbuild-gpl-2014-src/gnat/prj-dect.ads 0000644 0000767 0000145 00000006256 12323721731 017276 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . D E C T --
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2009, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Parse a list of declarative items in a project file
with Prj.Tree;
private package Prj.Dect is
procedure Parse
(In_Tree : Prj.Tree.Project_Node_Tree_Ref;
Declarations : out Prj.Tree.Project_Node_Id;
Current_Project : Prj.Tree.Project_Node_Id;
Extends : Prj.Tree.Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean;
Flags : Processing_Flags);
-- Parse project declarative items
--
-- In_Tree is the project node tree
--
-- Declarations is the resulting project node
--
-- Current_Project is the project node of the project for which the
-- declarative items are parsed.
--
-- Extends is the project node of the project that project Current_Project
-- extends. If project Current-Project does not extend any project,
-- Extends has the value Empty_Node.
--
-- Packages_To_Check is the list of packages that needs to be checked.
-- For legal packages declared in project Current_Project that are not in
-- Packages_To_Check, only the syntax of the declarations are checked, not
-- the attribute names and kinds.
--
-- Is_Config_File should be set to True if the project represents a config
-- file (.cgpr) since some specific checks apply.
end Prj.Dect;
gprbuild-gpl-2014-src/gnat/opt.ads 0000644 0000767 0000145 00000276237 12323721731 016400 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- O P T --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, 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 3, 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. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- .prep, if the source is preprocessed.
Generate_SCO : Boolean := False;
-- GNAT
-- True when switch -fdump-scos (or -gnateS) is used. When True, Source
-- Coverage Obligation (SCO) information is generated and output in the ALI
-- file. See unit Par_SCO for full details.
Generate_SCO_Instance_Table : Boolean := False;
-- GNAT
-- True when switch -fdebug-instances is used. When True, a table of
-- instances is included in SCOs.
Generating_Code : Boolean := False;
-- GNAT
-- True if the frontend finished its work and has called the backend to
-- process the tree and generate the object file.
Global_Discard_Names : Boolean := False;
-- GNAT, GNATBIND
-- True if a pragma Discard_Names appeared as a configuration pragma for
-- the current compilation unit.
GNAT_Mode : Boolean := False;
-- GNAT
-- True if compiling in GNAT system mode (-gnatg switch)
Heap_Size : Nat := 0;
-- GNATBIND
-- Heap size for memory allocations. Valid values are 32 and 64. Only
-- available on VMS.
Identifier_Character_Set : Character;
-- GNAT
-- This variable indicates the character set to be used for identifiers.
-- The possible settings are:
-- '1' Latin-1 (ISO-8859-1)
-- '2' Latin-2 (ISO-8859-2)
-- '3' Latin-3 (ISO-8859-3)
-- '4' Latin-4 (ISO-8859-4)
-- '5' Latin-Cyrillic (ISO-8859-5)
-- '9' Latin-9 (ISO-8859-15)
-- 'p' PC (US, IBM page 437)
-- '8' PC (European, IBM page 850)
-- 'f' Full upper set (all distinct)
-- 'n' No upper characters (Ada 83 rules)
-- 'w' Latin-1 plus wide characters allowed in identifiers
--
-- The setting affects the set of letters allowed in identifiers and the
-- upper/lower case equivalences. It does not affect the interpretation of
-- character and string literals, which are always stored using the actual
-- coding in the source program. This variable is initialized to the
-- default value appropriate to the system (in Osint.Initialize), and then
-- reset if a command line switch is used to change the setting.
Ignore_Rep_Clauses : Boolean := False;
-- GNAT
-- Set True to ignore all representation clauses. Useful when compiling
-- code from foreign compilers for checking or ASIS purposes. Can be
-- set True by use of -gnatI.
Ignore_Style_Checks_Pragmas : Boolean := False;
-- GNAT
-- Set True to ignore all Style_Checks pragmas. Can be set True by use
-- of -gnateY.
Ignore_Unrecognized_VWY_Switches : Boolean := False;
-- GNAT
-- Set True to ignore unrecognized y, V, w switches. Can be set True
-- by use of -gnateu, causing subsequent unrecognized switches to result
-- in a warning rather than an error.
Implementation_Unit_Warnings : Boolean := True;
-- GNAT
-- Set True to active warnings for use of implementation internal units.
-- Modified by use of -gnatwi/-gnatwI.
Implicit_Packing : Boolean := False;
-- GNAT
-- If set True, then a Size attribute clause on an array is allowed to
-- cause implicit packing instead of generating an error message. Set by
-- use of pragma Implicit_Packing.
Ineffective_Inline_Warnings : Boolean := False;
-- GNAT
-- Set True to activate warnings if front-end inlining (-gnatN) is not
-- able to actually inline a particular call (or all calls). Can be
-- controlled by use of -gnatwp/-gnatwP.
Init_Or_Norm_Scalars : Boolean := False;
-- GNAT, GANTBIND
-- Set True if a pragma Initialize_Scalars applies to the current unit.
-- Also set True if a pragma Restriction (Normalize_Scalars) applies.
Initialize_Scalars : Boolean := False;
-- GNAT
-- Set True if a pragma Initialize_Scalars applies to the current unit.
-- Note that Init_Or_Norm_Scalars is also set to True if this is True.
Initialize_Scalars_Mode1 : Character := 'I';
Initialize_Scalars_Mode2 : Character := 'N';
-- GNATBIND
-- Set to two characters from -S switch (IN/LO/HI/EV/xx). The default
-- is IN (invalid values), used if no -S switch is used.
Inline_Active : Boolean := False;
-- GNAT
-- Set True to activate pragma Inline processing across modules. Default
-- for now is not to inline across module boundaries.
Inline_Level : Nat := 0;
-- GNAT
-- Set to indicate the inlining level: 0 means that an appropriate value is
-- to be computed by the compiler based on the optimization level (-gnatn),
-- 1 is for moderate inlining across modules (-gnatn1) and 2 for full
-- inlining across modules (-gnatn2).
Interface_Library_Unit : Boolean := False;
-- GNATBIND
-- Set to True to indicate that at least one ALI file is an interface ALI:
-- then elaboration flag checks are to be generated in the binder
-- generated file.
Generate_SCIL : Boolean := False;
-- GNAT
-- Set True to activate SCIL code generation.
Invalid_Value_Used : Boolean := False;
-- GNAT
-- Set True if a valid Invalid_Value attribute is encountered
Follow_Links_For_Files : Boolean := False;
-- PROJECT MANAGER
-- Set to True (-eL) to process the project files in trusted mode. If
-- Follow_Links is False, it is assumed that the project doesn't contain
-- any file duplicated through symbolic links (although the latter are
-- still valid if they point to a file which is outside of the project),
-- and that no directory has a name which is a valid source name.
Follow_Links_For_Dirs : Boolean := False;
-- PROJECT MANAGER
-- Set to True if directories can be links in this project, and therefore
-- additional system calls must be performed to ensure that we always see
-- the same full name for each directory.
Front_End_Inlining : Boolean := False;
-- GNAT
-- Set True to activate inlining by front-end expansion
Inline_Processing_Required : Boolean := False;
-- GNAT
-- Set True if inline processing is required. Inline processing is required
-- if an active Inline pragma is processed. The flag is set for a pragma
-- Inline or Inline_Always that is actually active.
In_Place_Mode : Boolean := False;
-- GNATMAKE
-- Set True to store ALI and object files in place i.e. in the object
-- directory if these files already exist or in the source directory
-- if not.
Keep_Going : Boolean := False;
-- GNATMAKE, GPRMAKE, GPRBUILD
-- When True signals to ignore compilation errors and keep processing
-- sources until there is no more work.
Keep_Temporary_Files : Boolean := False;
-- GNATCMD
-- When True the temporary files created by the GNAT driver are not
-- deleted. Set by switch -dn or qualifier /KEEP_TEMPORARY_FILES.
Leap_Seconds_Support : Boolean := False;
-- GNATBIND
-- Set to True to enable leap seconds support in Ada.Calendar and its
-- children.
Link_Only : Boolean := False;
-- GNATMAKE, GPRMAKE, GPRBUILD
-- Set to True to skip compile and bind steps (except when Bind_Only is
-- set to True).
List_Body_Required_Info : Boolean := False;
-- GNATMAKE
-- List info messages about why a package requires a body. Modified by use
-- of -gnatw.y/.Y.
List_Inherited_Aspects : Boolean := False;
-- GNAT
-- List inherited invariants, preconditions, and postconditions from
-- Invariant'Class, Pre'Class, and Post'Class aspects. Also list inherited
-- subtype predicates. Modified by use of -gnatw.l/.L.
List_Restrictions : Boolean := False;
-- GNATBIND
-- Set to True to list restrictions pragmas that could apply to partition
List_Units : Boolean := False;
-- GNAT
-- List units in the active library for a compilation (-gnatu switch)
List_Closure : Boolean := False;
-- GNATBIND
-- List all sources in the closure of a main (-R or -Ra gnatbind switch)
List_Closure_All : Boolean := False;
-- GNATBIND
-- List all sources in closure of main including run-time units (-Ra
-- gnatbind switch).
List_Dependencies : Boolean := False;
-- GNATMAKE
-- When True gnatmake verifies that the objects are up to date and
-- outputs the list of object dependencies (-M switch).
-- Output depends if -a switch is used or not.
-- This list can be used directly in a Makefile.
List_Representation_Info : Int range 0 .. 3 := 0;
-- GNAT
-- Set non-zero by -gnatR switch to list representation information.
-- The settings are as follows:
--
-- 0 = no listing of representation information (default as above)
-- 1 = list rep info for user defined record and array types
-- 2 = list rep info for all user defined types and objects
-- 3 = like 2, but variable fields are decoded symbolically
List_Representation_Info_To_File : Boolean := False;
-- GNAT
-- Set true by -gnatRs switch. Causes information from -gnatR/1/2/3/m to be
-- written to file.rep (where file is the name of the source file) instead
-- of stdout. For example, if file x.adb is compiled using -gnatR2s then
-- representation info is written to x.adb.ref.
List_Representation_Info_Mechanisms : Boolean := False;
-- GNAT
-- Set true by -gnatRm switch. Causes information on mechanisms to be
-- included in the representation output information.
List_Preprocessing_Symbols : Boolean := False;
-- GNAT, GNATPREP
-- Set to True if symbols for preprocessing a source are to be listed
-- before preprocessing occurs. Set to True by switch -s of gnatprep or
-- -s in preprocessing data file for the compiler.
type Create_Repinfo_File_Proc is access procedure (Src : String);
type Write_Repinfo_Line_Proc is access procedure (Info : String);
type Close_Repinfo_File_Proc is access procedure;
-- Types used for procedure addresses below
Create_Repinfo_File_Access : Create_Repinfo_File_Proc := null;
Write_Repinfo_Line_Access : Write_Repinfo_Line_Proc := null;
Close_Repinfo_File_Access : Close_Repinfo_File_Proc := null;
-- GNAT
-- These three locations are left null when operating in non-compiler (e.g.
-- ASIS mode), but when operating in compiler mode, they are set to point
-- to the three corresponding procedures in Osint-C. The reason for this
-- slightly strange interface is to stop Repinfo from dragging in Osint in
-- ASIS mode, which would include lots of unwanted units in the ASIS build.
type Create_List_File_Proc is access procedure (S : String);
type Write_List_Info_Proc is access procedure (S : String);
type Close_List_File_Proc is access procedure;
-- Types used for procedure addresses below
Create_List_File_Access : Create_List_File_Proc := null;
Write_List_Info_Access : Write_List_Info_Proc := null;
Close_List_File_Access : Close_List_File_Proc := null;
-- GNAT
-- These three locations are left null when operating in non-compiler
-- (e.g. from the binder), but when operating in compiler mode, they are
-- set to point to the three corresponding procedures in Osint-C. The
-- reason for this slightly strange interface is to prevent Repinfo
-- from dragging in Osint-C in the binder, which would include unwanted
-- units in the binder.
Locking_Policy : Character := ' ';
-- GNAT, GNATBIND
-- Set to ' ' for the default case (no locking policy specified). Reset to
-- first character (uppercase) of locking policy name if a valid pragma
-- Locking_Policy is encountered.
Locking_Policy_Sloc : Source_Ptr := No_Location;
-- GNAT, GNATBIND
-- Remember location of previous Locking_Policy pragma. This is used for
-- inconsistency error messages. A value of System_Location is used if the
-- policy is set in package System.
Look_In_Primary_Dir : Boolean := True;
-- GNAT, GNATBIND, GNATMAKE, GNATCLEAN
-- Set to False if a -I- was present on the command line. When True we are
-- allowed to look in the primary directory to locate other source or
-- library files.
Make_Steps : Boolean := False;
-- GNATMAKE
-- Set to True when either Compile_Only, Bind_Only or Link_Only is
-- set to True.
Main_Index : Int := 0;
-- GNATMAKE
-- This is set to non-zero by gnatmake switch -eInnn to indicate that
-- the main program is the nnn unit in a multi-unit source file.
Mapping_File_Name : String_Ptr := null;
-- GNAT
-- File name of mapping between unit names, file names and path names.
-- (given by switch -gnatem)
Maximum_Messages : Int := 9999;
-- GNAT, GNATBIND
-- Maximum default number of errors before compilation is terminated, or in
-- the case of GNAT, maximum number of warnings before further warnings are
-- suppressed. Can be overridden by -gnatm (GNAT) or -m (GNATBIND) switch.
Maximum_File_Name_Length : Int;
-- GNAT, GNATBIND
-- Maximum number of characters allowed in a file name, not counting the
-- extension, as set by the appropriate switch. If no switch is given,
-- then this value is initialized by Osint to the appropriate value.
Maximum_Instantiations : Int := 8000;
-- GNAT
-- Maximum number of instantiations permitted (to stop runaway cases
-- of nested instantiations). These situations probably only occur in
-- specially concocted test cases. Can be modified by -gnateinn switch.
Maximum_Processes : Positive := 1;
-- GNATMAKE, GPRMAKE, GPRBUILD
-- Maximum number of processes that should be spawned to carry out
-- compilations.
Minimal_Recompilation : Boolean := False;
-- GNATMAKE
-- Set to True if minimal recompilation mode requested
Modify_Tree_For_C : Boolean := False;
-- GNAT
-- If this switch is set True (currently it is set only by -gnatd.V), then
-- certain meaning-preserving transformations are applied to the tree to
-- make it easier to interface with back ends that implement C semantics.
-- There is a section in Sinfo which describes the transformations made.
Multiple_Unit_Index : Int := 0;
-- GNAT
-- This is set non-zero if the current unit is being compiled in multiple
-- unit per file mode, meaning that the current unit is selected from the
-- sequence of units in the current source file, using the value stored
-- in this variable (e.g. 2 = select second unit in file). A value of
-- zero indicates that we are in normal (one unit per file) mode.
No_Backup : Boolean := False;
-- GNATNAME
-- Do not create backup copies of project files. Set by switch --no-backup.
No_Deletion : Boolean := False;
-- GNATPREP
-- Set by preprocessor switch -a. Do not eliminate any source text. Implies
-- Undefined_Symbols_Are_False. Useful to perform a syntax check on all
-- branches of #if constructs.
No_Main_Subprogram : Boolean := False;
-- GNATMAKE, GNATBIND
-- Set to True if compilation/binding of a program without main
-- subprogram requested.
No_Run_Time_Mode : Boolean := False;
-- GNAT, GNATBIND
-- This flag is set True if a No_Run_Time pragma is encountered. See
-- spec of Rtsfind for a full description of handling of this pragma.
No_Split_Units : Boolean := False;
-- GPRBUILD
-- Set to True with switch --no-split-units. When True, unit sources, spec,
-- body and subunits, must all be in the same project. This is checked
-- after each compilation.
No_Stdinc : Boolean := False;
-- GNAT, GNATBIND, GNATMAKE, GNATFIND, GNATXREF
-- Set to True if no default source search dirs added to search list.
No_Stdlib : Boolean := False;
-- GNATMAKE, GNATBIND, GNATFIND, GNATXREF
-- Set to True if no default library search dirs added to search list.
No_Strict_Aliasing : Boolean := False;
-- GNAT
-- Set True if pragma No_Strict_Aliasing with no parameters encountered.
Normalize_Scalars : Boolean := False;
-- GNAT, GNATBIND
-- Set True if a pragma Normalize_Scalars applies to the current unit.
-- Note that Init_Or_Norm_Scalars is also set to True if this is True.
Object_Directory_Present : Boolean := False;
-- GNATMAKE
-- Set to True when an object directory is specified with option -D
Object_Path_File_Name : String_Ptr := null;
-- GNAT2WHY
-- Path of the temporary file that contains a list of object directories
-- passed by -gnateO=.
One_Compilation_Per_Obj_Dir : Boolean := False;
-- GNATMAKE, GPRBUILD
-- Set to True with switch --single-compile-per-obj-dir. When True, there
-- cannot be simultaneous compilations with the object files in the same
-- object directory, if project files are used.
type Operating_Mode_Type is (Check_Syntax, Check_Semantics, Generate_Code);
pragma Ordered (Operating_Mode_Type);
Operating_Mode : Operating_Mode_Type := Generate_Code;
-- GNAT
-- Indicates the operating mode of the compiler. The default is generate
-- code, which runs the parser, semantics and backend. Switches can be
-- used to set syntax checking only mode, or syntax and semantics checking
-- only mode. Operating_Mode can also be modified as a result of detecting
-- errors during the compilation process. In particular if any serious
-- error is detected then this flag is reset from Generate_Code to
-- Check_Semantics after generating an error message. This is an ordered
-- type with the semantics that each value does more than the previous one.
Optimize_Alignment : Character := 'O';
-- Setting of Optimize_Alignment, set to T/S/O for time/space/off. Can
-- be modified by use of pragma Optimize_Alignment.
Optimize_Alignment_Local : Boolean := False;
-- Set True if Optimize_Alignment mode is set by a local configuration
-- pragma that overrides the gnat.adc (or other configuration file) default
-- so that the unit is not dependent on the default setting. Also always
-- set True for internal units, since these always have a default setting
-- of Optimize_Alignment (Off) that is enforced (essentially equivalent to
-- them all having such an explicit pragma in each unit).
Original_Operating_Mode : Operating_Mode_Type := Generate_Code;
-- GNAT
-- Indicates the original operating mode of the compiler as set by compiler
-- options. This is identical to Operating_Mode except that this is not
-- affected by errors.
Optimization_Level : Int;
pragma Import (C, Optimization_Level, "optimize");
-- Constant reflecting the optimization level (0,1,2,3 for -O0,-O1,-O2,-O3)
-- See jmissing.c and aamissing.c for definitions for dotnet/jgnat and
-- GNAAMP back ends.
Optimize_Size : Int;
pragma Import (C, Optimize_Size, "optimize_size");
-- Constant reflecting setting of -Os (optimize for size). Set to nonzero
-- in -Os mode and set to zero otherwise. See jmissing.c and aamissing.c
-- for definitions of "optimize_size" for dotnet/jgnat and GNAAMP backends
Output_File_Name_Present : Boolean := False;
-- GNATBIND, GNAT, GNATMAKE, GPRMAKE
-- Set to True when the output C file name is given with option -o for
-- GNATBIND, when the object file name is given with option -gnatO for GNAT
-- or when the executable is given with option -o for GNATMAKE or GPRMAKE.
Output_Linker_Option_List : Boolean := False;
-- GNATBIND
-- True if output of list of linker options is requested (-K switch set)
Output_ALI_List : Boolean := False;
ALI_List_Filename : String_Ptr;
-- GNATBIND
-- True if output of list of ALIs is requested (-A switch set). List is
-- output under the given filename, or standard output if not specified.
Output_Object_List : Boolean := False;
Object_List_Filename : String_Ptr;
-- GNATBIND
-- True if output of list of objects is requested (-O switch set). List is
-- output under the given filename, or standard output if not specified.
Partition_Elaboration_Policy : Character := ' ';
-- GNAT, GNATBIND
-- Set to ' ' for the default case (no elaboration policy specified). Reset
-- to first character (uppercase) of locking policy name if a valid pragma
-- Partition_Elaboration_Policy is encountered.
Partition_Elaboration_Policy_Sloc : Source_Ptr := No_Location;
-- GNAT, GNATBIND
-- Remember location of previous Partition_Elaboration_Policy pragma. This
-- is used for inconsistency error messages. A value of System_Location is
-- used if the policy is set in package System.
Persistent_BSS_Mode : Boolean := False;
-- GNAT
-- True if a Persistent_BSS configuration pragma is in effect, causing
-- potentially persistent data to be placed in the persistent_bss section.
Pessimistic_Elab_Order : Boolean := False;
-- GNATBIND
-- True if pessimistic elaboration order is to be chosen (-p switch set)
Polling_Required : Boolean := False;
-- GNAT
-- Set to True if polling for asynchronous abort is enabled by using
-- the -gnatP option for GNAT.
Preprocessing_Data_File : String_Ptr := null;
-- GNAT
-- Set by switch -gnatep=. The file name of the preprocessing data file.
Preprocessing_Symbol_Defs : String_List_Access := new String_List (1 .. 4);
-- An extensible array to temporarily stores symbol definitions specified
-- on the command line with -gnateD switches.
-- What is this magic constant 4 ???
-- What is extensible about this fixed length array ???
Preprocessing_Symbol_Last : Natural := 0;
-- Index of last symbol definition in array Symbol_Definitions
Print_Generated_Code : Boolean := False;
-- GNAT
-- Set to True to enable output of generated code in source form. This
-- flag is set by the -gnatG switch.
Print_Standard : Boolean := False;
-- GNAT
-- Set to true to enable printing of package standard in source form.
-- This flag is set by the -gnatS switch
type Usage is (Unknown, Not_In_Use, In_Use);
Project_File_In_Use : Usage := Unknown;
-- GNAT
-- Indicates if a project file is used or not. Set to In_Use by the first
-- SFNP pragma.
Queuing_Policy : Character := ' ';
-- GNAT, GNATBIND
-- Set to ' ' for the default case (no queuing policy specified). Reset to
-- first character (uppercase) of locking policy name if a valid
-- Queuing_Policy pragma is encountered.
Queuing_Policy_Sloc : Source_Ptr := No_Location;
-- GNAT, GNATBIND
-- Remember location of previous Queuing_Policy pragma. This is used for
-- inconsistency error messages. A value of System_Location is used if the
-- policy is set in package System.
Quiet_Output : Boolean := False;
-- GNATMAKE, GNATCLEAN, GPRMAKE, GPRBUILD, GPRCLEAN
-- Set to True if the tool should not have any output if there are no
-- errors or warnings.
Overriding_Renamings : Boolean := False;
-- GNAT
-- Set to True to enable compatibility mode with Rational compiler, and
-- to accept renamings of implicit operations in their own scope.
Relaxed_RM_Semantics : Boolean := False;
-- GNAT
-- Set to True to ignore some Ada semantic error to help parse legacy
-- Ada code for use in e.g. static analysis (such as CodePeer). This
-- deals with cases where other compilers allow illegal constructs. Tools
-- such as CodePeer are interested in analyzing code rather than enforcing
-- legality rules, so as long as these illegal constructs end up with code
-- that can be handled by the tool in question, there is no reason to
-- reject the code that is considered correct by the other compiler.
Replace_In_Comments : Boolean := False;
-- GNATPREP
-- Set to True if -C switch used.
RTS_Lib_Path_Name : String_Ptr := null;
RTS_Src_Path_Name : String_Ptr := null;
-- GNAT
-- Set to the "adalib" and "adainclude" directories of the run time
-- specified by --RTS=.
RTS_Switch : Boolean := False;
-- GNAT, GNATMAKE, GNATBIND, GNATLS, GNATFIND, GNATXREF
-- Set to True when the --RTS switch is set
Run_Path_Option : Boolean := True;
-- GNATMAKE, GNATLINK
-- Set to False when no run_path_option should be issued to the linker
Search_Directory_Present : Boolean := False;
-- GNAT
-- Set to True when argument is -I. Reset to False when next argument, a
-- search directory path is taken into account. Note that this is quite
-- different from other switches in this section in that it is only set in
-- a transitory manner as a result of scanning a -I switch with no file
-- name, and if set, is an indication that the next argument is to be
-- treated as a file name.
Sec_Stack_Used : Boolean := False;
-- GNAT, GBATBIND
-- Set True if generated code uses the System.Secondary_Stack package. For
-- the binder, set if any unit uses the secondary stack package.
Setup_Projects : Boolean := False;
-- GNAT DRIVER
-- Set to True for GNAT SETUP: the Project Manager creates non existing
-- object, library and exec directories.
Shared_Libgnat : Boolean;
-- GNATBIND
-- Set to True if a shared libgnat is requested by using the -shared option
-- for GNATBIND and to False when using the -static option. The value of
-- this flag is set by Gnatbind.Scan_Bind_Arg.
Short_Circuit_And_Or : Boolean := False;
-- GNAT
-- Set True if a pragma Short_Circuit_And_Or applies to the current unit.
Short_Descriptors : Boolean := False;
-- GNAT
-- Set True if a pragma Short_Descriptors applies to the current unit.
type SPARK_Mode_Type is (None, Off, On);
-- Possible legal modes that can be set by aspect/pragma SPARK_Mode, as
-- well as the value None, which indicates no such pragma/aspect applies.
SPARK_Mode : SPARK_Mode_Type := None;
-- GNAT
-- Current SPARK mode setting.
SPARK_Mode_Pragma : Node_Id := Empty;
-- GNAT
-- If the current SPARK_Mode (above) was set by a pragma, this records
-- the pragma that set this mode.
SPARK_Switches_File_Name : String_Ptr := null;
-- GNAT
-- Set to non-null file name by use of the -gnates switch to specify
-- SPARK (gnat2why) specific switches in the given file name.
Special_Exception_Package_Used : Boolean := False;
-- GNAT
-- Set to True if either of the unit GNAT.Most_Recent_Exception or
-- GNAT.Exception_Traces is with'ed. Used to inhibit transformation of
-- local raise statements into gotos in the presence of either package.
Sprint_Line_Limit : Nat := 72;
-- GNAT
-- Limit values for chopping long lines in Cprint/Sprint output, can be
-- reset by use of NNN parameter with -gnatG or -gnatD switches.
Stack_Checking_Enabled : Boolean := False;
-- GNAT
-- Set to indicate if stack checking is enabled for the compilation. This
-- is set directly from the value in the gcc back end in the body of the
-- gcc version of back_end.adb.
Style_Check : Boolean := False;
-- GNAT
-- Set True to perform style checks. Activates checks carried out in
-- package Style (see body of this package for details of checks). This
-- flag is set True by use of either the -gnatg or -gnaty switches, or
-- by the Style_Check pragma.
Style_Check_Main : Boolean := False;
-- GNAT
-- Set True if Style_Check was set for the main unit. This is used to
-- renable style checks for units in the mail extended source that get
-- with'ed indirectly. It is set True by use of either the -gnatg or
-- -gnaty switches, but not by use of the Style_Checks pragma.
Suppress_All_Inlining : Boolean := False;
-- GNAT
-- Set by -fno-inline. Suppresses all inlining, both front end and back end
-- regardless of any other switches that are set.
Suppress_Control_Flow_Optimizations : Boolean := False;
-- GNAT
-- Set by -fpreserve-control-flow. Suppresses control flow optimizations
-- that interfere with coverage analysis based on the object code.
System_Extend_Pragma_Arg : Node_Id := Empty;
-- GNAT
-- Set non-empty if and only if a correct Extend_System pragma was present
-- in which case it points to the argument of the pragma, and the name can
-- be located as Chars (Expression (System_Extend_Pragma_Arg)).
System_Extend_Unit : Node_Id := Empty;
-- GNAT
-- This is set to Empty if GNAT_Mode is set, since pragma Extend_System
-- is never appropriate in GNAT_Mode (and causes troubles, including
-- bogus circularities, if we try to compile the run-time library with
-- a System extension). If GNAT_Mode is not set, then System_Extend_Unit
-- is a copy of the value set in System_Extend_Pragma_Arg.
Subunits_Missing : Boolean := False;
-- GNAT
-- This flag is set true if missing subunits are detected with code
-- generation active. This causes code generation to be skipped.
Suppress_Checks : Boolean := False;
-- GNAT
-- Set to True if -gnatp (suppress all checks) switch present.
Suppress_Options : Suppress_Record;
-- GNAT
-- Indicates outer level setting of check suppression. This initializes
-- the settings of the outer scope level in any unit compiled. This is
-- initialized by Osint.Initialize, and further initialized by the
-- Adjust_Global_Switches flag in Gnat1drv.
Table_Factor : Int := 1;
-- GNAT
-- Factor by which all initial table sizes set in Alloc are multiplied.
-- Used in Table to calculate initial table sizes (the initial table size
-- is the value in Alloc, used as the Table_Initial parameter value,
-- multiplied by the factor given here. The default value is used if no
-- -gnatT switch appears.
Tagged_Type_Expansion : Boolean := True;
-- GNAT
-- Set True if tagged types and interfaces should be expanded by the
-- front-end. If False, the original tree is left unexpanded for tagged
-- types and dispatching calls, assuming the underlying target supports
-- it (e.g. in the JVM case).
Target_Dependent_Info_Read_Name : String_Ptr := null;
-- GNAT
-- Set non-null to override the normal processing in Get_Targ and set the
-- necessary information by reading the target dependent information file
-- whose name is given here (see packages Get_Targ and Set_Targ for full
-- details). Set to non-null file name by use of the -gnateT switch.
Target_Dependent_Info_Write_Name : String_Ptr := null;
-- GNAT
-- Set non-null to enable a call to Set_Targ.Write_Target_Dependent_Info
-- which writes a target independent information file (see packages
-- Get_Targ and Set_Targ for full details) using the name given by
-- this switch. Set to non-null file name by use of the -gnatet switch.
Task_Dispatching_Policy : Character := ' ';
-- GNAT, GNATBIND
-- Set to ' ' for the default case (no task dispatching policy specified).
-- Reset to first character (uppercase) of task dispatching policy name
-- if a valid Task_Dispatching_Policy pragma is encountered.
Task_Dispatching_Policy_Sloc : Source_Ptr := No_Location;
-- GNAT, GNATBIND
-- Remember location of previous Task_Dispatching_Policy pragma. This is
-- used for inconsistency error messages. A value of System_Location is
-- used if the policy is set in package System.
Tasking_Used : Boolean := False;
-- Set True if any tasking construct is encountered. Used to activate the
-- output of the Q, L and T lines in ALI files.
Time_Slice_Set : Boolean := False;
-- GNATBIND
-- Set True if a pragma Time_Slice is processed in the main unit, or
-- if the -gnatTnn switch is present to set a time slice value.
Time_Slice_Value : Nat;
-- GNATBIND
-- Time slice value. Valid only if Time_Slice_Set is True, i.e. if
-- Time_Slice pragma has been processed. Set to the time slice value in
-- microseconds. Negative values are stored as zero, and the value is not
-- larger than 1_000_000_000 (1000 seconds). Values larger than this are
-- reset to this maximum. This can also be set with the -gnatTnn switch.
Tolerate_Consistency_Errors : Boolean := False;
-- GNATBIND
-- Tolerate time stamp and other consistency errors. If this flag is set to
-- True (-t), then inconsistencies result in warnings rather than errors.
Treat_Categorization_Errors_As_Warnings : Boolean := False;
-- Normally categorization errors are true illegalities. If this switch
-- is set, then such errors result in warning messages rather than error
-- messages. Set True by -gnateP (P for Pure/Preelaborate). Also set in
-- Relaxed_RM_Semantics mode since some old Ada 83 compilers treated
-- pragma Preelaborate differently.
Treat_Restrictions_As_Warnings : Boolean := False;
-- GNAT
-- Set True to treat pragma Restrictions as Restriction_Warnings. Set by
-- -gnatr switch.
Tree_Output : Boolean := False;
-- GNAT
-- Set to True (-gnatt) to generate output tree file
True_VMS_Target : Boolean := False;
-- Set True if we are on a VMS target. The setting of this flag reflects
-- the true state of the compile, unlike Targparm.OpenVMS_On_Target which
-- can also be true when debug flag m is set (-gnatdm). This is used in the
-- few cases where we do NOT want -gnatdm to trigger the VMS behavior.
Try_Semantics : Boolean := False;
-- GNAT
-- Flag set to force attempt at semantic analysis, even if parser errors
-- occur. This will probably cause blowups at this stage in the game. On
-- the other hand, most such blowups will be caught cleanly and simply
-- say compilation abandoned. This flag is set True by -gnatq or -gnatQ.
Unchecked_Shared_Lib_Imports : Boolean := False;
-- GPRBUILD
-- Set to True when shared library projects are allowed to import projects
-- that are not shared library projects. Set on by use of the switch
-- --unchecked-shared-lib-imports.
Undefined_Symbols_Are_False : Boolean := False;
-- GNAT, GNATPREP
-- Set to True by switch -u of gnatprep or -u in the preprocessing data
-- file for the compiler. Indicates that while preprocessing sources,
-- symbols that are not defined have the value FALSE.
Uneval_Old : Character := 'E';
-- GNAT
-- Set to 'E'/'W'/'A' for use of Error/Warn/Allow in a valid pragma
-- Unevaluated_Use_Of_Old. Default in the absence of the pragma is 'E'
-- for the RM default behavior of giving an error.
Unique_Error_Tag : Boolean := Tag_Errors;
-- GNAT
-- Indicates if error messages are to be prefixed by the string error:
-- Initialized from Tag_Errors, can be forced on with the -gnatU switch.
Universal_Addressing_On_AAMP : Boolean := False;
-- GNAAMP
-- Indicates if library-level objects should be accessed and updated using
-- universal addressing instructions on the AAMP architecture. This flag is
-- set to True when pragma Universal_Data is given as a configuration
-- pragma.
Unreserve_All_Interrupts : Boolean := False;
-- GNAT, GNATBIND
-- Normally set False, set True if a valid Unreserve_All_Interrupts pragma
-- appears anywhere in the main unit for GNAT, or if any ALI file has the
-- corresponding attribute set in GNATBIND.
Upper_Half_Encoding : Boolean := False;
-- GNAT, GNATBIND
-- Normally set False, indicating that upper half ISO 8859-1 characters are
-- used in the normal way to represent themselves. If the wide character
-- encoding method uses the upper bit for this encoding, then this flag is
-- set True, and upper half characters in the source indicate the start of
-- a wide character sequence. Set by -gnatW or -W switches.
Use_Include_Path_File : Boolean := False;
-- GNATMAKE, GPRBUILD
-- When True, create a source search path file, even when a mapping file
-- is used.
Usage_Requested : Boolean := False;
-- GNAT, GNATBIND, GNATMAKE
-- Set to True if -h (-gnath for the compiler) switch encountered
-- requesting usage information
Use_Pragma_Linker_Constructor : Boolean := False;
-- GNATBIND
-- True if pragma Linker_Constructor applies to adainit
Use_VADS_Size : Boolean := False;
-- GNAT
-- Set to True if a valid pragma Use_VADS_Size is processed
Validity_Checks_On : Boolean := True;
-- GNAT
-- This flag determines if validity checking is on or off. The initial
-- state is on, and the required default validity checks are active. The
-- actual set of checks that is performed if Validity_Checks_On is set is
-- defined by the switches in package Validsw. The Validity_Checks_On flag
-- is controlled by pragma Validity_Checks (On | Off), and also some
-- generated compiler code (typically code that has to do with validity
-- check generation) is compiled with this flag set to False. This flag is
-- set to False by the -gnatp switch.
Verbose_Mode : Boolean := False;
-- GNAT, GNATBIND, GNATMAKE, GNATLINK, GNATLS, GNATNAME, GNATCLEAN,
-- GPRMAKE, GPRBUILD, GPRCLEAN
-- Set to True to get verbose mode (full error message text and location
-- information sent to standard output, also header, copyright and summary)
type Verbosity_Level_Type is (None, Low, Medium, High);
pragma Ordered (Verbosity_Level_Type);
Verbosity_Level : Verbosity_Level_Type := High;
-- GNATMAKE, GPRMAKE
-- Modified by gnatmake or gprmake switches -v, -vl, -vm, -vh. Indicates
-- the level of verbosity of informational messages:
--
-- In Low Verbosity, the reasons why a source is recompiled, the name
-- of the executable and the reason it must be rebuilt is output.
--
-- In Medium Verbosity, additional lines are output for each ALI file
-- that is checked.
--
-- In High Verbosity, additional lines are output when the ALI file
-- is part of an Ada library, is read-only or is part of the runtime.
Warn_On_Ada_2005_Compatibility : Boolean := True;
-- GNAT
-- Set to True to generate all warnings on Ada 2005 compatibility issues,
-- including warnings on Ada 2005 obsolescent features used in Ada 2005
-- mode. Set by default, modified by use of -gnatwy/Y.
Warn_On_Ada_2012_Compatibility : Boolean := True;
-- GNAT
-- Set to True to generate all warnings on Ada 2012 compatibility issues,
-- including warnings on Ada 2012 obsolescent features used in Ada 2012
-- mode. Modified by use of -gnatwy/Y.
Warn_On_All_Unread_Out_Parameters : Boolean := False;
-- GNAT
-- Set to True to generate warnings in all cases where a variable is
-- modified by being passed as to an OUT formal, but the resulting value is
-- never read. The default is that this warning is suppressed. Modified
-- by use of gnatw.o/.O.
Warn_On_Assertion_Failure : Boolean := True;
-- GNAT
-- Set to True to activate warnings on assertions that can be determined
-- at compile time will always fail. Modified by use of -gnatw.a/.A.
Warn_On_Assumed_Low_Bound : Boolean := True;
-- GNAT
-- Set to True to activate warnings for string parameters that are indexed
-- with literals or S'Length, presumably assuming a lower bound of one.
-- Modified by use of -gnatww/W.
Warn_On_Atomic_Synchronization : Boolean := False;
-- GNAT
-- Set to True to generate information messages for atomic synchronization.
-- Modified by use of -gnatw.n/.N.
Warn_On_Bad_Fixed_Value : Boolean := False;
-- GNAT
-- Set to True to generate warnings for static fixed-point expression
-- values that are not an exact multiple of the small value of the type.
-- Odd by default, modified by use of -gnatwb/B.
Warn_On_Biased_Representation : Boolean := True;
-- GNAT
-- Set to True to generate warnings for size clauses, component clauses
-- and component_size clauses that force biased representation. Modified
-- by use of -gnatw.b/.B.
Warn_On_Constant : Boolean := False;
-- GNAT
-- Set to True to generate warnings for variables that could be declared
-- as constants. Modified by use of -gnatwk/K.
Warn_On_Deleted_Code : Boolean := False;
-- GNAT
-- Set to True to generate warnings for code deleted by the front end
-- for conditional statements whose outcome is known at compile time.
-- Modified by use of -gnatwt/T.
Warn_On_Dereference : Boolean := False;
-- GNAT
-- Set to True to generate warnings for implicit dereferences for array
-- indexing and record component access. Modified by use of -gnatwd/D.
Warn_On_Export_Import : Boolean := True;
-- GNAT
-- Set to True to generate warnings for suspicious use of export or
-- import pragmas. Modified by use of -gnatwx/X.
Warn_On_Hiding : Boolean := False;
-- GNAT
-- Set to True to generate warnings if a declared entity hides another
-- entity. The default is that this warning is suppressed. Modified by
-- use of -gnatwh/H.
Warn_On_Modified_Unread : Boolean := False;
-- GNAT
-- Set to True to generate warnings if a variable is assigned but is never
-- read. Also controls warnings for similar cases involving out parameters,
-- but only if there is only one out parameter for the procedure involved.
-- The default is that this warning is suppressed, modified by use of
-- -gnatwm/M.
Warn_On_No_Value_Assigned : Boolean := True;
-- GNAT
-- Set to True to generate warnings if no value is ever assigned to a
-- variable that is at least partially uninitialized. Set to false to
-- suppress such warnings. The default is that such warnings are enabled.
-- Modified by use of -gnatwv/V.
Warn_On_Non_Local_Exception : Boolean := False;
-- GNAT
-- Set to True to generate warnings for non-local exception raises and also
-- handlers that can never handle a local raise. This warning is only ever
-- generated if pragma Restrictions (No_Exception_Propagation) is set. The
-- default is not to generate the warnings except that if the source has
-- at least one exception handler, and this restriction is set, and the
-- warning was not explicitly turned off, then it is turned on by default.
-- Modified by use of -gnatw.x/.X.
No_Warn_On_Non_Local_Exception : Boolean := False;
-- GNAT
-- This is set to True if the above warning is explicitly suppressed. We
-- use this to avoid turning it on by default when No_Exception_Propagation
-- restriction is set and an exception handler is present.
Warn_On_Object_Renames_Function : Boolean := False;
-- GNAT
-- Set to True to generate warnings when a function result is renamed as
-- an object. The default is that this warning is disabled. Modified by
-- use of -gnatw.r/.R.
Warn_On_Obsolescent_Feature : Boolean := False;
-- GNAT
-- Set to True to generate warnings on use of any feature in Annex or if a
-- subprogram is called for which a pragma Obsolescent applies. Modified
-- by use of -gnatwj/J.
Warn_On_Overlap : Boolean := False;
-- GNAT
-- Set to True to generate warnings when a writable actual overlaps with
-- another actual in a subprogram call. This applies only in modes before
-- Ada 2012. Starting with Ada 2012, such overlaps are illegal.
-- Modified by use of -gnatw.i/.I.
Warn_On_Questionable_Missing_Parens : Boolean := True;
-- GNAT
-- Set to True to generate warnings for cases where parentheses are missing
-- and the usage is questionable, because the intent is unclear. On by
-- default, modified by use of -gnatwq/Q.
Warn_On_Parameter_Order : Boolean := False;
-- GNAT
-- Set to True to generate warnings for cases where the argument list for
-- a call is a sequence of identifiers that match the formal identifiers,
-- but are in the wrong order.
Warn_On_Redundant_Constructs : Boolean := False;
-- GNAT
-- Set to True to generate warnings for redundant constructs (e.g. useless
-- assignments/conversions). The default is that this warning is disabled.
-- Modified by use of -gnatwr/R.
Warn_On_Reverse_Bit_Order : Boolean := True;
-- GNAT
-- Set to True to generate warning (informational) messages for component
-- clauses that are affected by non-standard bit-order. The default is
-- that this warning is enabled. Modified by -gnatw.v/.V.
Warn_On_Suspicious_Contract : Boolean := True;
-- GNAT
-- Set to True to generate warnings for suspicious contracts expressed as
-- pragmas or aspects precondition and postcondition. The default is that
-- this warning is enabled. Modified by use of -gnatw.t/.T.
Warn_On_Suspicious_Modulus_Value : Boolean := True;
-- GNAT
-- Set to True to generate warnings for suspicious modulus values. The
-- default is that this warning is enabled. Modified by -gnatw.m/.M.
Warn_On_Unchecked_Conversion : Boolean := True;
-- GNAT
-- Set to True to generate warnings for unchecked conversions that may have
-- non-portable semantics (e.g. because sizes of types differ). Modified
-- by use of -gnatwz/Z.
Warn_On_Unordered_Enumeration_Type : Boolean := False;
-- GNAT
-- Set to True to generate warnings for inappropriate uses (comparisons
-- and explicit ranges) on unordered enumeration types (which includes
-- all enumeration types for which pragma Ordered is not given). The
-- default is that this warning is disabled. Modified by -gnat.u/.U.
Warn_On_Unrecognized_Pragma : Boolean := True;
-- GNAT
-- Set to True to generate warnings for unrecognized pragmas. The default
-- is that this warning is enabled. Modified by use of -gnatwg/G.
Warn_On_Unrepped_Components : Boolean := False;
-- GNAT
-- Set to True to generate warnings for the case of components of record
-- which have a record representation clause but this component does not
-- have a component clause. Modified by use of -gnatw.c/.C.
Warn_On_Warnings_Off : Boolean := False;
-- GNAT
-- Set to True to generate warnings for use of Pragma Warnings (Off, ent),
-- where either the pragma is never used, or it could be replaced by a
-- pragma Unmodified or Unreferenced. Also generates warnings for pragma
-- Warning (Off, string) which either has no matching pragma Warning On,
-- or where no warning has been suppressed by the use of the pragma.
-- Modified by use of -gnatw.w/.W.
type Warning_Mode_Type is (Suppress, Normal, Treat_As_Error);
Warning_Mode : Warning_Mode_Type := Normal;
-- GNAT, GNATBIND
-- Controls treatment of warning messages. If set to Suppress, warning
-- messages are not generated at all. In Normal mode, they are generated
-- but do not count as errors. In Treat_As_Error mode, warning messages are
-- generated and are treated as errors. Note that Warning_Mode = Suppress
-- causes pragma Warnings to be ignored (except for legality checks),
-- unless we are in GNATprove_Mode, which requires pragma Warnings to
-- be stored for the formal verification backend.
Warnings_As_Errors_Count : Natural;
-- GNAT
-- Number of entries stored in Warnings_As_Errors table
Wide_Character_Encoding_Method : WC_Encoding_Method := WCEM_Brackets;
-- GNAT, GNATBIND
-- Method used for encoding wide characters in the source program. See
-- description of type in unit System.WCh_Con for a list of the methods
-- that are currently supported. Note that brackets notation is always
-- recognized in source programs regardless of the setting of this
-- variable. The default setting causes only the brackets notation to be
-- recognized. If this is the main unit, this setting also controls the
-- output of the W=? parameter in the ALI file, which is used to provide
-- the default for encoding [Wide_[Wide_]]Text_IO files. For the binder,
-- the value set here overrides this main unit default.
Wide_Character_Encoding_Method_Specified : Boolean := False;
-- GNAT, GNATBIND
-- Set True if the value in Wide_Character_Encoding_Method was set as
-- a result of an explicit -gnatW? or -W? switch. False otherwise.
Xref_Active : Boolean := True;
-- GNAT
-- Set if cross-referencing is enabled (i.e. xref info in ALI files)
Zero_Formatting : Boolean := False;
-- GNATBIND
-- Do no formatting (no title, no leading spaces, no empty lines) in
-- auxiliary outputs (-e, -K, -l, -R).
----------------------------
-- Configuration Settings --
----------------------------
-- These are settings that are used to establish the mode at the start of
-- each unit. The values defined below can be affected either by command
-- line switches, or by the use of appropriate configuration pragmas in a
-- configuration pragma file (but NOT by a local use of a configuration
-- pragma in a single file).
Ada_Version_Config : Ada_Version_Type;
-- GNAT
-- This is the value of the configuration switch for the Ada 83 mode, as
-- set by the command line switches -gnat83/95/2005/2012, and possibly
-- modified by the use of configuration pragmas Ada_*. This switch is used
-- to set the initial value for Ada_Version mode at the start of analysis
-- of a unit. Note however that the setting of this flag is ignored for
-- internal and predefined units (which are always compiled in the most up
-- to date version of Ada).
Ada_Version_Pragma_Config : Node_Id;
-- This will be set non empty if it is set by a configuration pragma
Ada_Version_Explicit_Config : Ada_Version_Type;
-- GNAT
-- This is set in the same manner as Ada_Version_Config. The difference is
-- that the setting of this flag is not ignored for internal and predefined
-- units, which for some purposes do indeed access this value, regardless
-- of the fact that they are compiled the most up to date ada version).
Assertions_Enabled_Config : Boolean;
-- GNAT
-- This is the value of the configuration switch for assertions enabled
-- mode, as possibly set by the command line switch -gnata, and possibly
-- modified by the use of the configuration pragma Assertion_Policy.
Assume_No_Invalid_Values_Config : Boolean;
-- GNAT
-- This is the value of the configuration switch for assuming "no invalid
-- values enabled" mode, as possibly set by the command line switch
-- -gnatB, and possibly modified by the use of the configuration pragma
-- Assume_No_Invalid_Values.
Check_Float_Overflow_Config : Boolean;
-- GNAT
-- Set to True to check that operations on predefined unconstrained float
-- types (e.g. Float, Long_Float) do not overflow and generate infinities
-- or invalid values. Set by the Check_Float_Overflow pragma, or by use
-- of the -gnateF switch.
Check_Policy_List_Config : Node_Id;
-- GNAT
-- This points to the list of N_Pragma nodes for Check_Policy pragmas
-- that are linked through the Next_Pragma fields, with the list being
-- terminated by Empty. The order is most recently processed first. This
-- list includes only those pragmas in configuration pragma files.
Default_Pool_Config : Node_Id := Empty;
-- GNAT
-- Same as Default_Pool above, except this is only for Default_Storage_Pool
-- pragmas that are configuration pragmas.
Default_SSO_Config : Character := ' ';
-- GNAT
-- Set if a pragma Default_Scalar_Storage_Order appears as a configuration
-- pragma. A value of ' ' means that no pragma was given, otherwise the
-- value is 'H' for High_Order_First or 'L' for Low_Order_First.
Dynamic_Elaboration_Checks_Config : Boolean := False;
-- GNAT
-- Set True for dynamic elaboration checking mode, as set by the -gnatE
-- switch or by the use of pragma Elaboration_Checking (Dynamic).
Exception_Locations_Suppressed_Config : Boolean := False;
-- GNAT
-- Set True by use of the configuration pragma Suppress_Exception_Messages
Extensions_Allowed_Config : Boolean;
-- GNAT
-- This is the flag that indicates whether extensions are allowed. It can
-- be set True either by use of the -gnatX switch, or by use of the
-- configuration pragma Extensions_Allowed (On). It is always set to True
-- for internal GNAT units, since extensions are always permitted in such
-- units.
External_Name_Exp_Casing_Config : External_Casing_Type;
-- GNAT
-- This is the value of the configuration switch that controls casing of
-- external symbols for which an explicit external name is given. It can be
-- set to Uppercase by the command line switch -gnatF, and further modified
-- by the use of the configuration pragma External_Name_Casing in the
-- gnat.adc file. This flag is used to set the initial value for
-- External_Name_Exp_Casing at the start of analyzing each unit. Note
-- however that the setting of this flag is ignored for internal and
-- predefined units (which are always compiled with As_Is mode).
External_Name_Imp_Casing_Config : External_Casing_Type;
-- GNAT
-- This is the value of the configuration switch that controls casing of
-- external symbols where the external name is implicitly given. It can be
-- set to Uppercase by the command line switch -gnatF, and further modified
-- by the use of the configuration pragma External_Name_Casing in the
-- gnat.adc file. This flag is used to set the initial value for
-- External_Name_Imp_Casing at the start of analyzing each unit. Note
-- however that the setting of this flag is ignored for internal and
-- predefined units (which are always compiled with Lowercase mode).
Fast_Math_Config : Boolean;
-- GNAT
-- This is the value of the configuration switch that controls Fast_Math
-- mode, as set by a Fast_Math pragma in configuration pragmas. It is
-- used to set the initial value of Fast_Math at the start of each new
-- compilation unit.
Initialize_Scalars_Config : Boolean;
-- GNAT
-- This is the value of the configuration switch that is set by the
-- pragma Initialize_Scalars when it appears in the gnat.adc file.
-- This switch is not set when the pragma appears ahead of a given
-- unit, so it does not affect the compilation of other units.
Optimize_Alignment_Config : Character;
-- GNAT
-- This is the value of the configuration switch that controls the
-- alignment optimization mode, as set by an Optimize_Alignment pragma.
-- It is used to set the initial value of Optimize_Alignment at the start
-- of each new compilation unit, except that it is always set to 'O' (off)
-- for internal units.
Persistent_BSS_Mode_Config : Boolean;
-- GNAT
-- This is the value of the configuration switch that controls whether
-- potentially persistent data is to be placed in the persistent_bss
-- section. It can be set True by use of the pragma Persistent_BSS.
-- This flag is used to set the initial value of Persistent_BSS_Mode
-- at the start of each compilation unit, except that it is always
-- set False for predefined units.
Polling_Required_Config : Boolean;
-- GNAT
-- This is the value of the configuration switch that controls polling
-- mode. It can be set True by the command line switch -gnatP, and then
-- further modified by the use of pragma Polling in the gnat.adc file. This
-- flag is used to set the initial value for Polling_Required at the start
-- of analyzing each unit.
Short_Descriptors_Config : Boolean;
-- GNAT
-- This is the value of the configuration switch that controls the use of
-- Short_Descriptors for setting descriptor default sizes. It can be set
-- True by the use of the pragma Short_Descriptors in the gnat.adc file.
-- This flag is used to set the initial value for Short_Descriptors at the
-- start of analyzing each unit.
SPARK_Mode_Config : SPARK_Mode_Type := None;
-- GNAT
-- The setting of SPARK_Mode from configuration pragmas
SPARK_Mode_Pragma_Config : Node_Id := Empty;
-- If a SPARK_Mode pragma appeared in the configuration pragmas (setting
-- SPARK_Mode_Config appropriately), then this points to the N_Pragma node.
Uneval_Old_Config : Character;
-- GNAT
-- The setting of Uneval_Old from configuration pragmas
Use_VADS_Size_Config : Boolean;
-- GNAT
-- This is the value of the configuration switch that controls the use of
-- VADS_Size instead of Size wherever the attribute Size is used. It can
-- be set True by the use of the pragma Use_VADS_Size in the gnat.adc file.
-- This flag is used to set the initial value for Use_VADS_Size at the
-- start of analyzing each unit. Note however that the setting of this flag
-- is ignored for internal and predefined units (which are always compiled
-- with the standard Size semantics).
Warnings_As_Errors_Count_Config : Natural;
-- GNAT
-- Count of pattern strings stored from Warning_As_Error pragmas
type Config_Switches_Type is private;
-- Type used to save values of the switches set from Config values
procedure Save_Opt_Config_Switches (Save : out Config_Switches_Type);
-- This procedure saves the current values of the switches which are
-- initialized from the above Config values, and then resets these switches
-- according to the Config value settings.
procedure Set_Opt_Config_Switches
(Internal_Unit : Boolean;
Main_Unit : Boolean);
-- This procedure sets the switches to the appropriate initial values. The
-- parameter Internal_Unit is True for an internal or predefined unit, and
-- affects the way the switches are set (see above). Main_Unit is true if
-- switches are being set for the main unit or for the spec of the main
-- unit. This affects setting of the assert/debug pragma switches, which
-- are normally set false by default for an internal unit, except when the
-- internal unit is the main unit, in which case we use the command line
-- settings).
procedure Restore_Opt_Config_Switches (Save : Config_Switches_Type);
-- This procedure restores a set of switch values previously saved by a
-- call to Save_Opt_Config_Switches (Save).
procedure Register_Opt_Config_Switches;
-- This procedure is called after processing the gnat.adc file and other
-- configuration pragma files to record the values of the Config switches,
-- as possibly modified by the use of command line switches and pragmas
-- appearing in these files.
------------------------
-- Other Global Flags --
------------------------
Expander_Active : Boolean := False;
-- A flag that indicates if expansion is active (True) or deactivated
-- (False). When expansion is deactivated all calls to expander routines
-- have no effect. Note that the initial setting of False is merely to
-- prevent saving of an undefined value for an initial call to the
-- Expander_Mode_Save_And_Set procedure. For more information on the use of
-- this flag, see package Expander. Indeed this flag might more logically
-- be in the spec of Expander, but it is referenced by Errout, and it
-- really seems wrong for Errout to depend on Expander.
Static_Dispatch_Tables : Boolean := True;
-- This flag indicates if the backend supports generation of statically
-- allocated dispatch tables. If it is True, then the front end will
-- generate static aggregates for dispatch tables that contain forward
-- references to addresses of subprograms not seen yet, and the back end
-- must be prepared to handle this case. If it is False, then the front
-- end generates assignments to initialize the dispatch table, and there
-- are no such forward references. By default we build statically allocated
-- dispatch tables for all library level tagged types in all platforms.This
-- behavior can be disabled using switch -gnatd.t which will set this flag
-- to False and revert to the previous dynamic behavior.
-----------------------
-- Tree I/O Routines --
-----------------------
procedure Tree_Read;
-- Reads switch settings from current tree file using Tree_Read
procedure Tree_Write;
-- Writes out switch settings to current tree file using Tree_Write
--------------------------
-- ASIS Version Control --
--------------------------
-- These two variables (Tree_Version_String and Tree_ASIS_Version_Number)
-- are supposed to be used in the GNAT/ASIS version check performed in
-- the ASIS code (this package is also a part of the ASIS implementation).
-- They are set by Tree_Read procedure, so they represent the version
-- number (and the version string) of the compiler which has created the
-- tree, and they are supposed to be compared with the corresponding values
-- from the Tree_IO and Gnatvsn packages which also are a part of ASIS
-- implementation.
Tree_Version_String : String_Access;
-- Used to store the compiler version string read from a tree file to check
-- if it is from the same date as stored in the version string in Gnatvsn.
-- We require that ASIS Pro can be used only with GNAT Pro, but we allow
-- non-Pro ASIS and ASIS-based tools to be used with any version of the
-- GNAT compiler. Therefore, we need the possibility to compare the dates
-- of the corresponding source sets, using version strings that may be
-- of different lengths.
Tree_ASIS_Version_Number : Int;
-- Used to store the ASIS version number read from a tree file to check if
-- it is the same as stored in the ASIS version number in Tree_IO.
-----------------------------------
-- Modes for Formal Verification --
-----------------------------------
GNATprove_Mode : Boolean := False;
-- Specific compiling mode targeting formal verification for those parts
-- of the input code that belong to the SPARK 2014 subset of Ada. Set True
-- by the gnat2why executable or by use of the -gnatd.F debug switch. Note
-- that this is completely separate from the SPARK restriction defined in
-- GNAT to detect violations of a subset of SPARK 2005 rules.
---------------------------
-- Error/Warning Control --
---------------------------
-- The following array would more reasonably be located in Err_Vars or
-- Errour, but but we put them here to deal with licensing issues (we need
-- this to have the GPL exception licensing, since these variables and
-- subprograms are accessed from units with this licensing).
Warnings_As_Errors : array (1 .. 10_000) of String_Ptr;
-- Table for recording Warning_As_Error pragmas as they are processed.
-- It would be nicer to use Table, but there are circular elaboration
-- problems if we try to do this, and an attempt to find some other
-- appropriately licensed unit to declare this as a Table failed with
-- various elaboration circularities. Memory is getting cheap these days!
--------------------------
-- Private Declarations --
--------------------------
private
-- The following type is used to save and restore settings of switches in
-- Opt that represent the configuration (i.e. result of config pragmas).
-- Note that Ada_Version_Explicit is not included, since this is a sticky
-- flag that once set does not get reset, since the whole idea of this flag
-- is to record the setting for the main unit.
type Config_Switches_Type is record
Ada_Version : Ada_Version_Type;
Ada_Version_Explicit : Ada_Version_Type;
Ada_Version_Pragma : Node_Id;
Assertions_Enabled : Boolean;
Assume_No_Invalid_Values : Boolean;
Check_Float_Overflow : Boolean;
Check_Policy_List : Node_Id;
Default_Pool : Node_Id;
Default_SSO : Character;
Dynamic_Elaboration_Checks : Boolean;
Exception_Locations_Suppressed : Boolean;
Extensions_Allowed : Boolean;
External_Name_Exp_Casing : External_Casing_Type;
External_Name_Imp_Casing : External_Casing_Type;
Fast_Math : Boolean;
Initialize_Scalars : Boolean;
Normalize_Scalars : Boolean;
Optimize_Alignment : Character;
Optimize_Alignment_Local : Boolean;
Persistent_BSS_Mode : Boolean;
Polling_Required : Boolean;
Short_Descriptors : Boolean;
SPARK_Mode : SPARK_Mode_Type;
SPARK_Mode_Pragma : Node_Id;
Uneval_Old : Character;
Use_VADS_Size : Boolean;
Warnings_As_Errors_Count : Natural;
end record;
-- The following declarations are for GCC version dependent flags. We do
-- not let client code in the compiler test GCC_Version directly, but
-- instead use deferred constants for relevant feature tags.
-- Note: there currently are no such constants defined in this section,
-- since the compiler front end is currently entirely independent of the
-- GCC version, which is a desirable state of affairs.
function get_gcc_version return Int;
pragma Import (C, get_gcc_version, "get_gcc_version");
GCC_Version : constant Nat := get_gcc_version;
-- GNATMAKE
-- Indicates which version of gcc is in use (3 = 3.x, 4 = 4.x). Note that
-- gcc 2.8.1 (which used to be a value of 2) is no longer supported.
end Opt;
gprbuild-gpl-2014-src/gnat/prj-conf.adb 0000644 0000767 0000145 00000202244 12323721731 017256 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . C O N F --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006-2014, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Hostparm;
with Makeutl; use Makeutl;
with MLib.Tgt;
with Opt; use Opt;
with Output; use Output;
with Prj.Env;
with Prj.Err;
with Prj.Part;
with Prj.PP;
with Prj.Proc; use Prj.Proc;
with Prj.Tree; use Prj.Tree;
with Prj.Util; use Prj.Util;
with Prj; use Prj;
with Snames; use Snames;
with Ada.Directories; use Ada.Directories;
with Ada.Exceptions; use Ada.Exceptions;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.HTable; use GNAT.HTable;
package body Prj.Conf is
Auto_Cgpr : constant String := "auto.cgpr";
Config_Project_Env_Var : constant String := "GPR_CONFIG";
-- Name of the environment variable that provides the name of the
-- configuration file to use.
Gprconfig_Name : constant String := "gprconfig";
package RTS_Languages is new GNAT.HTable.Simple_HTable
(Header_Num => Prj.Header_Num,
Element => Name_Id,
No_Element => No_Name,
Key => Name_Id,
Hash => Prj.Hash,
Equal => "=");
-- Stores the runtime names for the various languages. This is in general
-- set from a --RTS command line option.
-----------------------
-- Local_Subprograms --
-----------------------
function Check_Target
(Config_File : Prj.Project_Id;
Autoconf_Specified : Boolean;
Project_Tree : Prj.Project_Tree_Ref;
Target : String := "") return Boolean;
-- Check that the config file's target matches Target.
-- Target should be set to the empty string when the user did not specify
-- a target. If the target in the configuration file is invalid, this
-- function will raise Invalid_Config with an appropriate message.
-- Autoconf_Specified should be set to True if the user has used
-- autoconf.
function Locate_Config_File (Name : String) return String_Access;
-- Search for Name in the config files directory. Return full path if
-- found, or null otherwise.
procedure Raise_Invalid_Config (Msg : String);
pragma No_Return (Raise_Invalid_Config);
-- Raises exception Invalid_Config with given message
procedure Apply_Config_File
(Config_File : Prj.Project_Id;
Project_Tree : Prj.Project_Tree_Ref);
-- Apply the configuration file settings to all the projects in the
-- project tree. The Project_Tree must have been parsed first, and
-- processed through the first phase so that all its projects are known.
--
-- Currently, this will add new attributes and packages in the various
-- projects, so that when the second phase of the processing is performed
-- these attributes are automatically taken into account.
------------------------------------
-- Add_Default_GNAT_Naming_Scheme --
------------------------------------
procedure Add_Default_GNAT_Naming_Scheme
(Config_File : in out Project_Node_Id;
Project_Tree : Project_Node_Tree_Ref)
is
procedure Create_Attribute
(Name : Name_Id;
Value : String;
Index : String := "";
Pkg : Project_Node_Id := Empty_Node);
----------------------
-- Create_Attribute --
----------------------
procedure Create_Attribute
(Name : Name_Id;
Value : String;
Index : String := "";
Pkg : Project_Node_Id := Empty_Node)
is
Attr : Project_Node_Id;
pragma Unreferenced (Attr);
Expr : Name_Id := No_Name;
Val : Name_Id := No_Name;
Parent : Project_Node_Id := Config_File;
begin
if Index /= "" then
Name_Len := Index'Length;
Name_Buffer (1 .. Name_Len) := Index;
Val := Name_Find;
end if;
if Pkg /= Empty_Node then
Parent := Pkg;
end if;
Name_Len := Value'Length;
Name_Buffer (1 .. Name_Len) := Value;
Expr := Name_Find;
Attr := Create_Attribute
(Tree => Project_Tree,
Prj_Or_Pkg => Parent,
Name => Name,
Index_Name => Val,
Kind => Prj.Single,
Value => Create_Literal_String (Expr, Project_Tree));
end Create_Attribute;
-- Local variables
Name : Name_Id;
Naming : Project_Node_Id;
Compiler : Project_Node_Id;
-- Start of processing for Add_Default_GNAT_Naming_Scheme
begin
if Config_File = Empty_Node then
-- Create a dummy config file is none was found
Name_Len := Auto_Cgpr'Length;
Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
Name := Name_Find;
-- An invalid project name to avoid conflicts with user-created ones
Name_Len := 5;
Name_Buffer (1 .. Name_Len) := "_auto";
Config_File :=
Create_Project
(In_Tree => Project_Tree,
Name => Name_Find,
Full_Path => Path_Name_Type (Name),
Is_Config_File => True);
-- Setup library support
case MLib.Tgt.Support_For_Libraries is
when None =>
null;
when Static_Only =>
Create_Attribute (Name_Library_Support, "static_only");
when Full =>
Create_Attribute (Name_Library_Support, "full");
end case;
if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then
Create_Attribute (Name_Library_Auto_Init_Supported, "true");
else
Create_Attribute (Name_Library_Auto_Init_Supported, "false");
end if;
-- Declare an empty target
Create_Attribute (Name_Target, "");
-- Setup Ada support (Ada is the default language here, since this
-- is only called when no config file existed initially, ie for
-- gnatmake).
Create_Attribute (Name_Default_Language, "ada");
Compiler := Create_Package (Project_Tree, Config_File, "compiler");
Create_Attribute
(Name_Driver, "gcc", "ada", Pkg => Compiler);
Create_Attribute
(Name_Language_Kind, "unit_based", "ada", Pkg => Compiler);
Create_Attribute
(Name_Dependency_Kind, "ALI_File", "ada", Pkg => Compiler);
Naming := Create_Package (Project_Tree, Config_File, "naming");
Create_Attribute (Name_Spec_Suffix, ".ads", "ada", Pkg => Naming);
Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming);
Create_Attribute (Name_Body_Suffix, ".adb", "ada", Pkg => Naming);
Create_Attribute (Name_Dot_Replacement, "-", Pkg => Naming);
Create_Attribute (Name_Casing, "lowercase", Pkg => Naming);
if Current_Verbosity = High then
Write_Line ("Automatically generated (in-memory) config file");
Prj.PP.Pretty_Print
(Project => Config_File,
In_Tree => Project_Tree,
Backward_Compatibility => False);
end if;
end if;
end Add_Default_GNAT_Naming_Scheme;
-----------------------
-- Apply_Config_File --
-----------------------
procedure Apply_Config_File
(Config_File : Prj.Project_Id;
Project_Tree : Prj.Project_Tree_Ref)
is
procedure Add_Attributes
(Project_Tree : Project_Tree_Ref;
Conf_Decl : Declarations;
User_Decl : in out Declarations);
-- Process the attributes in the config declarations. For
-- single string values, if the attribute is not declared in
-- the user declarations, declare it with the value in the
-- config declarations. For string list values, prepend the
-- value in the user declarations with the value in the config
-- declarations.
--------------------
-- Add_Attributes --
--------------------
procedure Add_Attributes
(Project_Tree : Project_Tree_Ref;
Conf_Decl : Declarations;
User_Decl : in out Declarations)
is
Shared : constant Shared_Project_Tree_Data_Access :=
Project_Tree.Shared;
Conf_Attr_Id : Variable_Id;
Conf_Attr : Variable;
Conf_Array_Id : Array_Id;
Conf_Array : Array_Data;
Conf_Array_Elem_Id : Array_Element_Id;
Conf_Array_Elem : Array_Element;
Conf_List : String_List_Id;
Conf_List_Elem : String_Element;
User_Attr_Id : Variable_Id;
User_Attr : Variable;
User_Array_Id : Array_Id;
User_Array : Array_Data;
User_Array_Elem_Id : Array_Element_Id;
User_Array_Elem : Array_Element;
begin
Conf_Attr_Id := Conf_Decl.Attributes;
User_Attr_Id := User_Decl.Attributes;
while Conf_Attr_Id /= No_Variable loop
Conf_Attr := Shared.Variable_Elements.Table (Conf_Attr_Id);
User_Attr := Shared.Variable_Elements.Table (User_Attr_Id);
if not Conf_Attr.Value.Default then
if User_Attr.Value.Default then
-- No attribute declared in user project file: just copy
-- the value of the configuration attribute.
User_Attr.Value := Conf_Attr.Value;
Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr;
elsif User_Attr.Value.Kind = List
and then Conf_Attr.Value.Values /= Nil_String
then
-- List attribute declared in both the user project and the
-- configuration project: prepend the user list with the
-- configuration list.
declare
User_List : constant String_List_Id :=
User_Attr.Value.Values;
Conf_List : String_List_Id := Conf_Attr.Value.Values;
Conf_Elem : String_Element;
New_List : String_List_Id;
New_Elem : String_Element;
begin
-- Create new list
String_Element_Table.Increment_Last
(Shared.String_Elements);
New_List :=
String_Element_Table.Last (Shared.String_Elements);
-- Value of attribute is new list
User_Attr.Value.Values := New_List;
Shared.Variable_Elements.Table (User_Attr_Id) :=
User_Attr;
loop
-- Get each element of configuration list
Conf_Elem := Shared.String_Elements.Table (Conf_List);
New_Elem := Conf_Elem;
Conf_List := Conf_Elem.Next;
if Conf_List = Nil_String then
-- If it is the last element in the list, connect
-- to first element of user list, and we are done.
New_Elem.Next := User_List;
Shared.String_Elements.Table (New_List) := New_Elem;
exit;
else
-- If it is not the last element in the list, add
-- to new list.
String_Element_Table.Increment_Last
(Shared.String_Elements);
New_Elem.Next := String_Element_Table.Last
(Shared.String_Elements);
Shared.String_Elements.Table (New_List) := New_Elem;
New_List := New_Elem.Next;
end if;
end loop;
end;
end if;
end if;
Conf_Attr_Id := Conf_Attr.Next;
User_Attr_Id := User_Attr.Next;
end loop;
Conf_Array_Id := Conf_Decl.Arrays;
while Conf_Array_Id /= No_Array loop
Conf_Array := Shared.Arrays.Table (Conf_Array_Id);
User_Array_Id := User_Decl.Arrays;
while User_Array_Id /= No_Array loop
User_Array := Shared.Arrays.Table (User_Array_Id);
exit when User_Array.Name = Conf_Array.Name;
User_Array_Id := User_Array.Next;
end loop;
-- If this associative array does not exist in the user project
-- file, do a shallow copy of the full associative array.
if User_Array_Id = No_Array then
Array_Table.Increment_Last (Shared.Arrays);
User_Array := Conf_Array;
User_Array.Next := User_Decl.Arrays;
User_Decl.Arrays := Array_Table.Last (Shared.Arrays);
Shared.Arrays.Table (User_Decl.Arrays) := User_Array;
-- Otherwise, check each array element
else
Conf_Array_Elem_Id := Conf_Array.Value;
while Conf_Array_Elem_Id /= No_Array_Element loop
Conf_Array_Elem :=
Shared.Array_Elements.Table (Conf_Array_Elem_Id);
User_Array_Elem_Id := User_Array.Value;
while User_Array_Elem_Id /= No_Array_Element loop
User_Array_Elem :=
Shared.Array_Elements.Table (User_Array_Elem_Id);
exit when User_Array_Elem.Index = Conf_Array_Elem.Index;
User_Array_Elem_Id := User_Array_Elem.Next;
end loop;
-- If the array element doesn't exist in the user array,
-- insert a shallow copy of the conf array element in the
-- user array.
if User_Array_Elem_Id = No_Array_Element then
Array_Element_Table.Increment_Last
(Shared.Array_Elements);
User_Array_Elem := Conf_Array_Elem;
User_Array_Elem.Next := User_Array.Value;
User_Array.Value :=
Array_Element_Table.Last (Shared.Array_Elements);
Shared.Array_Elements.Table (User_Array.Value) :=
User_Array_Elem;
Shared.Arrays.Table (User_Array_Id) := User_Array;
-- Otherwise, if the value is a string list, prepend the
-- conf array element value to the array element.
elsif Conf_Array_Elem.Value.Kind = List then
Conf_List := Conf_Array_Elem.Value.Values;
if Conf_List /= Nil_String then
declare
Link : constant String_List_Id :=
User_Array_Elem.Value.Values;
Previous : String_List_Id := Nil_String;
Next : String_List_Id;
begin
loop
Conf_List_Elem :=
Shared.String_Elements.Table (Conf_List);
String_Element_Table.Increment_Last
(Shared.String_Elements);
Next :=
String_Element_Table.Last
(Shared.String_Elements);
Shared.String_Elements.Table (Next) :=
Conf_List_Elem;
if Previous = Nil_String then
User_Array_Elem.Value.Values := Next;
Shared.Array_Elements.Table
(User_Array_Elem_Id) := User_Array_Elem;
else
Shared.String_Elements.Table
(Previous).Next := Next;
end if;
Previous := Next;
Conf_List := Conf_List_Elem.Next;
if Conf_List = Nil_String then
Shared.String_Elements.Table
(Previous).Next := Link;
exit;
end if;
end loop;
end;
end if;
end if;
Conf_Array_Elem_Id := Conf_Array_Elem.Next;
end loop;
end if;
Conf_Array_Id := Conf_Array.Next;
end loop;
end Add_Attributes;
Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
Conf_Decl : constant Declarations := Config_File.Decl;
Conf_Pack_Id : Package_Id;
Conf_Pack : Package_Element;
User_Decl : Declarations;
User_Pack_Id : Package_Id;
User_Pack : Package_Element;
Proj : Project_List;
begin
Debug_Output ("Applying config file to a project tree");
Proj := Project_Tree.Projects;
while Proj /= null loop
if Proj.Project /= Config_File then
User_Decl := Proj.Project.Decl;
Add_Attributes
(Project_Tree => Project_Tree,
Conf_Decl => Conf_Decl,
User_Decl => User_Decl);
Conf_Pack_Id := Conf_Decl.Packages;
while Conf_Pack_Id /= No_Package loop
Conf_Pack := Shared.Packages.Table (Conf_Pack_Id);
User_Pack_Id := User_Decl.Packages;
while User_Pack_Id /= No_Package loop
User_Pack := Shared.Packages.Table (User_Pack_Id);
exit when User_Pack.Name = Conf_Pack.Name;
User_Pack_Id := User_Pack.Next;
end loop;
if User_Pack_Id = No_Package then
Package_Table.Increment_Last (Shared.Packages);
User_Pack := Conf_Pack;
User_Pack.Next := User_Decl.Packages;
User_Decl.Packages := Package_Table.Last (Shared.Packages);
Shared.Packages.Table (User_Decl.Packages) := User_Pack;
else
Add_Attributes
(Project_Tree => Project_Tree,
Conf_Decl => Conf_Pack.Decl,
User_Decl => Shared.Packages.Table
(User_Pack_Id).Decl);
end if;
Conf_Pack_Id := Conf_Pack.Next;
end loop;
Proj.Project.Decl := User_Decl;
-- For aggregate projects, we need to apply the config to all
-- their aggregated trees as well.
if Proj.Project.Qualifier in Aggregate_Project then
declare
List : Aggregated_Project_List;
begin
List := Proj.Project.Aggregated_Projects;
while List /= null loop
Debug_Output
("Recursively apply config to aggregated tree",
List.Project.Name);
Apply_Config_File
(Config_File, Project_Tree => List.Tree);
List := List.Next;
end loop;
end;
end if;
end if;
Proj := Proj.Next;
end loop;
end Apply_Config_File;
------------------
-- Check_Target --
------------------
function Check_Target
(Config_File : Project_Id;
Autoconf_Specified : Boolean;
Project_Tree : Prj.Project_Tree_Ref;
Target : String := "") return Boolean
is
Shared : constant Shared_Project_Tree_Data_Access :=
Project_Tree.Shared;
Variable : constant Variable_Value :=
Value_Of
(Name_Target, Config_File.Decl.Attributes, Shared);
Tgt_Name : Name_Id := No_Name;
OK : Boolean;
begin
if Variable /= Nil_Variable_Value and then not Variable.Default then
Tgt_Name := Variable.Value;
end if;
OK :=
Target = ""
or else
(Tgt_Name /= No_Name
and then (Length_Of_Name (Tgt_Name) = 0
or else Target = Get_Name_String (Tgt_Name)));
if not OK then
if Autoconf_Specified then
if Verbose_Mode then
Write_Line ("inconsistent targets, performing autoconf");
end if;
return False;
else
if Tgt_Name /= No_Name then
Raise_Invalid_Config
("invalid target name """
& Get_Name_String (Tgt_Name) & """ in configuration");
else
Raise_Invalid_Config
("no target specified in configuration file");
end if;
end if;
end if;
return True;
end Check_Target;
--------------------------------------
-- Get_Or_Create_Configuration_File --
--------------------------------------
procedure Get_Or_Create_Configuration_File
(Project : Project_Id;
Conf_Project : Project_Id;
Project_Tree : Project_Tree_Ref;
Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
Env : in out Prj.Tree.Environment;
Allow_Automatic_Generation : Boolean;
Config_File_Name : String := "";
Autoconf_Specified : Boolean;
Target_Name : String := "";
Normalized_Hostname : String;
Packages_To_Check : String_List_Access := null;
Config : out Prj.Project_Id;
Config_File_Path : out String_Access;
Automatically_Generated : out Boolean;
On_Load_Config : Config_File_Hook := null)
is
Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
At_Least_One_Compiler_Command : Boolean := False;
-- Set to True if at least one attribute Ide'Compiler_Command is
-- specified for one language of the system.
Conf_File_Name : String_Access := new String'(Config_File_Name);
-- The configuration project file name. May be modified if there are
-- switches --config= in the Builder package of the main project.
Selected_Target : String_Access := new String'(Target_Name);
function Default_File_Name return String;
-- Return the name of the default config file that should be tested
procedure Do_Autoconf;
-- Generate a new config file through gprconfig. In case of error, this
-- raises the Invalid_Config exception with an appropriate message
procedure Check_Builder_Switches;
-- Check for switches --config and --RTS in package Builder
procedure Get_Project_Target;
-- If Target_Name is empty, get the specified target in the project
-- file, if any.
function Get_Config_Switches return Argument_List_Access;
-- Return the --config switches to use for gprconfig
function Get_Db_Switches return Argument_List_Access;
-- Return the --db switches to use for gprconfig
function Might_Have_Sources (Project : Project_Id) return Boolean;
-- True if the specified project might have sources (ie the user has not
-- explicitly specified it. We haven't checked the file system, nor do
-- we need to at this stage.
----------------------------
-- Check_Builder_Switches --
----------------------------
procedure Check_Builder_Switches is
Get_RTS_Switches : constant Boolean :=
RTS_Languages.Get_First = No_Name;
-- If no switch --RTS have been specified on the command line, look
-- for --RTS switches in the Builder switches.
Builder : constant Package_Id :=
Value_Of (Name_Builder, Project.Decl.Packages, Shared);
Switch_Array_Id : Array_Element_Id;
-- The Switches to be checked
procedure Check_Switches;
-- Check the switches in Switch_Array_Id
--------------------
-- Check_Switches --
--------------------
procedure Check_Switches is
Switch_Array : Array_Element;
Switch_List : String_List_Id := Nil_String;
Switch : String_Element;
Lang : Name_Id;
Lang_Last : Positive;
begin
while Switch_Array_Id /= No_Array_Element loop
Switch_Array :=
Shared.Array_Elements.Table (Switch_Array_Id);
Switch_List := Switch_Array.Value.Values;
List_Loop : while Switch_List /= Nil_String loop
Switch := Shared.String_Elements.Table (Switch_List);
if Switch.Value /= No_Name then
Get_Name_String (Switch.Value);
if Conf_File_Name'Length = 0
and then Name_Len > 9
and then Name_Buffer (1 .. 9) = "--config="
then
Conf_File_Name :=
new String'(Name_Buffer (10 .. Name_Len));
elsif Get_RTS_Switches
and then Name_Len >= 7
and then Name_Buffer (1 .. 5) = "--RTS"
then
if Name_Buffer (6) = '=' then
if not Runtime_Name_Set_For (Name_Ada) then
Set_Runtime_For
(Name_Ada,
Name_Buffer (7 .. Name_Len));
Locate_Runtime (Name_Ada, Project_Tree, Env);
end if;
elsif Name_Len > 7
and then Name_Buffer (6) = ':'
and then Name_Buffer (7) /= '='
then
Lang_Last := 7;
while Lang_Last < Name_Len
and then Name_Buffer (Lang_Last + 1) /= '='
loop
Lang_Last := Lang_Last + 1;
end loop;
if Name_Buffer (Lang_Last + 1) = '=' then
declare
RTS : constant String :=
Name_Buffer (Lang_Last + 2 .. Name_Len);
begin
Name_Buffer (1 .. Lang_Last - 6) :=
Name_Buffer (7 .. Lang_Last);
Name_Len := Lang_Last - 6;
To_Lower (Name_Buffer (1 .. Name_Len));
Lang := Name_Find;
if not Runtime_Name_Set_For (Lang) then
Set_Runtime_For (Lang, RTS);
Locate_Runtime (Lang, Project_Tree, Env);
end if;
end;
end if;
end if;
end if;
end if;
Switch_List := Switch.Next;
end loop List_Loop;
Switch_Array_Id := Switch_Array.Next;
end loop;
end Check_Switches;
-- Start of processing for Check_Builder_Switches
begin
if Builder /= No_Package then
Switch_Array_Id :=
Value_Of
(Name => Name_Switches,
In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays,
Shared => Shared);
Check_Switches;
Switch_Array_Id :=
Value_Of
(Name => Name_Default_Switches,
In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays,
Shared => Shared);
Check_Switches;
end if;
end Check_Builder_Switches;
------------------------
-- Get_Project_Target --
------------------------
procedure Get_Project_Target is
begin
if Selected_Target'Length = 0 then
-- Check if attribute Target is specified in the main
-- project, or in a project it extends. If it is, use this
-- target to invoke gprconfig.
declare
Variable : Variable_Value;
Proj : Project_Id;
Tgt_Name : Name_Id := No_Name;
begin
Proj := Project;
Project_Loop :
while Proj /= No_Project loop
Variable :=
Value_Of (Name_Target, Proj.Decl.Attributes, Shared);
if Variable /= Nil_Variable_Value
and then not Variable.Default
and then Variable.Value /= No_Name
then
Tgt_Name := Variable.Value;
exit Project_Loop;
end if;
Proj := Proj.Extends;
end loop Project_Loop;
if Tgt_Name /= No_Name then
Selected_Target := new String'(Get_Name_String (Tgt_Name));
end if;
end;
end if;
end Get_Project_Target;
-----------------------
-- Default_File_Name --
-----------------------
function Default_File_Name return String is
Ada_RTS : constant String := Runtime_Name_For (Name_Ada);
Tmp : String_Access;
begin
if Selected_Target'Length /= 0 then
if Ada_RTS /= "" then
return
Selected_Target.all & '-' &
Ada_RTS & Config_Project_File_Extension;
else
return
Selected_Target.all & Config_Project_File_Extension;
end if;
elsif Ada_RTS /= "" then
return Ada_RTS & Config_Project_File_Extension;
else
Tmp := Getenv (Config_Project_Env_Var);
declare
T : constant String := Tmp.all;
begin
Free (Tmp);
if T'Length = 0 then
return Default_Config_Name;
else
return T;
end if;
end;
end if;
end Default_File_Name;
-----------------
-- Do_Autoconf --
-----------------
procedure Do_Autoconf is
Obj_Dir : constant Variable_Value :=
Value_Of
(Name_Object_Dir,
Conf_Project.Decl.Attributes,
Shared);
Gprconfig_Path : String_Access;
Success : Boolean;
begin
Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name);
if Gprconfig_Path = null then
Raise_Invalid_Config
("could not locate gprconfig for auto-configuration");
end if;
-- First, find the object directory of the Conf_Project
if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
Get_Name_String (Conf_Project.Directory.Display_Name);
else
if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
Get_Name_String (Obj_Dir.Value);
else
Name_Len := 0;
Add_Str_To_Name_Buffer
(Get_Name_String (Conf_Project.Directory.Display_Name));
Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
end if;
end if;
if Subdirs /= null then
Add_Char_To_Name_Buffer (Directory_Separator);
Add_Str_To_Name_Buffer (Subdirs.all);
end if;
for J in 1 .. Name_Len loop
if Name_Buffer (J) = '/' then
Name_Buffer (J) := Directory_Separator;
end if;
end loop;
-- Make sure that Obj_Dir ends with a directory separator
if Name_Buffer (Name_Len) /= Directory_Separator then
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Directory_Separator;
end if;
declare
Obj_Dir : constant String := Name_Buffer (1 .. Name_Len);
Config_Switches : Argument_List_Access;
Db_Switches : Argument_List_Access;
Args : Argument_List (1 .. 5);
Arg_Last : Positive;
Obj_Dir_Exists : Boolean := True;
begin
-- Check if the object directory exists. If Setup_Projects is True
-- (-p) and directory does not exist, attempt to create it.
-- Otherwise, if directory does not exist, fail without calling
-- gprconfig.
if not Is_Directory (Obj_Dir)
and then (Setup_Projects or else Subdirs /= null)
then
begin
Create_Path (Obj_Dir);
if not Quiet_Output then
Write_Str ("object directory """);
Write_Str (Obj_Dir);
Write_Line (""" created");
end if;
exception
when others =>
Raise_Invalid_Config
("could not create object directory " & Obj_Dir);
end;
end if;
if not Is_Directory (Obj_Dir) then
case Env.Flags.Require_Obj_Dirs is
when Error =>
Raise_Invalid_Config
("object directory " & Obj_Dir & " does not exist");
when Warning =>
Prj.Err.Error_Msg
(Env.Flags,
"?object directory " & Obj_Dir & " does not exist");
Obj_Dir_Exists := False;
when Silent =>
null;
end case;
end if;
-- Get the config switches. This should be done only now, as some
-- runtimes may have been found if the Builder switches.
Config_Switches := Get_Config_Switches;
-- Get eventual --db switches
Db_Switches := Get_Db_Switches;
-- Invoke gprconfig
Args (1) := new String'("--batch");
Args (2) := new String'("-o");
-- If no config file was specified, set the auto.cgpr one
if Conf_File_Name'Length = 0 then
if Obj_Dir_Exists then
Args (3) := new String'(Obj_Dir & Auto_Cgpr);
else
declare
Path_FD : File_Descriptor;
Path_Name : Path_Name_Type;
begin
Prj.Env.Create_Temp_File
(Shared => Project_Tree.Shared,
Path_FD => Path_FD,
Path_Name => Path_Name,
File_Use => "configuration file");
if Path_FD /= Invalid_FD then
declare
Temp_Dir : constant String :=
Containing_Directory
(Get_Name_String (Path_Name));
begin
GNAT.OS_Lib.Close (Path_FD);
Args (3) :=
new String'(Temp_Dir &
Directory_Separator &
Auto_Cgpr);
Delete_File (Get_Name_String (Path_Name));
end;
else
-- We'll have an error message later on
Args (3) := new String'(Obj_Dir & Auto_Cgpr);
end if;
end;
end if;
else
Args (3) := Conf_File_Name;
end if;
if Normalized_Hostname = "" then
Arg_Last := 3;
else
if Selected_Target'Length = 0 then
if At_Least_One_Compiler_Command then
Args (4) :=
new String'("--target=all");
else
Args (4) :=
new String'("--target=" & Normalized_Hostname);
end if;
else
Args (4) :=
new String'("--target=" & Selected_Target.all);
end if;
Arg_Last := 4;
end if;
if not Verbose_Mode then
Arg_Last := Arg_Last + 1;
Args (Arg_Last) := new String'("-q");
end if;
if Verbose_Mode then
Write_Str (Gprconfig_Name);
for J in 1 .. Arg_Last loop
Write_Char (' ');
Write_Str (Args (J).all);
end loop;
for J in Config_Switches'Range loop
Write_Char (' ');
Write_Str (Config_Switches (J).all);
end loop;
for J in Db_Switches'Range loop
Write_Char (' ');
Write_Str (Db_Switches (J).all);
end loop;
Write_Eol;
elsif not Quiet_Output then
-- Display no message if we are creating auto.cgpr, unless in
-- verbose mode
if Config_File_Name'Length > 0
or else Verbose_Mode
then
Write_Str ("creating ");
Write_Str (Simple_Name (Args (3).all));
Write_Eol;
end if;
end if;
Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) &
Config_Switches.all & Db_Switches.all,
Success);
Free (Config_Switches);
Config_File_Path := Locate_Config_File (Args (3).all);
if Config_File_Path = null then
Raise_Invalid_Config
("could not create " & Args (3).all);
end if;
for F in Args'Range loop
Free (Args (F));
end loop;
end;
end Do_Autoconf;
---------------------
-- Get_Db_Switches --
---------------------
function Get_Db_Switches return Argument_List_Access is
Result : Argument_List_Access;
Nmb_Arg : Natural;
begin
Nmb_Arg :=
(2 * Db_Switch_Args.Last) + Boolean'Pos (not Load_Standard_Base);
Result := new Argument_List (1 .. Nmb_Arg);
if Nmb_Arg /= 0 then
for J in 1 .. Db_Switch_Args.Last loop
Result (2 * J - 1) :=
new String'("--db");
Result (2 * J) :=
new String'(Get_Name_String (Db_Switch_Args.Table (J)));
end loop;
if not Load_Standard_Base then
Result (Result'Last) := new String'("--db-");
end if;
end if;
return Result;
end Get_Db_Switches;
-------------------------
-- Get_Config_Switches --
-------------------------
function Get_Config_Switches return Argument_List_Access is
package Language_Htable is new GNAT.HTable.Simple_HTable
(Header_Num => Prj.Header_Num,
Element => Name_Id,
No_Element => No_Name,
Key => Name_Id,
Hash => Prj.Hash,
Equal => "=");
-- Hash table to keep the languages used in the project tree
IDE : constant Package_Id :=
Value_Of (Name_Ide, Project.Decl.Packages, Shared);
procedure Add_Config_Switches_For_Project
(Project : Project_Id;
Tree : Project_Tree_Ref;
With_State : in out Integer);
-- Add all --config switches for this project. This is also called
-- for aggregate projects.
-------------------------------------
-- Add_Config_Switches_For_Project --
-------------------------------------
procedure Add_Config_Switches_For_Project
(Project : Project_Id;
Tree : Project_Tree_Ref;
With_State : in out Integer)
is
pragma Unreferenced (With_State);
Shared : constant Shared_Project_Tree_Data_Access := Tree.Shared;
Variable : Variable_Value;
Check_Default : Boolean;
Lang : Name_Id;
List : String_List_Id;
Elem : String_Element;
begin
if Might_Have_Sources (Project) then
Variable :=
Value_Of (Name_Languages, Project.Decl.Attributes, Shared);
if Variable = Nil_Variable_Value or else Variable.Default then
-- Languages is not declared. If it is not an extending
-- project, or if it extends a project with no Languages,
-- check for Default_Language.
Check_Default := Project.Extends = No_Project;
if not Check_Default then
Variable :=
Value_Of
(Name_Languages,
Project.Extends.Decl.Attributes,
Shared);
Check_Default :=
Variable /= Nil_Variable_Value
and then Variable.Values = Nil_String;
end if;
if Check_Default then
Variable :=
Value_Of
(Name_Default_Language,
Project.Decl.Attributes,
Shared);
if Variable /= Nil_Variable_Value
and then not Variable.Default
then
Get_Name_String (Variable.Value);
To_Lower (Name_Buffer (1 .. Name_Len));
Lang := Name_Find;
Language_Htable.Set (Lang, Lang);
-- If no default language is declared, default to Ada
else
Language_Htable.Set (Name_Ada, Name_Ada);
end if;
end if;
elsif Variable.Values /= Nil_String then
-- Attribute Languages is declared with a non empty list:
-- put all the languages in Language_HTable.
List := Variable.Values;
while List /= Nil_String loop
Elem := Shared.String_Elements.Table (List);
Get_Name_String (Elem.Value);
To_Lower (Name_Buffer (1 .. Name_Len));
Lang := Name_Find;
Language_Htable.Set (Lang, Lang);
List := Elem.Next;
end loop;
end if;
end if;
end Add_Config_Switches_For_Project;
procedure For_Every_Imported_Project is new For_Every_Project_Imported
(State => Integer, Action => Add_Config_Switches_For_Project);
-- Document this procedure ???
-- Local variables
Name : Name_Id;
Count : Natural;
Result : Argument_List_Access;
Variable : Variable_Value;
Dummy : Integer := 0;
-- Start of processing for Get_Config_Switches
begin
For_Every_Imported_Project
(By => Project,
Tree => Project_Tree,
With_State => Dummy,
Include_Aggregated => True);
Name := Language_Htable.Get_First;
Count := 0;
while Name /= No_Name loop
Count := Count + 1;
Name := Language_Htable.Get_Next;
end loop;
Result := new String_List (1 .. Count);
Count := 1;
Name := Language_Htable.Get_First;
while Name /= No_Name loop
-- Check if IDE'Compiler_Command is declared for the language.
-- If it is, use its value to invoke gprconfig.
Variable :=
Value_Of
(Name,
Attribute_Or_Array_Name => Name_Compiler_Command,
In_Package => IDE,
Shared => Shared,
Force_Lower_Case_Index => True);
declare
Config_Command : constant String :=
"--config=" & Get_Name_String (Name);
Runtime_Name : constant String :=
Runtime_Name_For (Name);
begin
if Variable = Nil_Variable_Value
or else Length_Of_Name (Variable.Value) = 0
then
Result (Count) :=
new String'(Config_Command & ",," & Runtime_Name);
else
At_Least_One_Compiler_Command := True;
declare
Compiler_Command : constant String :=
Get_Name_String (Variable.Value);
begin
if Is_Absolute_Path (Compiler_Command) then
Result (Count) :=
new String'
(Config_Command & ",," & Runtime_Name & "," &
Containing_Directory (Compiler_Command) & "," &
Simple_Name (Compiler_Command));
else
Result (Count) :=
new String'
(Config_Command & ",," & Runtime_Name & ",," &
Compiler_Command);
end if;
end;
end if;
end;
Count := Count + 1;
Name := Language_Htable.Get_Next;
end loop;
return Result;
end Get_Config_Switches;
------------------------
-- Might_Have_Sources --
------------------------
function Might_Have_Sources (Project : Project_Id) return Boolean is
Variable : Variable_Value;
begin
Variable :=
Value_Of
(Name_Source_Dirs,
Project.Decl.Attributes,
Shared);
if Variable = Nil_Variable_Value
or else Variable.Default
or else Variable.Values /= Nil_String
then
Variable :=
Value_Of
(Name_Source_Files,
Project.Decl.Attributes,
Shared);
return Variable = Nil_Variable_Value
or else Variable.Default
or else Variable.Values /= Nil_String;
else
return False;
end if;
end Might_Have_Sources;
Success : Boolean;
Config_Project_Node : Project_Node_Id := Empty_Node;
begin
pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
Free (Config_File_Path);
Config := No_Project;
Get_Project_Target;
Check_Builder_Switches;
-- Do not attempt to find a configuration project file when
-- Config_File_Name is No_Configuration_File.
if Config_File_Name = No_Configuration_File then
Config_File_Path := null;
else
if Conf_File_Name'Length > 0 then
Config_File_Path := Locate_Config_File (Conf_File_Name.all);
else
Config_File_Path := Locate_Config_File (Default_File_Name);
end if;
if Config_File_Path = null then
if not Allow_Automatic_Generation
and then Conf_File_Name'Length > 0
then
Raise_Invalid_Config
("could not locate main configuration project "
& Conf_File_Name.all);
end if;
end if;
end if;
Automatically_Generated :=
Allow_Automatic_Generation and then Config_File_Path = null;
<>
if Automatically_Generated then
if Hostparm.OpenVMS then
-- There is no gprconfig on VMS
Raise_Invalid_Config
("could not locate any configuration project file");
else
-- This might raise an Invalid_Config exception
Do_Autoconf;
end if;
-- If the config file is not auto-generated, warn if there is any --RTS
-- switch, but not when the config file is generated in memory.
elsif RTS_Languages.Get_First /= No_Name
and then Opt.Warning_Mode /= Opt.Suppress
and then On_Load_Config = null
then
Write_Line
("warning: " &
"--RTS is taken into account only in auto-configuration");
end if;
-- Parse the configuration file
if Verbose_Mode and then Config_File_Path /= null then
Write_Str ("Checking configuration ");
Write_Line (Config_File_Path.all);
end if;
if Config_File_Path /= null then
Prj.Part.Parse
(In_Tree => Project_Node_Tree,
Project => Config_Project_Node,
Project_File_Name => Config_File_Path.all,
Errout_Handling => Prj.Part.Finalize_If_Error,
Packages_To_Check => Packages_To_Check,
Current_Directory => Current_Directory,
Is_Config_File => True,
Env => Env);
else
Config_Project_Node := Empty_Node;
end if;
if On_Load_Config /= null then
On_Load_Config
(Config_File => Config_Project_Node,
Project_Node_Tree => Project_Node_Tree);
end if;
if Config_Project_Node /= Empty_Node then
Prj.Proc.Process_Project_Tree_Phase_1
(In_Tree => Project_Tree,
Project => Config,
Packages_To_Check => Packages_To_Check,
Success => Success,
From_Project_Node => Config_Project_Node,
From_Project_Node_Tree => Project_Node_Tree,
Env => Env,
Reset_Tree => False,
On_New_Tree_Loaded => null);
end if;
if Config_Project_Node = Empty_Node
or else Config = No_Project
then
Raise_Invalid_Config
("processing of configuration project """
& Config_File_Path.all & """ failed");
end if;
-- Check that the target of the configuration file is the one the user
-- specified on the command line. We do not need to check that when in
-- auto-conf mode, since the appropriate target was passed to gprconfig.
if not Automatically_Generated
and then not
Check_Target
(Config, Autoconf_Specified, Project_Tree, Selected_Target.all)
then
Automatically_Generated := True;
goto Process_Config_File;
end if;
end Get_Or_Create_Configuration_File;
------------------------
-- Locate_Config_File --
------------------------
function Locate_Config_File (Name : String) return String_Access is
Prefix_Path : constant String := Executable_Prefix_Path;
begin
if Prefix_Path'Length /= 0 then
return Locate_Regular_File
(Name,
"." & Path_Separator &
Prefix_Path & "share" & Directory_Separator & "gpr");
else
return Locate_Regular_File (Name, ".");
end if;
end Locate_Config_File;
--------------------
-- Locate_Runtime --
--------------------
procedure Locate_Runtime
(Language : Name_Id;
Project_Tree : Prj.Project_Tree_Ref;
Env : Prj.Tree.Environment)
is
function Is_Base_Name (Path : String) return Boolean;
-- Returns True if Path has no directory separator
------------------
-- Is_Base_Name --
------------------
function Is_Base_Name (Path : String) return Boolean is
begin
for I in Path'Range loop
if Path (I) = Directory_Separator or else Path (I) = '/' then
return False;
end if;
end loop;
return True;
end Is_Base_Name;
-- Local declarations
function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path
(Check_Filename => Is_Directory);
RTS_Name : constant String := Runtime_Name_For (Language);
Full_Path : String_Access;
-- Start of processing for Locate_Runtime
begin
if not Is_Base_Name (RTS_Name) then
Full_Path :=
Find_Rts_In_Path (Env.Project_Path, RTS_Name);
if Full_Path = null then
Fail_Program (Project_Tree, "cannot find RTS " & RTS_Name);
end if;
Set_Runtime_For (Language, Normalize_Pathname (Full_Path.all));
Free (Full_Path);
end if;
end Locate_Runtime;
------------------------------------
-- Parse_Project_And_Apply_Config --
------------------------------------
procedure Parse_Project_And_Apply_Config
(Main_Project : out Prj.Project_Id;
User_Project_Node : out Prj.Tree.Project_Node_Id;
Config_File_Name : String := "";
Autoconf_Specified : Boolean;
Project_File_Name : String;
Project_Tree : Prj.Project_Tree_Ref;
Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
Env : in out Prj.Tree.Environment;
Packages_To_Check : String_List_Access;
Allow_Automatic_Generation : Boolean := True;
Automatically_Generated : out Boolean;
Config_File_Path : out String_Access;
Target_Name : String := "";
Normalized_Hostname : String;
On_Load_Config : Config_File_Hook := null;
Implicit_Project : Boolean := False;
On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null)
is
begin
pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
-- Parse the user project tree
Prj.Initialize (Project_Tree);
Main_Project := No_Project;
Automatically_Generated := False;
Prj.Part.Parse
(In_Tree => Project_Node_Tree,
Project => User_Project_Node,
Project_File_Name => Project_File_Name,
Errout_Handling => Prj.Part.Finalize_If_Error,
Packages_To_Check => Packages_To_Check,
Current_Directory => Current_Directory,
Is_Config_File => False,
Env => Env,
Implicit_Project => Implicit_Project);
if User_Project_Node = Empty_Node then
User_Project_Node := Empty_Node;
return;
end if;
Process_Project_And_Apply_Config
(Main_Project => Main_Project,
User_Project_Node => User_Project_Node,
Config_File_Name => Config_File_Name,
Autoconf_Specified => Autoconf_Specified,
Project_Tree => Project_Tree,
Project_Node_Tree => Project_Node_Tree,
Env => Env,
Packages_To_Check => Packages_To_Check,
Allow_Automatic_Generation => Allow_Automatic_Generation,
Automatically_Generated => Automatically_Generated,
Config_File_Path => Config_File_Path,
Target_Name => Target_Name,
Normalized_Hostname => Normalized_Hostname,
On_Load_Config => On_Load_Config,
On_New_Tree_Loaded => On_New_Tree_Loaded);
end Parse_Project_And_Apply_Config;
--------------------------------------
-- Process_Project_And_Apply_Config --
--------------------------------------
procedure Process_Project_And_Apply_Config
(Main_Project : out Prj.Project_Id;
User_Project_Node : Prj.Tree.Project_Node_Id;
Config_File_Name : String := "";
Autoconf_Specified : Boolean;
Project_Tree : Prj.Project_Tree_Ref;
Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
Env : in out Prj.Tree.Environment;
Packages_To_Check : String_List_Access;
Allow_Automatic_Generation : Boolean := True;
Automatically_Generated : out Boolean;
Config_File_Path : out String_Access;
Target_Name : String := "";
Normalized_Hostname : String;
On_Load_Config : Config_File_Hook := null;
Reset_Tree : Boolean := True;
On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null)
is
Shared : constant Shared_Project_Tree_Data_Access :=
Project_Tree.Shared;
Main_Config_Project : Project_Id;
Success : Boolean;
Conf_Project : Project_Id := No_Project;
-- The object directory of this project is used to store the config
-- project file in auto-configuration. Set by Check_Project below.
procedure Check_Project (Project : Project_Id);
-- Look for a non aggregate project. If one is found, put its project Id
-- in Conf_Project.
-------------------
-- Check_Project --
-------------------
procedure Check_Project (Project : Project_Id) is
begin
if Project.Qualifier = Aggregate
or else
Project.Qualifier = Aggregate_Library
then
declare
List : Aggregated_Project_List := Project.Aggregated_Projects;
begin
-- Look for a non aggregate project until one is found
while Conf_Project = No_Project and then List /= null loop
Check_Project (List.Project);
List := List.Next;
end loop;
end;
else
Conf_Project := Project;
end if;
end Check_Project;
-- Start of processing for Process_Project_And_Apply_Config
begin
Main_Project := No_Project;
Automatically_Generated := False;
Process_Project_Tree_Phase_1
(In_Tree => Project_Tree,
Project => Main_Project,
Packages_To_Check => Packages_To_Check,
Success => Success,
From_Project_Node => User_Project_Node,
From_Project_Node_Tree => Project_Node_Tree,
Env => Env,
Reset_Tree => Reset_Tree,
On_New_Tree_Loaded => On_New_Tree_Loaded);
if not Success then
Main_Project := No_Project;
return;
end if;
if Project_Tree.Source_Info_File_Name /= null then
if not Is_Absolute_Path (Project_Tree.Source_Info_File_Name.all) then
declare
Obj_Dir : constant Variable_Value :=
Value_Of
(Name_Object_Dir,
Main_Project.Decl.Attributes,
Shared);
begin
if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
Get_Name_String (Main_Project.Directory.Display_Name);
else
if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
Get_Name_String (Obj_Dir.Value);
else
Name_Len := 0;
Add_Str_To_Name_Buffer
(Get_Name_String (Main_Project.Directory.Display_Name));
Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
end if;
end if;
Add_Char_To_Name_Buffer (Directory_Separator);
Add_Str_To_Name_Buffer (Project_Tree.Source_Info_File_Name.all);
Free (Project_Tree.Source_Info_File_Name);
Project_Tree.Source_Info_File_Name :=
new String'(Name_Buffer (1 .. Name_Len));
end;
end if;
Read_Source_Info_File (Project_Tree);
end if;
-- Get the first project that is not an aggregate project or an
-- aggregate library project. The object directory of this project will
-- be used to store the config project file in auto-configuration.
Check_Project (Main_Project);
-- Fail if there is only aggregate projects and aggregate library
-- projects in the project tree.
if Conf_Project = No_Project then
Raise_Invalid_Config ("there are no non-aggregate projects");
end if;
-- Find configuration file
Get_Or_Create_Configuration_File
(Config => Main_Config_Project,
Project => Main_Project,
Conf_Project => Conf_Project,
Project_Tree => Project_Tree,
Project_Node_Tree => Project_Node_Tree,
Env => Env,
Allow_Automatic_Generation => Allow_Automatic_Generation,
Config_File_Name => Config_File_Name,
Autoconf_Specified => Autoconf_Specified,
Target_Name => Target_Name,
Normalized_Hostname => Normalized_Hostname,
Packages_To_Check => Packages_To_Check,
Config_File_Path => Config_File_Path,
Automatically_Generated => Automatically_Generated,
On_Load_Config => On_Load_Config);
Apply_Config_File (Main_Config_Project, Project_Tree);
-- Finish processing the user's project
Prj.Proc.Process_Project_Tree_Phase_2
(In_Tree => Project_Tree,
Project => Main_Project,
Success => Success,
From_Project_Node => User_Project_Node,
From_Project_Node_Tree => Project_Node_Tree,
Env => Env);
if Success then
if Project_Tree.Source_Info_File_Name /= null
and then not Project_Tree.Source_Info_File_Exists
then
Write_Source_Info_File (Project_Tree);
end if;
else
Main_Project := No_Project;
end if;
end Process_Project_And_Apply_Config;
--------------------------
-- Raise_Invalid_Config --
--------------------------
procedure Raise_Invalid_Config (Msg : String) is
begin
Raise_Exception (Invalid_Config'Identity, Msg);
end Raise_Invalid_Config;
----------------------
-- Runtime_Name_For --
----------------------
function Runtime_Name_For (Language : Name_Id) return String is
begin
if RTS_Languages.Get (Language) /= No_Name then
return Get_Name_String (RTS_Languages.Get (Language));
else
return "";
end if;
end Runtime_Name_For;
--------------------------
-- Runtime_Name_Set_For --
--------------------------
function Runtime_Name_Set_For (Language : Name_Id) return Boolean is
begin
return RTS_Languages.Get (Language) /= No_Name;
end Runtime_Name_Set_For;
---------------------
-- Set_Runtime_For --
---------------------
procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is
begin
Name_Len := RTS_Name'Length;
Name_Buffer (1 .. Name_Len) := RTS_Name;
RTS_Languages.Set (Language, Name_Find);
end Set_Runtime_For;
end Prj.Conf;
gprbuild-gpl-2014-src/gnat/nlists.adb 0000644 0000767 0000145 00000107524 12323721731 017061 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- N L I S T S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, 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 3, 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. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- ");
elsif P <= Standard_Location then
Write_Str ("");
else
declare
SI : constant Source_File_Index := Get_Source_File_Index (P);
begin
Write_Name (Debug_Source_Name (SI));
Write_Char (':');
Write_Int (Int (Get_Logical_Line_Number (P)));
Write_Char (':');
Write_Int (Int (Get_Column_Number (P)));
if Instantiation (SI) /= No_Location then
Write_Str (" [");
Write_Location (Instantiation (SI));
Write_Char (']');
end if;
end;
end if;
end Write_Location;
----------------------
-- Write_Time_Stamp --
----------------------
procedure Write_Time_Stamp (S : Source_File_Index) is
T : constant Time_Stamp_Type := Time_Stamp (S);
P : Natural;
begin
if T (1) = '9' then
Write_Str ("19");
P := 0;
else
Write_Char (T (1));
Write_Char (T (2));
P := 2;
end if;
Write_Char (T (P + 1));
Write_Char (T (P + 2));
Write_Char ('-');
Write_Char (T (P + 3));
Write_Char (T (P + 4));
Write_Char ('-');
Write_Char (T (P + 5));
Write_Char (T (P + 6));
Write_Char (' ');
Write_Char (T (P + 7));
Write_Char (T (P + 8));
Write_Char (':');
Write_Char (T (P + 9));
Write_Char (T (P + 10));
Write_Char (':');
Write_Char (T (P + 11));
Write_Char (T (P + 12));
end Write_Time_Stamp;
----------------------------------------------
-- Access Subprograms for Source File Table --
----------------------------------------------
function Debug_Source_Name (S : SFI) return File_Name_Type is
begin
return Source_File.Table (S).Debug_Source_Name;
end Debug_Source_Name;
function Instance (S : SFI) return Instance_Id is
begin
return Source_File.Table (S).Instance;
end Instance;
function File_Name (S : SFI) return File_Name_Type is
begin
return Source_File.Table (S).File_Name;
end File_Name;
function File_Type (S : SFI) return Type_Of_File is
begin
return Source_File.Table (S).File_Type;
end File_Type;
function First_Mapped_Line (S : SFI) return Logical_Line_Number is
begin
return Source_File.Table (S).First_Mapped_Line;
end First_Mapped_Line;
function Full_Debug_Name (S : SFI) return File_Name_Type is
begin
return Source_File.Table (S).Full_Debug_Name;
end Full_Debug_Name;
function Full_File_Name (S : SFI) return File_Name_Type is
begin
return Source_File.Table (S).Full_File_Name;
end Full_File_Name;
function Full_Ref_Name (S : SFI) return File_Name_Type is
begin
return Source_File.Table (S).Full_Ref_Name;
end Full_Ref_Name;
function Identifier_Casing (S : SFI) return Casing_Type is
begin
return Source_File.Table (S).Identifier_Casing;
end Identifier_Casing;
function Inlined_Body (S : SFI) return Boolean is
begin
return Source_File.Table (S).Inlined_Body;
end Inlined_Body;
function Inlined_Call (S : SFI) return Source_Ptr is
begin
return Source_File.Table (S).Inlined_Call;
end Inlined_Call;
function Keyword_Casing (S : SFI) return Casing_Type is
begin
return Source_File.Table (S).Keyword_Casing;
end Keyword_Casing;
function Last_Source_Line (S : SFI) return Physical_Line_Number is
begin
return Source_File.Table (S).Last_Source_Line;
end Last_Source_Line;
function License (S : SFI) return License_Type is
begin
return Source_File.Table (S).License;
end License;
function Num_SRef_Pragmas (S : SFI) return Nat is
begin
return Source_File.Table (S).Num_SRef_Pragmas;
end Num_SRef_Pragmas;
function Reference_Name (S : SFI) return File_Name_Type is
begin
return Source_File.Table (S).Reference_Name;
end Reference_Name;
function Source_Checksum (S : SFI) return Word is
begin
return Source_File.Table (S).Source_Checksum;
end Source_Checksum;
function Source_First (S : SFI) return Source_Ptr is
begin
if S = Internal_Source_File then
return Internal_Source'First;
else
return Source_File.Table (S).Source_First;
end if;
end Source_First;
function Source_Last (S : SFI) return Source_Ptr is
begin
if S = Internal_Source_File then
return Internal_Source'Last;
else
return Source_File.Table (S).Source_Last;
end if;
end Source_Last;
function Source_Text (S : SFI) return Source_Buffer_Ptr is
begin
if S = Internal_Source_File then
return Internal_Source_Ptr;
else
return Source_File.Table (S).Source_Text;
end if;
end Source_Text;
function Template (S : SFI) return SFI is
begin
return Source_File.Table (S).Template;
end Template;
function Time_Stamp (S : SFI) return Time_Stamp_Type is
begin
return Source_File.Table (S).Time_Stamp;
end Time_Stamp;
function Unit (S : SFI) return Unit_Number_Type is
begin
return Source_File.Table (S).Unit;
end Unit;
------------------------------------------
-- Set Procedures for Source File Table --
------------------------------------------
procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
begin
Source_File.Table (S).Identifier_Casing := C;
end Set_Identifier_Casing;
procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
begin
Source_File.Table (S).Keyword_Casing := C;
end Set_Keyword_Casing;
procedure Set_License (S : SFI; L : License_Type) is
begin
Source_File.Table (S).License := L;
end Set_License;
procedure Set_Unit (S : SFI; U : Unit_Number_Type) is
begin
Source_File.Table (S).Unit := U;
end Set_Unit;
----------------------
-- Trim_Lines_Table --
----------------------
procedure Trim_Lines_Table (S : Source_File_Index) is
Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
begin
-- Release allocated storage that is no longer needed
Source_File.Table (S).Lines_Table := To_Pointer
(Memory.Realloc
(To_Address (Source_File.Table (S).Lines_Table),
Memory.size_t
(Max * (Lines_Table_Type'Component_Size / System.Storage_Unit))));
Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
end Trim_Lines_Table;
------------
-- Unlock --
------------
procedure Unlock is
begin
Source_File.Locked := False;
Source_File.Release;
end Unlock;
--------
-- wl --
--------
procedure wl (P : Source_Ptr) is
begin
Write_Location (P);
Write_Eol;
end wl;
end Sinput;
gprbuild-gpl-2014-src/gnat/prj-pp.ads 0000644 0000767 0000145 00000011732 12323721731 016771 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . P P --
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2011, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package is the Project File Pretty Printer
-- Used to output a project file from a project file tree.
-- Used by gnatname to update or create project files.
-- Also used GPS to display project file trees.
-- Also be used for debugging tools that create project file trees.
with Prj.Tree;
package Prj.PP is
-- The following access to procedure types are used to redirect output when
-- calling Pretty_Print.
type Write_Char_Ap is access procedure (C : Character);
type Write_Eol_Ap is access procedure;
type Write_Str_Ap is access procedure (S : String);
subtype Max_Length_Of_Line is Positive range 50 .. 255;
procedure Pretty_Print
(Project : Prj.Tree.Project_Node_Id;
In_Tree : Prj.Tree.Project_Node_Tree_Ref;
Increment : Positive := 3;
Eliminate_Empty_Case_Constructions : Boolean := False;
Minimize_Empty_Lines : Boolean := False;
W_Char : Write_Char_Ap := null;
W_Eol : Write_Eol_Ap := null;
W_Str : Write_Str_Ap := null;
Backward_Compatibility : Boolean;
Id : Prj.Project_Id := Prj.No_Project;
Max_Line_Length : Max_Length_Of_Line :=
Max_Length_Of_Line'Last);
-- Output a project file, using either the default output routines, or the
-- ones specified by W_Char, W_Eol and W_Str.
--
-- Increment is the number of spaces for each indentation level
--
-- W_Char, W_Eol and W_Str can be used to change the default output
-- procedures. The default values force the output to Standard_Output.
--
-- If Eliminate_Empty_Case_Constructions is True, then case constructions
-- and case items that do not include any declarations will not be output.
--
-- If Minimize_Empty_Lines is True, empty lines will be output only after
-- the last with clause, after the line declaring the project name, after
-- the last declarative item of the project and before each package
-- declaration. Otherwise, more empty lines are output.
--
-- If Backward_Compatibility is True, then new attributes (Spec,
-- Spec_Suffix, Body, Body_Suffix) will be replaced by obsolete ones
-- (Specification, Specification_Suffix, Implementation,
-- Implementation_Suffix).
--
-- Id is used to compute the display name of the project including its
-- proper casing.
--
-- Max_Line_Length is the maximum line length in the project file
private
procedure Output_Statistics;
-- This procedure can be used after one or more calls to Pretty_Print to
-- display what Project_Node_Kinds have not been exercised by the call(s)
-- to Pretty_Print. It is used only for testing purposes.
procedure wpr
(Project : Prj.Tree.Project_Node_Id;
In_Tree : Prj.Tree.Project_Node_Tree_Ref);
-- Wrapper for use from gdb: call Pretty_Print with default parameters
end Prj.PP;
gprbuild-gpl-2014-src/gnat/ali.ads 0000644 0000767 0000145 00000123165 12323721731 016332 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- A L I --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package defines the internal data structures used for representation
-- of Ada Library Information (ALI) acquired from the ALI files generated by
-- the front end.
with Casing; use Casing;
with Gnatvsn; use Gnatvsn;
with Namet; use Namet;
with Rident; use Rident;
with Table;
with Types; use Types;
with GNAT.HTable; use GNAT.HTable;
package ALI is
--------------
-- Id Types --
--------------
-- The various entries are stored in tables with distinct subscript ranges.
-- The following type definitions show the ranges used for the subscripts
-- (Id values) for the various tables.
type ALI_Id is range 0 .. 999_999;
-- Id values used for ALIs table entries
type Unit_Id is range 1_000_000 .. 1_999_999;
-- Id values used for Unit table entries
type With_Id is range 2_000_000 .. 2_999_999;
-- Id values used for Withs table entries
type Arg_Id is range 3_000_000 .. 3_999_999;
-- Id values used for argument table entries
type Sdep_Id is range 4_000_000 .. 4_999_999;
-- Id values used for Sdep table entries
type Source_Id is range 5_000_000 .. 5_999_999;
-- Id values used for Source table entries
type Interrupt_State_Id is range 6_000_000 .. 6_999_999;
-- Id values used for Interrupt_State table entries
type Priority_Specific_Dispatching_Id is range 7_000_000 .. 7_999_999;
-- Id values used for Priority_Specific_Dispatching table entries
--------------------
-- ALI File Table --
--------------------
-- Each ALI file read generates an entry in the ALIs table
No_ALI_Id : constant ALI_Id := ALI_Id'First;
-- Special value indicating no ALI entry
First_ALI_Entry : constant ALI_Id := No_ALI_Id + 1;
-- Id of first actual entry in table
type Main_Program_Type is (None, Proc, Func);
-- Indicator of whether unit can be used as main program
type ALIs_Record is record
Afile : File_Name_Type;
-- Name of ALI file
Ofile_Full_Name : File_Name_Type;
-- Full name of object file corresponding to the ALI file
Sfile : File_Name_Type;
-- Name of source file that generates this ALI file (which is equal
-- to the name of the source file in the first unit table entry for
-- this ALI file, since the body if present is always first).
Ver : String (1 .. Ver_Len_Max);
-- Value of library version (V line in ALI file). Not set if
-- V lines are ignored as a result of the Ignore_Lines parameter.
Ver_Len : Natural;
-- Length of characters stored in Ver. Not set if V lines are ignored as
-- a result of the Ignore_Lines parameter.
SAL_Interface : Boolean;
-- Set True when this is an interface to a standalone library
First_Unit : Unit_Id;
-- Id of first Unit table entry for this file
Last_Unit : Unit_Id;
-- Id of last Unit table entry for this file
First_Sdep : Sdep_Id;
-- Id of first Sdep table entry for this file
Last_Sdep : Sdep_Id;
-- Id of last Sdep table entry for this file
Main_Program : Main_Program_Type;
-- Indicator of whether first unit can be used as main program. Not set
-- if 'M' appears in Ignore_Lines.
Main_Priority : Int;
-- Indicates priority value if Main_Program field indicates that this
-- can be a main program. A value of -1 (No_Main_Priority) indicates
-- that no parameter was found, or no M line was present. Not set if
-- 'M' appears in Ignore_Lines.
Main_CPU : Int;
-- Indicates processor if Main_Program field indicates that this can
-- be a main program. A value of -1 (No_Main_CPU) indicates that no C
-- parameter was found, or no M line was present. Not set if 'M' appears
-- in Ignore_Lines.
Time_Slice_Value : Int;
-- Indicates value of time slice parameter from T=xxx on main program
-- line. A value of -1 indicates that no T=xxx parameter was found, or
-- no M line was present. Not set if 'M' appears in Ignore_Lines.
WC_Encoding : Character;
-- Wide character encoding if main procedure. Otherwise not relevant.
-- Not set if 'M' appears in Ignore_Lines.
Locking_Policy : Character;
-- Indicates locking policy for units in this file. Space means tasking
-- was not used, or that no Locking_Policy pragma was present or that
-- this is a language defined unit. Otherwise set to first character
-- (upper case) of policy name. Not set if 'P' appears in Ignore_Lines.
Partition_Elaboration_Policy : Character;
-- Indicates partition elaboration policy for units in this file. Space
-- means that no Partition_Elaboration_Policy pragma was present or that
-- this is a language defined unit. Otherwise set to first character
-- (upper case) of policy name. Not set if 'P' appears in Ignore_Lines.
Queuing_Policy : Character;
-- Indicates queuing policy for units in this file. Space means tasking
-- was not used, or that no Queuing_Policy pragma was present or that
-- this is a language defined unit. Otherwise set to first character
-- (upper case) of policy name. Not set if 'P' appears in Ignore_Lines.
Task_Dispatching_Policy : Character;
-- Indicates task dispatching policy for units in this file. Space means
-- tasking was not used, or that no Task_Dispatching_Policy pragma was
-- present or that this is a language defined unit. Otherwise set to
-- first character (upper case) of policy name. Not set if 'P' appears
-- in Ignore_Lines.
Compile_Errors : Boolean;
-- Set to True if compile errors for unit. Note that No_Object will
-- always be set as well in this case. Not set if 'P' appears in
-- Ignore_Lines.
Float_Format : Character;
-- Set to float format (set to I if no float-format given). Not set if
-- 'P' appears in Ignore_Lines.
No_Object : Boolean;
-- Set to True if no object file generated. Not set if 'P' appears in
-- Ignore_Lines.
Normalize_Scalars : Boolean;
-- Set to True if file was compiled with Normalize_Scalars. Not set if
-- 'P' appears in Ignore_Lines.
SSO_Default : Character;
-- Set to 'H' or 'L' if file was compiled with a configuration pragma
-- file containing Default_Scalar_Storage_Order (High/Low_Order_First).
-- Set to ' ' if neither pragma was present. Not set if 'P' appears in
-- Ignore_Lines.
Unit_Exception_Table : Boolean;
-- Set to True if unit exception table pointer generated. Not set if 'P'
-- appears in Ignore_Lines.
Zero_Cost_Exceptions : Boolean;
-- Set to True if file was compiled with zero cost exceptions. Not set
-- if 'P' appears in Ignore_Lines.
Restrictions : Restrictions_Info;
-- Restrictions information reconstructed from R lines
First_Interrupt_State : Interrupt_State_Id;
Last_Interrupt_State : Interrupt_State_Id'Base;
-- These point to the first and last entries in the interrupt state
-- table for this unit. If no entries, then Last_Interrupt_State =
-- First_Interrupt_State - 1 (that's why the 'Base reference is there,
-- it can be one less than the lower bound of the subtype). Not set if
-- 'I' appears in Ignore_Lines
First_Specific_Dispatching : Priority_Specific_Dispatching_Id;
Last_Specific_Dispatching : Priority_Specific_Dispatching_Id'Base;
-- These point to the first and last entries in the priority specific
-- dispatching table for this unit. If there are no entries, then
-- Last_Specific_Dispatching = First_Specific_Dispatching - 1. That
-- is why the 'Base reference is there, it can be one less than the
-- lower bound of the subtype. Not set if 'S' appears in Ignore_Lines.
end record;
No_Main_Priority : constant Int := -1;
-- Code for no main priority set
No_Main_CPU : constant Int := -1;
-- Code for no main cpu set
package ALIs is new Table.Table (
Table_Component_Type => ALIs_Record,
Table_Index_Type => ALI_Id,
Table_Low_Bound => First_ALI_Entry,
Table_Initial => 500,
Table_Increment => 200,
Table_Name => "ALIs");
----------------
-- Unit Table --
----------------
-- Each unit within an ALI file generates an entry in the unit table
No_Unit_Id : constant Unit_Id := Unit_Id'First;
-- Special value indicating no unit table entry
First_Unit_Entry : constant Unit_Id := No_Unit_Id + 1;
-- Id of first actual entry in table
type Unit_Type is (Is_Spec, Is_Body, Is_Spec_Only, Is_Body_Only);
-- Indicates type of entry, if both body and spec appear in the ALI file,
-- then the first unit is marked Is_Body, and the second is marked Is_Spec.
-- If only a spec appears, then it is marked as Is_Spec_Only, and if only
-- a body appears, then it is marked Is_Body_Only).
subtype Version_String is String (1 .. 8);
-- Version string, taken from unit record
type Unit_Record is record
My_ALI : ALI_Id;
-- Corresponding ALI entry
Uname : Unit_Name_Type;
-- Name of Unit
Sfile : File_Name_Type;
-- Name of source file
Preelab : Boolean;
-- Indicates presence of PR parameter for a preelaborated package
No_Elab : Boolean;
-- Indicates presence of NE parameter for a unit that has does not
-- have an elaboration routine (since it has no elaboration code).
Pure : Boolean;
-- Indicates presence of PU parameter for a package having pragma Pure
Dynamic_Elab : Boolean;
-- Set to True if the unit was compiled with dynamic elaboration checks
-- (i.e. either -gnatE or pragma Elaboration_Checks (RM) was used to
-- compile the unit).
Elaborate_Body : Boolean;
-- Indicates presence of EB parameter for a package which has a pragma
-- Elaborate_Body, and also for generic package instantiations.
Set_Elab_Entity : Boolean;
-- Indicates presence of EE parameter for a unit which has an
-- elaboration entity which must be set true as part of the
-- elaboration of the unit.
Has_RACW : Boolean;
-- Indicates presence of RA parameter for a package that declares at
-- least one Remote Access to Class_Wide (RACW) object.
Remote_Types : Boolean;
-- Indicates presence of RT parameter for a package which has a
-- pragma Remote_Types.
Shared_Passive : Boolean;
-- Indicates presence of SP parameter for a package which has a pragma
-- Shared_Passive.
RCI : Boolean;
-- Indicates presence of RC parameter for a package which has a pragma
-- Remote_Call_Interface.
Predefined : Boolean;
-- Indicates if unit is language predefined (or a child of such a unit)
Internal : Boolean;
-- Indicates if unit is an internal unit (or a child of such a unit)
First_With : With_Id;
-- Id of first withs table entry for this file
Last_With : With_Id;
-- Id of last withs table entry for this file
First_Arg : Arg_Id;
-- Id of first args table entry for this file
Last_Arg : Arg_Id;
-- Id of last args table entry for this file
Utype : Unit_Type;
-- Type of entry
Is_Generic : Boolean;
-- True for generic unit (i.e. a generic declaration, or a generic
-- body). False for a non-generic unit.
Unit_Kind : Character;
-- Indicates the nature of the unit. 'p' for Packages and 's' for
-- subprograms.
Version : Version_String;
-- Version of unit
Icasing : Casing_Type;
-- Indicates casing of identifiers in source file for this unit. This
-- is used for informational output, and also for constructing the main
-- unit if it is being built in Ada.
Kcasing : Casing_Type;
-- Indicates casing of keywords in source file for this unit. This is
-- used for informational output, and also for constructing the main
-- unit if it is being built in Ada.
Elab_Position : aliased Natural;
-- Initialized to zero. Set non-zero when a unit is chosen and
-- placed in the elaboration order. The value represents the
-- ordinal position in the elaboration order.
Init_Scalars : Boolean;
-- Set True if IS qualifier appears in ALI file, indicating that
-- an Initialize_Scalars pragma applies to the unit.
SAL_Interface : Boolean;
-- Set True when this is an interface to a standalone library
Directly_Scanned : Boolean;
-- True iff it is a unit from an ALI file specified to gnatbind
Body_Needed_For_SAL : Boolean;
-- Indicates that the source for the body of the unit (subprogram,
-- package, or generic unit) must be included in a standalone library.
Elaborate_Body_Desirable : Boolean;
-- Indicates that the front end elaboration circuitry decided that it
-- would be a good idea if this package had Elaborate_Body. The binder
-- will attempt, but does not promise, to place the elaboration call
-- for the body right after the call for the spec, or at least as close
-- together as possible.
Optimize_Alignment : Character;
-- Optimize_Alignment setting. Set to L/S/T/O for OL/OS/OT/OO present
Has_Finalizer : Boolean;
-- Indicates whether a package body or a spec has a library-level
-- finalization routine.
end record;
package Units is new Table.Table (
Table_Component_Type => Unit_Record,
Table_Index_Type => Unit_Id,
Table_Low_Bound => First_Unit_Entry,
Table_Initial => 100,
Table_Increment => 200,
Table_Name => "Unit");
---------------------------
-- Interrupt State Table --
---------------------------
-- An entry is made in this table for each I (interrupt state) line
-- encountered in the input ALI file. The First/Last_Interrupt_Id
-- fields of the ALI file entry show the range of entries defined
-- within a particular ALI file.
type Interrupt_State_Record is record
Interrupt_Id : Nat;
-- Id from interrupt state entry
Interrupt_State : Character;
-- State from interrupt state entry ('u'/'r'/'s')
IS_Pragma_Line : Nat;
-- Line number of Interrupt_State pragma
end record;
package Interrupt_States is new Table.Table (
Table_Component_Type => Interrupt_State_Record,
Table_Index_Type => Interrupt_State_Id'Base,
Table_Low_Bound => Interrupt_State_Id'First,
Table_Initial => 100,
Table_Increment => 200,
Table_Name => "Interrupt_States");
-----------------------------------------
-- Priority Specific Dispatching Table --
-----------------------------------------
-- An entry is made in this table for each S (priority specific
-- dispatching) line encountered in the input ALI file. The
-- First/Last_Specific_Dispatching_Id fields of the ALI file
-- entry show the range of entries defined within a particular
-- ALI file.
type Specific_Dispatching_Record is record
Dispatching_Policy : Character;
-- First character (upper case) of the corresponding policy name
First_Priority : Nat;
-- Lower bound of the priority range to which the specified dispatching
-- policy applies.
Last_Priority : Nat;
-- Upper bound of the priority range to which the specified dispatching
-- policy applies.
PSD_Pragma_Line : Nat;
-- Line number of Priority_Specific_Dispatching pragma
end record;
package Specific_Dispatching is new Table.Table (
Table_Component_Type => Specific_Dispatching_Record,
Table_Index_Type => Priority_Specific_Dispatching_Id'Base,
Table_Low_Bound => Priority_Specific_Dispatching_Id'First,
Table_Initial => 100,
Table_Increment => 200,
Table_Name => "Priority_Specific_Dispatching");
--------------
-- Switches --
--------------
-- These switches record status information about ali files that
-- have been read, for quick reference without searching tables.
-- Note: a switch will be left set at its default value if the line
-- which might otherwise set it is ignored (from Ignore_Lines).
Dynamic_Elaboration_Checks_Specified : Boolean := False;
-- Set to False by Initialize_ALI. Set to True if Scan_ALI reads
-- a unit for which dynamic elaboration checking is enabled.
Float_Format_Specified : Character := ' ';
-- Set to blank by Initialize_ALI. Set to appropriate float format
-- character (V or I, see Opt.Float_Format) if an ali file that
-- is read contains an F line setting the floating point format.
Initialize_Scalars_Used : Boolean := False;
-- Set True if an ali file contains the Initialize_Scalars flag
Locking_Policy_Specified : Character := ' ';
-- Set to blank by Initialize_ALI. Set to the appropriate locking policy
-- character if an ali file contains a P line setting the locking policy.
No_Normalize_Scalars_Specified : Boolean := False;
-- Set to False by Initialize_ALI. Set to True if an ali file indicates
-- that the file was compiled without normalize scalars.
No_Object_Specified : Boolean := False;
-- Set to False by Initialize_ALI. Set to True if an ali file contains
-- the No_Object flag.
Normalize_Scalars_Specified : Boolean := False;
-- Set to False by Initialize_ALI. Set to True if an ali file indicates
-- that the file was compiled in Normalize_Scalars mode.
Partition_Elaboration_Policy_Specified : Character := ' ';
-- Set to blank by Initialize_ALI. Set to the appropriate partition
-- elaboration policy character if an ali file contains a P line setting
-- the policy.
Queuing_Policy_Specified : Character := ' ';
-- Set to blank by Initialize_ALI. Set to the appropriate queuing policy
-- character if an ali file contains a P line setting the queuing policy.
Cumulative_Restrictions : Restrictions_Info := No_Restrictions;
-- This variable records the cumulative contributions of R lines in all
-- ali files, showing whether a restriction pragma exists anywhere, and
-- accumulating the aggregate knowledge of violations.
SSO_Default_Specified : Boolean := False;
-- Set to True if at least one ALI file contains an OH/OL flag indicating
-- that it was compiled with a configuration pragmas file containing the
-- pragma Default_Scalar_Storage_Order (OH/OL present in ALI file P line).
Stack_Check_Switch_Set : Boolean := False;
-- Set to True if at least one ALI file contains '-fstack-check' in its
-- argument list.
Static_Elaboration_Model_Used : Boolean := False;
-- Set to False by Initialize_ALI. Set to True if any ALI file for a
-- non-internal unit compiled with the static elaboration model is
-- encountered.
Task_Dispatching_Policy_Specified : Character := ' ';
-- Set to blank by Initialize_ALI. Set to the appropriate task dispatching
-- policy character if an ali file contains a P line setting the
-- task dispatching policy.
Unreserve_All_Interrupts_Specified : Boolean := False;
-- Set to False by Initialize_ALI. Set to True if an ali file is read that
-- has P line specifying unreserve all interrupts mode.
Zero_Cost_Exceptions_Specified : Boolean := False;
-- Set to False by Initialize_ALI. Set to True if an ali file is read that
-- has a P line specifying the generation of zero cost exceptions.
-----------------
-- Withs Table --
-----------------
-- Each With line (W line) in an ALI file generates a Withs table entry
-- Note: there will be no entries in this table if 'W' lines are ignored
No_With_Id : constant With_Id := With_Id'First;
-- Special value indicating no withs table entry
First_With_Entry : constant With_Id := No_With_Id + 1;
-- Id of first actual entry in table
type With_Record is record
Uname : Unit_Name_Type;
-- Name of Unit
Sfile : File_Name_Type;
-- Name of source file, set to No_File in generic case
Afile : File_Name_Type;
-- Name of ALI file, set to No_File in generic case
Elaborate : Boolean;
-- Indicates presence of E parameter
Elaborate_All : Boolean;
-- Indicates presence of EA parameter
Elab_All_Desirable : Boolean;
-- Indicates presence of AD parameter
Elab_Desirable : Boolean;
-- Indicates presence of ED parameter
SAL_Interface : Boolean := False;
-- True if the Unit is an Interface of a Stand-Alone Library
Limited_With : Boolean := False;
-- True if unit is named in a limited_with_clause
Implicit_With_From_Instantiation : Boolean := False;
-- True if this is an implicit with from a generic instantiation
end record;
package Withs is new Table.Table (
Table_Component_Type => With_Record,
Table_Index_Type => With_Id,
Table_Low_Bound => First_With_Entry,
Table_Initial => 5000,
Table_Increment => 200,
Table_Name => "Withs");
---------------------
-- Arguments Table --
---------------------
-- Each Arg line (A line) in an ALI file generates an Args table entry
-- Note: there will be no entries in this table if 'A' lines are ignored
No_Arg_Id : constant Arg_Id := Arg_Id'First;
-- Special value indicating no args table entry
First_Arg_Entry : constant Arg_Id := No_Arg_Id + 1;
-- Id of first actual entry in table
package Args is new Table.Table (
Table_Component_Type => String_Ptr,
Table_Index_Type => Arg_Id,
Table_Low_Bound => First_Arg_Entry,
Table_Initial => 1000,
Table_Increment => 100,
Table_Name => "Args");
--------------------------
-- Linker_Options Table --
--------------------------
-- If an ALI file has one of more Linker_Options lines, then a single
-- entry is made in this table. If more than one Linker_Options lines
-- appears in a given ALI file, then the arguments are concatenated
-- to form the entry in this table, using a NUL character as the
-- separator, and a final NUL character is appended to the end.
-- Note: there will be no entries in this table if 'L' lines are ignored
type Linker_Option_Record is record
Name : Name_Id;
-- Name entry containing concatenated list of Linker_Options
-- arguments separated by NUL and ended by NUL as described above.
Unit : Unit_Id;
-- Unit_Id for the entry
Internal_File : Boolean;
-- Set True if the linker options are from an internal file. This is
-- used to insert certain standard entries after all the user entries
-- but before the entries from the run-time.
Original_Pos : Positive;
-- Keep track of original position in the linker options table. This
-- is used to implement a stable sort when we sort the linker options
-- table.
end record;
-- The indexes of active entries in this table range from 1 to the
-- value of Linker_Options.Last. The zero'th element is for sort call.
package Linker_Options is new Table.Table (
Table_Component_Type => Linker_Option_Record,
Table_Index_Type => Integer,
Table_Low_Bound => 0,
Table_Initial => 200,
Table_Increment => 400,
Table_Name => "Linker_Options");
-----------------
-- Notes Table --
-----------------
-- The notes table records entries from N lines
type Notes_Record is record
Pragma_Type : Character;
-- 'A', 'C', 'I', 'S', 'T' for Annotate/Comment/Ident/Subtitle/Title
Pragma_Line : Nat;
-- Line number of pragma
Pragma_Col : Nat;
-- Column number of pragma
Unit : Unit_Id;
-- Unit_Id for the entry
Pragma_Args : Name_Id;
-- Pragma arguments. No_Name if no arguments, otherwise a single
-- name table entry consisting of all the characters on the notes
-- line from the first non-blank character following the source
-- location to the last character on the line.
end record;
-- The indexes of active entries in this table range from 1 to the
-- value of Linker_Options.Last. The zero'th element is for convenience
-- if the table needs to be sorted.
package Notes is new Table.Table (
Table_Component_Type => Notes_Record,
Table_Index_Type => Integer,
Table_Low_Bound => 0,
Table_Initial => 200,
Table_Increment => 400,
Table_Name => "Notes");
-------------------------------------------
-- External Version Reference Hash Table --
-------------------------------------------
-- This hash table keeps track of external version reference strings
-- as read from E lines in the ali file. The stored values do not
-- include the terminating quote characters.
-- Note: there will be no entries in this table if 'E' lines are ignored
type Vindex is range 0 .. 98;
-- Type to define range of headers
function SHash (S : String_Ptr) return Vindex;
-- Hash function for this table
function SEq (F1, F2 : String_Ptr) return Boolean;
-- Equality function for this table
package Version_Ref is new Simple_HTable (
Header_Num => Vindex,
Element => Boolean,
No_Element => False,
Key => String_Ptr,
Hash => SHash,
Equal => SEq);
-------------------------
-- No_Dependency Table --
-------------------------
-- Each R line for a No_Dependency Restriction generates an entry in
-- this No_Dependency table.
type No_Dep_Record is record
ALI_File : ALI_Id;
-- ALI File containing the entry
No_Dep_Unit : Name_Id;
-- Id for names table entry including entire name, including periods
end record;
package No_Deps is new Table.Table (
Table_Component_Type => No_Dep_Record,
Table_Index_Type => Integer,
Table_Low_Bound => 0,
Table_Initial => 200,
Table_Increment => 400,
Table_Name => "No_Deps");
------------------------------------
-- Sdep (Source Dependency) Table --
------------------------------------
-- Each source dependency (D line) in an ALI file generates an entry in the
-- Sdep table.
-- Note: there will be no entries in this table if 'D' lines are ignored
No_Sdep_Id : constant Sdep_Id := Sdep_Id'First;
-- Special value indicating no Sdep table entry
First_Sdep_Entry : Sdep_Id := No_Sdep_Id + 1;
-- Id of first Sdep entry for current ali file. This is initialized to the
-- first Sdep entry in the table, and then incremented appropriately as
-- successive ALI files are scanned.
type Sdep_Record is record
Sfile : File_Name_Type;
-- Name of source file
Stamp : Time_Stamp_Type;
-- Time stamp value. Note that this will be all zero characters for the
-- dummy entries for missing or non-dependent files.
Checksum : Word;
-- Checksum value. Note that this will be all zero characters for the
-- dummy entries for missing or non-dependent files
Dummy_Entry : Boolean;
-- Set True for dummy entries that correspond to missing files or files
-- where no dependency relationship exists.
Subunit_Name : Name_Id;
-- Name_Id for subunit name if present, else No_Name
Unit_Name : Name_Id;
-- Name_Id for the unit name if not a subunit (No_Name for a subunit)
Rfile : File_Name_Type;
-- Reference file name. Same as Sfile unless a Source_Reference pragma
-- was used, in which case it reflects the name used in the pragma.
Start_Line : Nat;
-- Starting line number in file. Always 1, unless a Source_Reference
-- pragma was used, in which case it reflects the line number value
-- given in the pragma.
end record;
package Sdep is new Table.Table (
Table_Component_Type => Sdep_Record,
Table_Index_Type => Sdep_Id,
Table_Low_Bound => First_Sdep_Entry,
Table_Initial => 5000,
Table_Increment => 200,
Table_Name => "Sdep");
----------------------------
-- Use of Name Table Info --
----------------------------
-- All unit names and file names are entered into the Names table. The Info
-- fields of these entries are used as follows:
-- Unit name Info field has Unit_Id of unit table entry
-- ALI file name Info field has ALI_Id of ALI table entry
-- Source file name Info field has Source_Id of source table entry
--------------------------
-- Cross-Reference Data --
--------------------------
-- The following table records cross-reference sections, there is one entry
-- for each X header line in the ALI file for an xref section.
-- Note: there will be no entries in this table if 'X' lines are ignored
type Xref_Section_Record is record
File_Num : Sdep_Id;
-- Dependency number for file (entry in Sdep.Table)
File_Name : File_Name_Type;
-- Name of file
First_Entity : Nat;
-- First entry in Xref_Entity table
Last_Entity : Nat;
-- Last entry in Xref_Entity table
end record;
package Xref_Section is new Table.Table (
Table_Component_Type => Xref_Section_Record,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 50,
Table_Increment => 300,
Table_Name => "Xref_Section");
-- The following is used to indicate whether a typeref field is present
-- for the entity, and if so what kind of typeref field.
type Tref_Kind is (
Tref_None, -- No typeref present
Tref_Access, -- Access type typeref (points to designated type)
Tref_Derived, -- Derived type typeref (points to parent type)
Tref_Type); -- All other cases
type Visibility_Kind is
(Global, -- Library level entity
Static, -- Static C/C++ entity
Other); -- Local and other entity
-- The following table records entities for which xrefs are recorded
type Xref_Entity_Record is record
Line : Pos;
-- Line number of definition
Etype : Character;
-- Set to the identification character for the entity. See section
-- "Cross-Reference Entity Identifiers" in lib-xref.ads for details.
Col : Pos;
-- Column number of definition
Visibility : Visibility_Kind;
-- Visibility of entity
Entity : Name_Id;
-- Name of entity
Iref_File_Num : Sdep_Id;
-- This field is set to the dependency reference for the file containing
-- the generic entity that this one instantiates, or to No_Sdep_Id if
-- the current entity is not an instantiation
Iref_Line : Nat;
-- This field is set to the line number in Iref_File_Num of the generic
-- entity that this one instantiates, or to zero if the current entity
-- is not an instantiation.
Rref_Line : Nat;
-- This field is set to the line number of a renaming reference if
-- one is present, or to zero if no renaming reference is present
Rref_Col : Nat;
-- This field is set to the column number of a renaming reference
-- if one is present, or to zero if no renaming reference is present.
Tref : Tref_Kind;
-- Indicates if a typeref is present, and if so what kind. Set to
-- Tref_None if no typeref field is present.
Tref_File_Num : Sdep_Id;
-- This field is set to No_Sdep_Id if no typeref is present, or
-- if the typeref refers to an entity in standard. Otherwise it
-- it is the dependency reference for the file containing the
-- declaration of the typeref entity.
Tref_Line : Nat;
-- This field is set to zero if no typeref is present, or if the
-- typeref refers to an entity in standard. Otherwise it contains
-- the line number of the declaration of the typeref entity.
Tref_Type : Character;
-- This field is set to blank if no typeref is present, or if the
-- typeref refers to an entity in standard. Otherwise it contains
-- the identification character for the typeref entity. See section
-- "Cross-Reference Entity Identifiers" in lib-xref.ads for details.
Tref_Col : Nat;
-- This field is set to zero if no typeref is present, or if the
-- typeref refers to an entity in standard. Otherwise it contains
-- the column number of the declaration of the parent type.
Tref_Standard_Entity : Name_Id;
-- This field is set to No_Name if no typeref is present or if the
-- typeref refers to a declared entity rather than an entity in
-- package Standard. If there is a typeref that references an
-- entity in package Standard, then this field is a Name_Id
-- reference for the entity name.
Oref_File_Num : Sdep_Id;
-- This field is set to No_Sdep_Id if the entity doesn't override any
-- other entity, or to the dependency reference for the overridden
-- entity.
Oref_Line : Nat;
Oref_Col : Nat;
-- These two fields are set to the line and column of the overridden
-- entity.
First_Xref : Nat;
-- Index into Xref table of first cross-reference
Last_Xref : Nat;
-- Index into Xref table of last cross-reference. The value in
-- Last_Xref can be less than the First_Xref value to indicate
-- that no entries are present in the Xref Table.
end record;
package Xref_Entity is new Table.Table (
Table_Component_Type => Xref_Entity_Record,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 500,
Table_Increment => 300,
Table_Name => "Xref_Entity");
Array_Index_Reference : constant Character := '*';
Interface_Reference : constant Character := 'I';
-- Some special types of references. In the ALI file itself, these
-- are output as attributes of the entity, not as references, but
-- there is no provision in Xref_Entity_Record for storing multiple
-- such references.
-- The following table records actual cross-references
type Xref_Record is record
File_Num : Sdep_Id;
-- Set to the file dependency number for the cross-reference. Note
-- that if no file entry is present explicitly, this is just a copy
-- of the reference for the current cross-reference section.
Line : Nat;
-- Line number for the reference. This is zero when referencing a
-- predefined entity, but in this case Name is set.
Rtype : Character;
-- Indicates type of reference, using code used in ALI file:
-- r = reference
-- m = modification
-- b = body entity
-- c = completion of private or incomplete type
-- x = type extension
-- i = implicit reference
-- Array_Index_Reference = reference to the index of an array
-- Interface_Reference = reference to an interface implemented
-- by the type
-- See description in lib-xref.ads for further details
Col : Nat;
-- Column number for the reference
Name : Name_Id := No_Name;
-- This is only used when referencing a predefined entity. Currently,
-- this only occurs for array indexes.
-- Note: for instantiation references, Rtype is set to ' ', and Col is
-- set to zero. One or more such entries can follow any other reference.
-- When there is more than one such entry, this is to be read as:
-- e.g. ref1 ref2 ref3
-- ref1 is a reference to an entity that was instantied at ref2.
-- ref2 itself is also the result of an instantiation, that took
-- place at ref3
Imported_Lang : Name_Id := No_Name;
Imported_Name : Name_Id := No_Name;
-- Language and name of imported entity reference
end record;
package Xref is new Table.Table (
Table_Component_Type => Xref_Record,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 2000,
Table_Increment => 300,
Table_Name => "Xref");
--------------------------------------
-- Subprograms for Reading ALI File --
--------------------------------------
procedure Initialize_ALI;
-- Initialize the ALI tables. Also resets all switch values to defaults
function Scan_ALI
(F : File_Name_Type;
T : Text_Buffer_Ptr;
Ignore_ED : Boolean;
Err : Boolean;
Read_Xref : Boolean := False;
Read_Lines : String := "";
Ignore_Lines : String := "X";
Ignore_Errors : Boolean := False;
Directly_Scanned : Boolean := False) return ALI_Id;
-- Given the text, T, of an ALI file, F, scan and store the information
-- from the file, and return the Id of the resulting entry in the ALI
-- table. Switch settings may be modified as described above in the
-- switch description settings.
--
-- Ignore_ED is normally False. If set to True, it indicates that
-- all AD/ED (elaboration desirable) indications in the ALI file are
-- to be ignored. This parameter is obsolete now that the -f switch
-- is removed from gnatbind, and should be removed ???
--
-- Err determines the action taken on an incorrectly formatted file.
-- If Err is False, then an error message is output, and the program
-- is terminated. If Err is True, then no error message is output,
-- and No_ALI_Id is returned.
--
-- Ignore_Lines requests that Scan_ALI ignore any lines that start
-- with any given key character. The default value of X causes all
-- Xref lines to be ignored. The corresponding data in the ALI
-- tables will not be filled in this case. It is not possible
-- to ignore U (unit) lines, they are always read.
--
-- Read_Lines requests that Scan_ALI process only lines that start
-- with one of the given characters. The corresponding data in the
-- ALI file for any characters not given in the list will not be
-- set. The default value of the null string indicates that all
-- lines should be read (unless Ignore_Lines is specified). U
-- (unit) lines are always read regardless of the value of this
-- parameter.
--
-- Note: either Ignore_Lines or Read_Lines should be non-null, but not
-- both. If both are provided then only the Read_Lines value is used,
-- and the Ignore_Lines parameter is ignored.
--
-- Read_XREF is set True to read and acquire the cross-reference
-- information. If Read_XREF is set to True, then the effect is to ignore
-- all lines other than U, W, D and X lines and the Ignore_Lines and
-- Read_Lines parameters are ignored (i.e. the use of True for Read_XREF
-- is equivalent to specifying an argument of "UWDX" for Read_Lines.
--
-- Ignore_Errors is normally False. If it is set True, then Scan_ALI
-- will do its best to scan through a file and extract all information
-- it can, even if there are errors. In this case Err is only set if
-- Scan_ALI was completely unable to process the file (e.g. it did not
-- look like an ALI file at all). Ignore_Errors is intended to improve
-- the downward compatibility of new compilers with old tools.
--
-- Directly_Scanned is normally False. If it is set to True, then the
-- units (spec and/or body) corresponding to the ALI file are marked as
-- such. It is used to decide for what units gnatbind should generate
-- the symbols corresponding to 'Version or 'Body_Version in
-- Stand-Alone Libraries.
end ALI;
gprbuild-gpl-2014-src/gnat/sinput-p.ads 0000644 0000767 0000145 00000010451 12323721731 017335 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S I N P U T . P --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2010, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This child package contains the routines used to actually load a project
-- file and create entries in the source file table. It also contains two
-- routines to save and restore a project scan context.
with Scans; use Scans;
package Sinput.P is
procedure Clear_Source_File_Table;
-- This procedure frees memory allocated in the Source_File table (in the
-- private part of package Sinput). It should only be used when it is
-- guaranteed that all source files that have been loaded so far will not
-- be accessed before being reloaded. It is intended for tools that parse
-- several times sources, to avoid memory leaks.
function Load_Project_File (Path : String) return Source_File_Index;
-- Load the source of a project source file into memory and initialize the
-- Scans state.
procedure Reset_First;
-- Indicate that the next project loaded should be considered as the first
-- one, so that Sinput.Main_Source_File is set for this project file. This
-- is to get the correct number of lines when error finalization is called.
function Source_File_Is_Subunit (X : Source_File_Index) return Boolean;
-- This function determines if a source file represents a subunit. It works
-- by scanning for the first compilation unit token, and returning True if
-- it is the token SEPARATE. It will return False otherwise, meaning that
-- the file cannot possibly be a legal subunit. This function does NOT do a
-- complete parse of the file, or build a tree. It is used in gnatmake and
-- gprbuild to decide if a body without a spec in a project file needs to
-- be compiled or not. Returns False if X = No_Source_File.
type Saved_Project_Scan_State is limited private;
-- Used to save project scan state in following two routines
procedure Save_Project_Scan_State
(Saved_State : out Saved_Project_Scan_State);
pragma Inline (Save_Project_Scan_State);
-- Save the Scans state, as well as the values of Source and
-- Current_Source_File.
procedure Restore_Project_Scan_State
(Saved_State : Saved_Project_Scan_State);
pragma Inline (Restore_Project_Scan_State);
-- Restore the Scans state and the values of Source and
-- Current_Source_File.
private
type Saved_Project_Scan_State is record
Scan_State : Saved_Scan_State;
Source : Source_Buffer_Ptr;
Current_Source_File : Source_File_Index;
end record;
end Sinput.P;
gprbuild-gpl-2014-src/gnat/prj-attr.ads 0000644 0000767 0000145 00000034607 12323721731 017332 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . A T T R --
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2013, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package defines packages and attributes in GNAT project files.
-- There are predefined packages and attributes.
-- It is also possible to define new packages with their attributes
with Table;
with GNAT.Strings;
package Prj.Attr is
function Package_Name_List return GNAT.Strings.String_List;
-- Returns the list of valid package names, including those added by
-- procedures Register_New_Package below. The String_Access components of
-- the returned String_List should never be freed.
procedure Initialize;
-- Initialize the predefined project level attributes and the predefined
-- packages and their attribute. This procedure should be called by
-- Prj.Initialize.
type Attribute_Kind is (
Unknown,
-- The attribute does not exist
Single,
-- Single variable attribute (not an associative array)
Associative_Array,
-- Associative array attribute with a case sensitive index
Optional_Index_Associative_Array,
-- Associative array attribute with a case sensitive index and an
-- optional source index.
Case_Insensitive_Associative_Array,
-- Associative array attribute with a case insensitive index
Optional_Index_Case_Insensitive_Associative_Array
-- Associative array attribute with a case insensitive index and an
-- optional source index.
);
-- Characteristics of an attribute. Optional_Index indicates that there
-- may be an optional index in the index of the associative array, as in
-- for Switches ("files.ada" at 2) use ...
subtype Defined_Attribute_Kind is Attribute_Kind
range Single .. Optional_Index_Case_Insensitive_Associative_Array;
-- Subset of Attribute_Kinds that may be used for the attributes that is
-- used when defining a new package.
subtype All_Case_Insensitive_Associative_Array is Attribute_Kind range
Case_Insensitive_Associative_Array ..
Optional_Index_Case_Insensitive_Associative_Array;
-- Subtype including both cases of Case_Insensitive_Associative_Array
Max_Attribute_Name_Length : constant := 64;
-- The maximum length of attribute names
subtype Attribute_Name_Length is
Positive range 1 .. Max_Attribute_Name_Length;
type Attribute_Data (Name_Length : Attribute_Name_Length := 1) is record
Name : String (1 .. Name_Length);
-- The name of the attribute
Attr_Kind : Defined_Attribute_Kind;
-- The type of the attribute
Index_Is_File_Name : Boolean;
-- For associative arrays, indicate if the index is a file name, so
-- that the attribute kind may be modified depending on the case
-- sensitivity of file names. This is only taken into account when
-- Attr_Kind is Associative_Array or Optional_Index_Associative_Array.
Opt_Index : Boolean;
-- True if there may be an optional index in the value of the index,
-- as in:
-- "file.ada" at 2
-- ("main.adb", "file.ada" at 1)
Var_Kind : Defined_Variable_Kind;
-- The attribute value kind: single or list
end record;
-- Name and characteristics of an attribute in a package registered
-- explicitly with Register_New_Package (see below).
type Attribute_Data_Array is array (Positive range <>) of Attribute_Data;
-- A list of attribute name/characteristics to be used as parameter of
-- procedure Register_New_Package below.
-- In the subprograms below, when it is specified that the subprogram
-- "fails", procedure Prj.Com.Fail is called. Unless it is specified
-- otherwise, if Prj.Com.Fail returns, exception Prj.Prj_Error is raised.
procedure Register_New_Package
(Name : String;
Attributes : Attribute_Data_Array);
-- Add a new package with its attributes. This procedure can only be
-- called after Initialize, but before any other call to a service of
-- the Project Manager. Fail if the name of the package is empty or not
-- unique, or if the names of the attributes are not different.
----------------
-- Attributes --
----------------
type Attribute_Node_Id is private;
-- The type to refers to an attribute, self-initialized
Empty_Attribute : constant Attribute_Node_Id;
-- Indicates no attribute. Default value of Attribute_Node_Id objects
Attribute_First : constant Attribute_Node_Id;
-- First attribute node id of project level attributes
function Attribute_Node_Id_Of
(Name : Name_Id;
Starting_At : Attribute_Node_Id) return Attribute_Node_Id;
-- Returns the node id of an attribute at the project level or in
-- a package. Starting_At indicates the first known attribute node where
-- to start the search. Returns Empty_Attribute if the attribute cannot
-- be found.
function Attribute_Kind_Of
(Attribute : Attribute_Node_Id) return Attribute_Kind;
-- Returns the attribute kind of a known attribute. Returns Unknown if
-- Attribute is Empty_Attribute.
--
-- To use this function, the following code should be used:
--
-- Pkg : constant Package_Node_Id :=
-- Prj.Attr.Package_Node_Id_Of (Name => );
-- Att : constant Attribute_Node_Id :=
-- Prj.Attr.Attribute_Node_Id_Of
-- (Name => ,
-- Starting_At => First_Attribute_Of (Pkg));
-- Kind : constant Attribute_Kind := Attribute_Kind_Of (Att);
--
-- However, do not use this function once you have an already parsed
-- project tree. Instead, given a Project_Node_Id corresponding to the
-- attribute declaration ("for Attr (index) use ..."), use for example:
--
-- if Case_Insensitive (Attr, Tree) then ...
procedure Set_Attribute_Kind_Of
(Attribute : Attribute_Node_Id;
To : Attribute_Kind);
-- Set the attribute kind of a known attribute. Does nothing if
-- Attribute is Empty_Attribute.
function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id;
-- Returns the name of a known attribute. Returns No_Name if Attribute is
-- Empty_Attribute.
function Variable_Kind_Of
(Attribute : Attribute_Node_Id) return Variable_Kind;
-- Returns the variable kind of a known attribute. Returns Undefined if
-- Attribute is Empty_Attribute.
procedure Set_Variable_Kind_Of
(Attribute : Attribute_Node_Id;
To : Variable_Kind);
-- Set the variable kind of a known attribute. Does nothing if Attribute is
-- Empty_Attribute.
function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean;
-- Returns True if Attribute is a known attribute and may have an
-- optional index. Returns False otherwise.
function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean;
function Next_Attribute
(After : Attribute_Node_Id) return Attribute_Node_Id;
-- Returns the attribute that follow After in the list of project level
-- attributes or the list of attributes in a package.
-- Returns Empty_Attribute if After is either Empty_Attribute or is the
-- last of the list.
function Others_Allowed_For (Attribute : Attribute_Node_Id) return Boolean;
-- True iff the index for an associative array attributes may be others
--------------
-- Packages --
--------------
type Package_Node_Id is private;
-- Type to refer to a package, self initialized
Empty_Package : constant Package_Node_Id;
-- Default value of Package_Node_Id objects
Unknown_Package : constant Package_Node_Id;
-- Value of an unknown package that has been found but is unknown
procedure Register_New_Package (Name : String; Id : out Package_Node_Id);
-- Add a new package. Fails if Name (the package name) is empty or is
-- already the name of a package, and set Id to Empty_Package,
-- if Prj.Com.Fail returns. Initially, the new package has no attributes.
-- Id may be used to add attributes using procedure Register_New_Attribute
-- below.
procedure Register_New_Attribute
(Name : String;
In_Package : Package_Node_Id;
Attr_Kind : Defined_Attribute_Kind;
Var_Kind : Defined_Variable_Kind;
Index_Is_File_Name : Boolean := False;
Opt_Index : Boolean := False);
-- Add a new attribute to registered package In_Package. Fails if Name
-- (the attribute name) is empty, if In_Package is Empty_Package or if
-- the attribute name has a duplicate name. See definition of type
-- Attribute_Data above for the meaning of parameters Attr_Kind, Var_Kind,
-- Index_Is_File_Name and Opt_Index.
function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id;
-- Returns the package node id of the package with name Name. Returns
-- Empty_Package if there is no package with this name.
function First_Attribute_Of
(Pkg : Package_Node_Id) return Attribute_Node_Id;
-- Returns the first attribute in the list of attributes of package Pkg.
-- Returns Empty_Attribute if Pkg is Empty_Package or Unknown_Package.
private
----------------
-- Attributes --
----------------
Attributes_Initial : constant := 50;
Attributes_Increment : constant := 100;
Attribute_Node_Low_Bound : constant := 0;
Attribute_Node_High_Bound : constant := 099_999_999;
type Attr_Node_Id is
range Attribute_Node_Low_Bound .. Attribute_Node_High_Bound;
-- Index type for table Attrs in the body
type Attribute_Node_Id is record
Value : Attr_Node_Id := Attribute_Node_Low_Bound;
end record;
-- Full declaration of self-initialized private type
Empty_Attr : constant Attr_Node_Id := Attribute_Node_Low_Bound;
Empty_Attribute : constant Attribute_Node_Id := (Value => Empty_Attr);
First_Attribute : constant Attr_Node_Id := Attribute_Node_Low_Bound + 1;
First_Attribute_Node_Id : constant Attribute_Node_Id :=
(Value => First_Attribute);
Attribute_First : constant Attribute_Node_Id := First_Attribute_Node_Id;
--------------
-- Packages --
--------------
Packages_Initial : constant := 10;
Packages_Increment : constant := 100;
Package_Node_Low_Bound : constant := 0;
Package_Node_High_Bound : constant := 099_999_999;
type Pkg_Node_Id is
range Package_Node_Low_Bound .. Package_Node_High_Bound;
-- Index type for table Package_Attributes in the body
type Package_Node_Id is record
Value : Pkg_Node_Id := Package_Node_Low_Bound;
end record;
-- Full declaration of self-initialized private type
Empty_Pkg : constant Pkg_Node_Id := Package_Node_Low_Bound;
Empty_Package : constant Package_Node_Id := (Value => Empty_Pkg);
Unknown_Pkg : constant Pkg_Node_Id := Package_Node_High_Bound;
Unknown_Package : constant Package_Node_Id := (Value => Unknown_Pkg);
First_Package : constant Pkg_Node_Id := Package_Node_Low_Bound + 1;
First_Package_Node_Id : constant Package_Node_Id :=
(Value => First_Package);
Package_First : constant Package_Node_Id := First_Package_Node_Id;
----------------
-- Attributes --
----------------
type Attribute_Record is record
Name : Name_Id;
Var_Kind : Variable_Kind;
Optional_Index : Boolean;
Attr_Kind : Attribute_Kind;
Read_Only : Boolean;
Others_Allowed : Boolean;
Next : Attr_Node_Id;
end record;
-- Data for an attribute
package Attrs is
new Table.Table (Table_Component_Type => Attribute_Record,
Table_Index_Type => Attr_Node_Id,
Table_Low_Bound => First_Attribute,
Table_Initial => Attributes_Initial,
Table_Increment => Attributes_Increment,
Table_Name => "Prj.Attr.Attrs");
-- The table of the attributes
--------------
-- Packages --
--------------
type Package_Record is record
Name : Name_Id;
Known : Boolean := True;
First_Attribute : Attr_Node_Id;
end record;
-- Data for a package
package Package_Attributes is
new Table.Table (Table_Component_Type => Package_Record,
Table_Index_Type => Pkg_Node_Id,
Table_Low_Bound => First_Package,
Table_Initial => Packages_Initial,
Table_Increment => Packages_Increment,
Table_Name => "Prj.Attr.Packages");
-- The table of the packages
end Prj.Attr;
gprbuild-gpl-2014-src/gnat/ali-util.adb 0000644 0000767 0000145 00000045335 12323721731 017266 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- A L I . U T I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Debug; use Debug;
with Binderr; use Binderr;
with Opt; use Opt;
with Output; use Output;
with Osint; use Osint;
with Scans; use Scans;
with Scng;
with Sinput.C;
with Snames; use Snames;
with Stringt;
with Styleg;
with System.OS_Lib; use System.OS_Lib;
package body ALI.Util is
-- Empty procedures needed to instantiate Scng. Error procedures are
-- empty, because we don't want to report any errors when computing
-- a source checksum.
procedure Post_Scan;
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
procedure Error_Msg_S (Msg : String);
procedure Error_Msg_SC (Msg : String);
procedure Error_Msg_SP (Msg : String);
-- Instantiation of Styleg, needed to instantiate Scng
package Style is new Styleg
(Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP);
-- A Scanner is needed to get checksum of a source (procedure
-- Get_File_Checksum).
package Scanner is new Scng
(Post_Scan, Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP, Style);
type Header_Num is range 0 .. 1_000;
function Hash (F : File_Name_Type) return Header_Num;
-- Function used to compute hash of ALI file name
package Interfaces is new Simple_HTable (
Header_Num => Header_Num,
Element => Boolean,
No_Element => False,
Key => File_Name_Type,
Hash => Hash,
Equal => "=");
---------------------
-- Checksums_Match --
---------------------
function Checksums_Match (Checksum1, Checksum2 : Word) return Boolean is
begin
return Checksum1 = Checksum2 and then Checksum1 /= Checksum_Error;
end Checksums_Match;
---------------
-- Error_Msg --
---------------
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
pragma Warnings (Off, Msg);
pragma Warnings (Off, Flag_Location);
begin
null;
end Error_Msg;
-----------------
-- Error_Msg_S --
-----------------
procedure Error_Msg_S (Msg : String) is
pragma Warnings (Off, Msg);
begin
null;
end Error_Msg_S;
------------------
-- Error_Msg_SC --
------------------
procedure Error_Msg_SC (Msg : String) is
pragma Warnings (Off, Msg);
begin
null;
end Error_Msg_SC;
------------------
-- Error_Msg_SP --
------------------
procedure Error_Msg_SP (Msg : String) is
pragma Warnings (Off, Msg);
begin
null;
end Error_Msg_SP;
-----------------------
-- Get_File_Checksum --
-----------------------
function Get_File_Checksum (Fname : File_Name_Type) return Word is
Full_Name : File_Name_Type;
Source_Index : Source_File_Index;
begin
Full_Name := Find_File (Fname, Osint.Source);
-- If we cannot find the file, then return an impossible checksum,
-- impossible because checksums have the high order bit zero, so
-- that checksums do not match.
if Full_Name = No_File then
return Checksum_Error;
end if;
Source_Index := Sinput.C.Load_File (Get_Name_String (Full_Name));
if Source_Index = No_Source_File then
return Checksum_Error;
end if;
Scanner.Initialize_Scanner (Source_Index);
-- Make sure that the project language reserved words are not
-- recognized as reserved words, but as identifiers. The byte info for
-- those names have been set if we are in gnatmake.
Set_Name_Table_Byte (Name_Project, 0);
Set_Name_Table_Byte (Name_Extends, 0);
Set_Name_Table_Byte (Name_External, 0);
Set_Name_Table_Byte (Name_External_As_List, 0);
-- Scan the complete file to compute its checksum
loop
Scanner.Scan;
exit when Token = Tok_EOF;
end loop;
return Scans.Checksum;
end Get_File_Checksum;
----------
-- Hash --
----------
function Hash (F : File_Name_Type) return Header_Num is
begin
return Header_Num (Int (F) rem Header_Num'Range_Length);
end Hash;
---------------------------
-- Initialize_ALI_Source --
---------------------------
procedure Initialize_ALI_Source is
begin
-- When (re)initializing ALI data structures the ALI user expects to
-- get a fresh set of data structures. Thus we first need to erase the
-- marks put in the name table by the previous set of ALI routine calls.
-- This loop is empty and harmless the first time in.
for J in Source.First .. Source.Last loop
Set_Name_Table_Info (Source.Table (J).Sfile, 0);
Source.Table (J).Source_Found := False;
end loop;
Source.Init;
Interfaces.Reset;
end Initialize_ALI_Source;
---------------
-- Post_Scan --
---------------
procedure Post_Scan is
begin
null;
end Post_Scan;
----------------------
-- Read_Withed_ALIs --
----------------------
procedure Read_Withed_ALIs
(Id : ALI_Id;
Ignore_Errors : Boolean := False)
is
Afile : File_Name_Type;
Text : Text_Buffer_Ptr;
Idread : ALI_Id;
begin
-- Process all dependent units
for U in ALIs.Table (Id).First_Unit .. ALIs.Table (Id).Last_Unit loop
for
W in Units.Table (U).First_With .. Units.Table (U).Last_With
loop
Afile := Withs.Table (W).Afile;
-- Only process if not a generic (Afile /= No_File) and if
-- file has not been processed already.
if Afile /= No_File
and then Get_Name_Table_Info (Afile) = 0
then
Text := Read_Library_Info (Afile);
-- Unless Ignore_Errors is true, return with an error if source
-- cannot be found. We used to skip this check when we did not
-- compile library generics separately, but we now always do,
-- so there is no special case here anymore.
if Text = null then
if not Ignore_Errors then
Error_Msg_File_1 := Afile;
Error_Msg_File_2 := Withs.Table (W).Sfile;
Error_Msg ("{ not found, { must be compiled");
Set_Name_Table_Info (Afile, Int (No_Unit_Id));
return;
end if;
else
-- Enter in ALIs table
Idread :=
Scan_ALI
(F => Afile,
T => Text,
Ignore_ED => False,
Err => False);
Free (Text);
if ALIs.Table (Idread).Compile_Errors
and then not Ignore_Errors
then
Error_Msg_File_1 := Withs.Table (W).Sfile;
Error_Msg ("{ had errors, must be fixed, and recompiled");
Set_Name_Table_Info (Afile, Int (No_Unit_Id));
-- In GNATprove mode, object files are never generated, so
-- No_Object=True is not considered an error.
elsif ALIs.Table (Idread).No_Object
and then not GNATprove_Mode
and then not Ignore_Errors
then
Error_Msg_File_1 := Withs.Table (W).Sfile;
Error_Msg ("{ must be recompiled");
Set_Name_Table_Info (Afile, Int (No_Unit_Id));
end if;
-- If the Unit is an Interface to a Stand-Alone Library,
-- set the Interface flag in the Withs table, so that its
-- dependant are not considered for elaboration order.
if ALIs.Table (Idread).SAL_Interface then
Withs.Table (W).SAL_Interface := True;
Interface_Library_Unit := True;
-- Set the entry in the Interfaces hash table, so that
-- other units that import this unit will set the flag
-- in their entry in the Withs table.
Interfaces.Set (Afile, True);
else
-- Otherwise, recurse to get new dependents
Read_Withed_ALIs (Idread);
end if;
end if;
-- If the ALI file has already been processed and is an interface,
-- set the flag in the entry of the Withs table.
elsif Interface_Library_Unit and then Interfaces.Get (Afile) then
Withs.Table (W).SAL_Interface := True;
end if;
end loop;
end loop;
end Read_Withed_ALIs;
----------------------
-- Set_Source_Table --
----------------------
procedure Set_Source_Table (A : ALI_Id) is
F : File_Name_Type;
S : Source_Id;
Stamp : Time_Stamp_Type;
begin
Sdep_Loop : for D in
ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep
loop
F := Sdep.Table (D).Sfile;
if F /= No_File then
-- If this is the first time we are seeing this source file,
-- then make a new entry in the source table.
if Get_Name_Table_Info (F) = 0 then
Source.Increment_Last;
S := Source.Last;
Set_Name_Table_Info (F, Int (S));
Source.Table (S).Sfile := F;
Source.Table (S).All_Timestamps_Match := True;
-- Initialize checksum fields
Source.Table (S).Checksum := Sdep.Table (D).Checksum;
Source.Table (S).All_Checksums_Match := True;
-- In check source files mode, try to get time stamp from file
if Opt.Check_Source_Files then
Stamp := Source_File_Stamp (F);
-- If we got the stamp, then set the stamp in the source
-- table entry and mark it as set from the source so that
-- it does not get subsequently changed.
if Stamp (Stamp'First) /= ' ' then
Source.Table (S).Stamp := Stamp;
Source.Table (S).Source_Found := True;
Source.Table (S).Stamp_File := F;
-- If we could not find the file, then the stamp is set
-- from the dependency table entry (to be possibly reset
-- if we find a later stamp in subsequent processing)
else
Source.Table (S).Stamp := Sdep.Table (D).Stamp;
Source.Table (S).Source_Found := False;
Source.Table (S).Stamp_File := ALIs.Table (A).Afile;
-- In All_Sources mode, flag error of file not found
if Opt.All_Sources then
Error_Msg_File_1 := F;
Error_Msg ("cannot locate {");
end if;
end if;
-- First time for this source file, but Check_Source_Files
-- is off, so simply initialize the stamp from the Sdep entry
else
Source.Table (S).Stamp := Sdep.Table (D).Stamp;
Source.Table (S).Source_Found := False;
Source.Table (S).Stamp_File := ALIs.Table (A).Afile;
end if;
-- Here if this is not the first time for this source file,
-- so that the source table entry is already constructed.
else
S := Source_Id (Get_Name_Table_Info (F));
-- Update checksum flag
if not Checksums_Match
(Sdep.Table (D).Checksum, Source.Table (S).Checksum)
then
Source.Table (S).All_Checksums_Match := False;
end if;
-- Check for time stamp mismatch
if Sdep.Table (D).Stamp /= Source.Table (S).Stamp then
Source.Table (S).All_Timestamps_Match := False;
-- When we have a time stamp mismatch, we go look for the
-- source file even if Check_Source_Files is false, since
-- if we find it, then we can use it to resolve which of the
-- two timestamps in the ALI files is likely to be correct.
-- We only look in the current directory, because when
-- Check_Source_Files is false, other search directories are
-- likely to be incorrect.
if not Check_Source_Files
and then Is_Regular_File (Get_Name_String (F))
then
Stamp := Source_File_Stamp (F);
if Stamp (Stamp'First) /= ' ' then
Source.Table (S).Stamp := Stamp;
Source.Table (S).Source_Found := True;
Source.Table (S).Stamp_File := F;
end if;
end if;
-- If the stamp in the source table entry was set from the
-- source file, then we do not change it (the stamp in the
-- source file is always taken as the "right" one).
if Source.Table (S).Source_Found then
null;
-- Otherwise, we have no source file available, so we guess
-- that the later of the two timestamps is the right one.
-- Note that this guess only affects which error messages
-- are issued later on, not correct functionality.
else
if Sdep.Table (D).Stamp > Source.Table (S).Stamp then
Source.Table (S).Stamp := Sdep.Table (D).Stamp;
Source.Table (S).Stamp_File := ALIs.Table (A).Afile;
end if;
end if;
end if;
end if;
-- Set the checksum value in the source table
S := Source_Id (Get_Name_Table_Info (F));
Source.Table (S).Checksum := Sdep.Table (D).Checksum;
end if;
end loop Sdep_Loop;
end Set_Source_Table;
----------------------
-- Set_Source_Table --
----------------------
procedure Set_Source_Table is
begin
for A in ALIs.First .. ALIs.Last loop
Set_Source_Table (A);
end loop;
end Set_Source_Table;
-------------------------
-- Time_Stamp_Mismatch --
-------------------------
function Time_Stamp_Mismatch
(A : ALI_Id;
Read_Only : Boolean := False) return File_Name_Type
is
Src : Source_Id;
-- Source file Id for the current Sdep entry
begin
for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop
Src := Source_Id (Get_Name_Table_Info (Sdep.Table (D).Sfile));
if Opt.Minimal_Recompilation
and then Sdep.Table (D).Stamp /= Source.Table (Src).Stamp
then
-- If minimal recompilation is in action, replace the stamp
-- of the source file in the table if checksums match.
-- ??? It is probably worth updating the ALI file with a new
-- field to avoid recomputing it each time. In any case we ensure
-- that we don't gobble up string table space by doing a mark
-- release around this computation.
Stringt.Mark;
if Checksums_Match
(Get_File_Checksum (Sdep.Table (D).Sfile),
Source.Table (Src).Checksum)
then
if Verbose_Mode then
Write_Str (" ");
Write_Str (Get_Name_String (Sdep.Table (D).Sfile));
Write_Str (": up to date, different timestamps " &
"but same checksum");
Write_Eol;
end if;
Sdep.Table (D).Stamp := Source.Table (Src).Stamp;
end if;
Stringt.Release;
end if;
if (not Read_Only) or else Source.Table (Src).Source_Found then
if not Source.Table (Src).Source_Found
or else Sdep.Table (D).Stamp /= Source.Table (Src).Stamp
then
-- If -dt debug flag set, output time stamp found/expected
if Source.Table (Src).Source_Found and then Debug_Flag_T then
Write_Str ("Source: """);
Get_Name_String (Sdep.Table (D).Sfile);
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Line ("""");
Write_Str (" time stamp expected: ");
Write_Line (String (Sdep.Table (D).Stamp));
Write_Str (" time stamp found: ");
Write_Line (String (Source.Table (Src).Stamp));
end if;
-- Return the source file
return Source.Table (Src).Sfile;
end if;
end if;
end loop;
return No_File;
end Time_Stamp_Mismatch;
end ALI.Util;
gprbuild-gpl-2014-src/gnat/stand.adb 0000644 0000767 0000145 00000017764 12323721731 016664 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S T A N D --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, 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 3, 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. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--
/* objlist_file_supported is set to 1 when the system linker allows */
/* response file, that is a file that contains the list of object files. */
/* This is useful on systems where the command line length is limited, */
/* meaning that putting all the object files on the command line can */
/* result in an unacceptable limit on the number of files. */
/* object_file_option denotes the system dependent linker option which */
/* allows object file names to be placed in a file and then passed to */
/* the linker. object_file_option must be set if objlist_file_supported */
/* is set to 1. */
/* link_max is a conservative system specific threshold (in bytes) of the */
/* argument length passed to the linker which will trigger a file being */
/* used instead of the command line directly. If the argument length is */
/* greater than this threshold, then an objlist_file will be generated */
/* and object_file_option and objlist_file_supported must be set. If */
/* objlist_file_supported is set to 0 (unsupported), then link_max is */
/* set to 2**31-1 so that the limit will never be exceeded. */
/* run_path_option is the system dependent linker option which specifies */
/* the run time path to use when loading dynamic libraries. This should */
/* be set to the null string if the system does not support dynamic */
/* loading of libraries. */
/* shared_libgnat_default gives the system dependent link method that */
/* be used by default for linking libgnat (shared or static) */
/* shared_libgcc_default gives the system dependent link method that */
/* be used by default for linking libgcc (shared or static) */
/* separate_run_path_options is set to 1 when separate "rpath" arguments */
/* must be passed to the linker for each directory in the rpath. */
/* default_libgcc_subdir is the subdirectory name (from the installation */
/* root) where we may find a shared libgcc to use by default. */
#define SHARED 'H'
#define STATIC 'T'
#if defined (__WIN32)
const char *__gnat_object_file_option = "-Wl,@";
const char *__gnat_run_path_option = "";
int __gnat_link_max = 30000;
unsigned char __gnat_objlist_file_supported = 1;
char __gnat_shared_libgnat_default = STATIC;
char __gnat_shared_libgcc_default = STATIC;
const char *__gnat_object_library_extension = ".a";
unsigned char __gnat_separate_run_path_options = 0;
const char *__gnat_default_libgcc_subdir = "lib";
#elif defined (__hpux__)
const char *__gnat_object_file_option = "-Wl,-c,";
const char *__gnat_run_path_option = "-Wl,+b,";
int __gnat_link_max = 5000;
unsigned char __gnat_objlist_file_supported = 1;
char __gnat_shared_libgnat_default = STATIC;
char __gnat_shared_libgcc_default = STATIC;
const char *__gnat_object_library_extension = ".a";
unsigned char __gnat_separate_run_path_options = 0;
const char *__gnat_default_libgcc_subdir = "lib";
#elif defined (__FreeBSD__)
const char *__gnat_object_file_option = "-Wl,@";
const char *__gnat_run_path_option = "-Wl,-rpath,";
char __gnat_shared_libgnat_default = STATIC;
char __gnat_shared_libgcc_default = STATIC;
int __gnat_link_max = 8192;
unsigned char __gnat_objlist_file_supported = 1;
const char *__gnat_object_library_extension = ".a";
unsigned char __gnat_separate_run_path_options = 0;
const char *__gnat_default_libgcc_subdir = "lib";
#elif defined (__APPLE__)
const char *__gnat_object_file_option = "-Wl,-filelist,";
const char *__gnat_run_path_option = "-Wl,-rpath,";
char __gnat_shared_libgnat_default = STATIC;
char __gnat_shared_libgcc_default = SHARED;
int __gnat_link_max = 262144;
unsigned char __gnat_objlist_file_supported = 1;
const char *__gnat_object_library_extension = ".a";
unsigned char __gnat_separate_run_path_options = 1;
const char *__gnat_default_libgcc_subdir = "lib";
#elif defined (linux) || defined(__GLIBC__)
const char *__gnat_object_file_option = "-Wl,@";
const char *__gnat_run_path_option = "-Wl,-rpath,";
char __gnat_shared_libgnat_default = STATIC;
char __gnat_shared_libgcc_default = STATIC;
int __gnat_link_max = 8192;
unsigned char __gnat_objlist_file_supported = 1;
const char *__gnat_object_library_extension = ".a";
unsigned char __gnat_separate_run_path_options = 0;
#if defined (__x86_64)
# if defined (__LP64__)
const char *__gnat_default_libgcc_subdir = "lib64";
# else
const char *__gnat_default_libgcc_subdir = "libx32";
# endif
#else
const char *__gnat_default_libgcc_subdir = "lib";
#endif
#elif defined (_AIX)
/* On AIX, even when with GNU ld we use native linker switches. This is
particularly important for '-f' as it should be interpreted by collect2. */
const char *__gnat_object_file_option = "-Wl,-f,";
const char *__gnat_run_path_option = "";
char __gnat_shared_libgnat_default = STATIC;
char __gnat_shared_libgcc_default = STATIC;
int __gnat_link_max = 15000;
const unsigned char __gnat_objlist_file_supported = 1;
const char *__gnat_object_library_extension = ".a";
unsigned char __gnat_separate_run_path_options = 0;
const char *__gnat_default_libgcc_subdir = "lib";
#elif (HAVE_GNU_LD)
/* These are the settings for all systems that use gnu ld. GNU style response
file is supported, the shared library default is STATIC. */
const char *__gnat_object_file_option = "-Wl,@";
const char *__gnat_run_path_option = "";
char __gnat_shared_libgnat_default = STATIC;
char __gnat_shared_libgcc_default = STATIC;
int __gnat_link_max = 8192;
unsigned char __gnat_objlist_file_supported = 1;
const char *__gnat_object_library_extension = ".a";
unsigned char __gnat_separate_run_path_options = 0;
const char *__gnat_default_libgcc_subdir = "lib";
#elif defined (VMS)
const char *__gnat_object_file_option = "";
const char *__gnat_run_path_option = "";
char __gnat_shared_libgnat_default = STATIC;
char __gnat_shared_libgcc_default = STATIC;
int __gnat_link_max = 2147483647;
unsigned char __gnat_objlist_file_supported = 0;
const char *__gnat_object_library_extension = ".olb";
unsigned char __gnat_separate_run_path_options = 0;
const char *__gnat_default_libgcc_subdir = "lib";
#elif defined (sun)
const char *__gnat_object_file_option = "";
const char *__gnat_run_path_option = "-Wl,-R";
char __gnat_shared_libgnat_default = STATIC;
char __gnat_shared_libgcc_default = STATIC;
int __gnat_link_max = 2147483647;
unsigned char __gnat_objlist_file_supported = 0;
const char *__gnat_object_library_extension = ".a";
unsigned char __gnat_separate_run_path_options = 0;
#if defined (__sparc_v9__) || defined (__sparcv9)
const char *__gnat_default_libgcc_subdir = "lib/sparcv9";
#elif defined (__x86_64)
const char *__gnat_default_libgcc_subdir = "lib/amd64";
#else
const char *__gnat_default_libgcc_subdir = "lib";
#endif
#elif defined (__svr4__) && defined (i386)
const char *__gnat_object_file_option = "";
const char *__gnat_run_path_option = "";
char __gnat_shared_libgnat_default = STATIC;
char __gnat_shared_libgcc_default = STATIC;
int __gnat_link_max = 2147483647;
unsigned char __gnat_objlist_file_supported = 0;
const char *__gnat_object_library_extension = ".a";
unsigned char __gnat_separate_run_path_options = 0;
const char *__gnat_default_libgcc_subdir = "lib";
#else
/* These are the default settings for all other systems. No response file
is supported, the shared library default is STATIC. */
const char *__gnat_run_path_option = "";
const char *__gnat_object_file_option = "";
char __gnat_shared_libgnat_default = STATIC;
char __gnat_shared_libgcc_default = STATIC;
int __gnat_link_max = 2147483647;
unsigned char __gnat_objlist_file_supported = 0;
const char *__gnat_object_library_extension = ".a";
unsigned char __gnat_separate_run_path_options = 0;
const char *__gnat_default_libgcc_subdir = "lib";
#endif
#ifdef __cplusplus
}
#endif
gprbuild-gpl-2014-src/gnat/prj-util.ads 0000644 0000767 0000145 00000027312 12323721731 017330 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . U T I L --
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2012, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Utilities for use in processing project files
package Prj.Util is
function Executable_Of
(Project : Project_Id;
Shared : Shared_Project_Tree_Data_Access;
Main : File_Name_Type;
Index : Int;
Ada_Main : Boolean := True;
Language : String := "";
Include_Suffix : Boolean := True) return File_Name_Type;
-- Return the value of the attribute Builder'Executable for file Main in
-- the project Project, if it exists. If there is no attribute Executable
-- for Main, remove the suffix from Main; then, if the attribute
-- Executable_Suffix is specified, add this suffix, otherwise add the
-- standard executable suffix for the platform.
--
-- If Include_Suffix is true, then the ".exe" suffix (or any suffix defined
-- in the config) will be added. The suffix defined by the user in his own
-- project file is always taken into account. Otherwise, such a suffix is
-- not added. In particular, the prefix should not be added if you are
-- potentially testing for cross-platforms, since the suffix might not be
-- known (its default value comes from the ...-gnatmake prefix).
--
-- What is Ada_Main???
-- What is Language???
procedure Put
(Into_List : in out Name_List_Index;
From_List : String_List_Id;
In_Tree : Project_Tree_Ref;
Lower_Case : Boolean := False);
-- Append a name list to a string list
-- Describe parameters???
procedure Duplicate
(This : in out Name_List_Index;
Shared : Shared_Project_Tree_Data_Access);
-- Duplicate a name list
function Value_Of
(Variable : Variable_Value;
Default : String) return String;
-- Get the value of a single string variable. If Variable is a string list,
-- is Nil_Variable_Value,or is defaulted, return Default.
function Value_Of
(Index : Name_Id;
In_Array : Array_Element_Id;
Shared : Shared_Project_Tree_Data_Access) return Name_Id;
-- Get a single string array component. Returns No_Name if there is no
-- component Index, if In_Array is null, or if the component is a String
-- list. Depending on the attribute (only attributes may be associative
-- arrays) the index may or may not be case sensitive. If the index is not
-- case sensitive, it is first set to lower case before the search in the
-- associative array.
function Value_Of
(Index : Name_Id;
Src_Index : Int := 0;
In_Array : Array_Element_Id;
Shared : Shared_Project_Tree_Data_Access;
Force_Lower_Case_Index : Boolean := False;
Allow_Wildcards : Boolean := False) return Variable_Value;
-- Get a string array component (single String or String list). Returns
-- Nil_Variable_Value if no component Index or if In_Array is null.
--
-- Depending on the attribute (only attributes may be associative arrays)
-- the index may or may not be case sensitive. If the index is not case
-- sensitive, it is first set to lower case before the search in the
-- associative array.
function Value_Of
(Name : Name_Id;
Index : Int := 0;
Attribute_Or_Array_Name : Name_Id;
In_Package : Package_Id;
Shared : Shared_Project_Tree_Data_Access;
Force_Lower_Case_Index : Boolean := False;
Allow_Wildcards : Boolean := False) return Variable_Value;
-- In a specific package:
-- - if there exists an array Attribute_Or_Array_Name with an index Name,
-- returns the corresponding component (depending on the attribute, the
-- index may or may not be case sensitive, see previous function),
-- - otherwise if there is a single attribute Attribute_Or_Array_Name,
-- returns this attribute,
-- - otherwise, returns Nil_Variable_Value.
-- If In_Package is null, returns Nil_Variable_Value.
function Value_Of
(Index : Name_Id;
In_Array : Name_Id;
In_Arrays : Array_Id;
Shared : Shared_Project_Tree_Data_Access) return Name_Id;
-- Get a string array component in an array of an array list. Returns
-- No_Name if there is no component Index, if In_Arrays is null, if
-- In_Array is not found in In_Arrays or if the component is a String list.
function Value_Of
(Name : Name_Id;
In_Arrays : Array_Id;
Shared : Shared_Project_Tree_Data_Access) return Array_Element_Id;
-- Returns a specified array in an array list. Returns No_Array_Element
-- if In_Arrays is null or if Name is not the name of an array in
-- In_Arrays. The caller must ensure that Name is in lower case.
function Value_Of
(Name : Name_Id;
In_Packages : Package_Id;
Shared : Shared_Project_Tree_Data_Access) return Package_Id;
-- Returns a specified package in a package list. Returns No_Package
-- if In_Packages is null or if Name is not the name of a package in
-- Package_List. The caller must ensure that Name is in lower case.
function Value_Of
(Variable_Name : Name_Id;
In_Variables : Variable_Id;
Shared : Shared_Project_Tree_Data_Access) return Variable_Value;
-- Returns a specified variable in a variable list. Returns null if
-- In_Variables is null or if Variable_Name is not the name of a
-- variable in In_Variables. Caller must ensure that Name is lower case.
procedure Write_Str
(S : String;
Max_Length : Positive;
Separator : Character);
-- Output string S using Output.Write_Str. If S is too long to fit in one
-- line of Max_Length, cut it in several lines, using Separator as the last
-- character of each line, if possible.
type Text_File is limited private;
-- Represents a text file (default is invalid text file)
function Is_Valid (File : Text_File) return Boolean;
-- Returns True if File designates an open text file that has not yet been
-- closed.
procedure Open (File : out Text_File; Name : String);
-- Open a text file to read (File is invalid if text file cannot be opened)
procedure Create (File : out Text_File; Name : String);
-- Create a text file to write (File is invalid if text file cannot be
-- created).
function End_Of_File (File : Text_File) return Boolean;
-- Returns True if the end of the text file File has been reached. Fails if
-- File is invalid. Return True if File is an out file.
procedure Get_Line
(File : Text_File;
Line : out String;
Last : out Natural);
-- Reads a line from an open text file (fails if File is invalid or in an
-- out file).
procedure Put (File : Text_File; S : String);
procedure Put_Line (File : Text_File; Line : String);
-- Output a string or a line to an out text file (fails if File is invalid
-- or in an in file).
procedure Close (File : in out Text_File);
-- Close an open text file. File becomes invalid. Fails if File is already
-- invalid or if an out file cannot be closed successfully.
-----------------------
-- Source info files --
-----------------------
procedure Write_Source_Info_File (Tree : Project_Tree_Ref);
-- Create a new source info file, with the path name specified in the
-- project tree data. Issue a warning if it is not possible to create
-- the new file.
procedure Read_Source_Info_File (Tree : Project_Tree_Ref);
-- Check if there is a source info file specified for the project Tree. If
-- so, attempt to read it. If the file exists and is successfully read, set
-- the flag Source_Info_File_Exists to True for the tree.
type Source_Info_Data is record
Project : Name_Id;
Language : Name_Id;
Kind : Source_Kind;
Display_Path_Name : Name_Id;
Path_Name : Name_Id;
Unit_Name : Name_Id := No_Name;
Index : Int := 0;
Naming_Exception : Naming_Exception_Type := No;
end record;
-- Data read from a source info file for a single source
type Source_Info is access all Source_Info_Data;
No_Source_Info : constant Source_Info := null;
type Source_Info_Iterator is private;
-- Iterator to get the sources for a single project
procedure Initialize
(Iter : out Source_Info_Iterator;
For_Project : Name_Id);
-- Initialize Iter for the project
function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info;
-- Get the source info for the source corresponding to the current value of
-- the iterator. Returns No_Source_Info if there is no source corresponding
-- to the iterator.
procedure Next (Iter : in out Source_Info_Iterator);
-- Advance the iterator to the next source in the project
generic
with procedure Action (Source : Source_Id);
procedure For_Interface_Sources
(Tree : Project_Tree_Ref;
Project : Project_Id);
-- Call Action for every sources that are needed to use Project. This is
-- either the sources corresponding to the units in attribute Interfaces
-- or all sources of the project. Note that only the bodies that are
-- needed (because the unit is generic or contains some inline pragmas)
-- are handled. This routine must be called only when the project has
-- been built successfully.
private
type Text_File_Data is record
FD : File_Descriptor := Invalid_FD;
Out_File : Boolean := False;
Buffer : String (1 .. 1_000);
Buffer_Len : Natural := 0;
Cursor : Natural := 0;
End_Of_File_Reached : Boolean := False;
end record;
type Text_File is access Text_File_Data;
type Source_Info_Iterator is record
Info : Source_Info;
Next : Natural;
end record;
end Prj.Util;
gprbuild-gpl-2014-src/gnat/projects.texi 0000644 0000767 0000145 00000577243 12307305637 017637 0 ustar gnatmail gnat @set gprconfig GPRconfig
@c ------ projects.texi
@c Copyright (C) 2002-2014, Free Software Foundation, Inc.
@c This file is shared between the GNAT user's guide and gprbuild. It is not
@c compilable on its own, you should instead compile the other two manuals.
@c For that reason, there is no toplevel @menu
@c ---------------------------------------------
@node GNAT Project Manager
@chapter GNAT Project Manager
@c ---------------------------------------------
@noindent
@menu
* Introduction::
* Building With Projects::
* Organizing Projects into Subsystems::
* Scenarios in Projects::
* Library Projects::
* Project Extension::
* Aggregate Projects::
* Aggregate Library Projects::
* Project File Reference::
@end menu
@c ---------------------------------------------
@node Introduction
@section Introduction
@c ---------------------------------------------
@noindent
This chapter describes GNAT's @emph{Project Manager}, a facility that allows
you to manage complex builds involving a number of source files, directories,
and options for different system configurations. In particular,
project files allow you to specify:
@itemize @bullet
@item The directory or set of directories containing the source files, and/or the
names of the specific source files themselves
@item The directory in which the compiler's output
(@file{ALI} files, object files, tree files, etc.) is to be placed
@item The directory in which the executable programs are to be placed
@item ^Switch^Switch^ settings for any of the project-enabled tools;
you can apply these settings either globally or to individual compilation units.
@item The source files containing the main subprogram(s) to be built
@item The source programming language(s)
@item Source file naming conventions; you can specify these either globally or for
individual compilation units (@pxref{Naming Schemes}).
@item Change any of the above settings depending on external values, thus enabling
the reuse of the projects in various @b{scenarios} (@pxref{Scenarios in Projects}).
@item Automatically build libraries as part of the build process
(@pxref{Library Projects}).
@end itemize
@noindent
Project files are written in a syntax close to that of Ada, using familiar
notions such as packages, context clauses, declarations, default values,
assignments, and inheritance (@pxref{Project File Reference}).
Project files can be built hierarchically from other project files, simplifying
complex system integration and project reuse (@pxref{Organizing Projects into
Subsystems}).
@itemize @bullet
@item One project can import other projects containing needed source files.
More generally, the Project Manager lets you structure large development
efforts into hierarchical subsystems, where build decisions are delegated
to the subsystem level, and thus different compilation environments
(^switch^switch^ settings) used for different subsystems.
@item You can organize GNAT projects in a hierarchy: a child project
can extend a parent project, inheriting the parent's source files and
optionally overriding any of them with alternative versions
(@pxref{Project Extension}).
@end itemize
@noindent
Several tools support project files, generally in addition to specifying
the information on the command line itself). They share common switches
to control the loading of the project (in particular
@option{^-P^/PROJECT_FILE=^@emph{projectfile}} and
@option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}}).
The Project Manager supports a wide range of development strategies,
for systems of all sizes. Here are some typical practices that are
easily handled:
@itemize @bullet
@item Using a common set of source files and generating object files in different
directories via different ^switch^switch^ settings. It can be used for instance, for
generating separate sets of object files for debugging and for production.
@item Using a mostly-shared set of source files with different versions of
some units or subunits. It can be used for instance, for grouping and hiding
@end itemize
@noindent
all OS dependencies in a small number of implementation units.
Project files can be used to achieve some of the effects of a source
versioning system (for example, defining separate projects for
the different sets of sources that comprise different releases) but the
Project Manager is independent of any source configuration management tool
that might be used by the developers.
The various sections below introduce the different concepts related to
projects. Each section starts with examples and use cases, and then goes into
the details of related project file capabilities.
@c ---------------------------------------------
@node Building With Projects
@section Building With Projects
@c ---------------------------------------------
@noindent
In its simplest form, a unique project is used to build a single executable.
This section concentrates on such a simple setup. Later sections will extend
this basic model to more complex setups.
The following concepts are the foundation of project files, and will be further
detailed later in this documentation. They are summarized here as a reference.
@table @asis
@item @b{Project file}:
A text file using an Ada-like syntax, generally using the @file{.gpr}
extension. It defines build-related characteristics of an application.
The characteristics include the list of sources, the location of those
sources, the location for the generated object files, the name of
the main program, and the options for the various tools involved in the
build process.
@item @b{Project attribute}:
A specific project characteristic is defined by an attribute clause. Its
value is a string or a sequence of strings. All settings in a project
are defined through a list of predefined attributes with precise
semantics. @xref{Attributes}.
@item @b{Package in a project}:
Global attributes are defined at the top level of a project.
Attributes affecting specific tools are grouped in a
package whose name is related to tool's function. The most common
packages are @code{Builder}, @code{Compiler}, @code{Binder},
and @code{Linker}. @xref{Packages}.
@item @b{Project variables}:
In addition to attributes, a project can use variables to store intermediate
values and avoid duplication in complex expressions. It can be initialized
with a value coming from the environment.
A frequent use of variables is to define scenarios.
@xref{External Values}, @xref{Scenarios in Projects}, and @xref{Variables}.
@item @b{Source files} and @b{source directories}:
A source file is associated with a language through a naming convention. For
instance, @code{foo.c} is typically the name of a C source file;
@code{bar.ads} or @code{bar.1.ada} are two common naming conventions for a
file containing an Ada spec. A compilation unit is often composed of a main
source file and potentially several auxiliary ones, such as header files in C.
The naming conventions can be user defined @xref{Naming Schemes}, and will
drive the builder to call the appropriate compiler for the given source file.
Source files are searched for in the source directories associated with the
project through the @b{Source_Dirs} attribute. By default, all the files (in
these source directories) following the naming conventions associated with the
declared languages are considered to be part of the project. It is also
possible to limit the list of source files using the @b{Source_Files} or
@b{Source_List_File} attributes. Note that those last two attributes only
accept basenames with no directory information.
@item @b{Object files} and @b{object directory}:
An object file is an intermediate file produced by the compiler from a
compilation unit. It is used by post-compilation tools to produce
final executables or libraries. Object files produced in the context of
a given project are stored in a single directory that can be specified by the
@b{Object_Dir} attribute. In order to store objects in
two or more object directories, the system must be split into
distinct subsystems with their own project file.
/first exam
@end table
The following subsections introduce gradually all the attributes of interest
for simple build needs. Here is the simple setup that will be used in the
following examples.
The Ada source files @file{pack.ads}, @file{pack.adb}, and @file{proc.adb} are in
the @file{common/} directory. The file @file{proc.adb} contains an Ada main
subprogram @code{Proc} that @code{with}s package @code{Pack}. We want to compile
these source files with the ^switch^switch^
@option{^-O2^-O2^}, and put the resulting files in
the directory @file{obj/}.
@smallexample
@group
^common/^[COMMON]^
pack.ads
pack.adb
proc.adb
@end group
@group
^common/release/^[COMMON.RELEASE]^
proc.ali, proc.o pack.ali, pack.o
@end group
@end smallexample
@noindent
Our project is to be called @emph{Build}. The name of the
file is the name of the project (case-insensitive) with the
@file{.gpr} extension, therefore the project file name is @file{build.gpr}. This
is not mandatory, but a warning is issued when this convention is not followed.
This is a very simple example, and as stated above, a single project
file is enough for it. We will thus create a new file, that for now
should contain the following code:
@smallexample
@b{project} Build @b{is}
@b{end} Build;
@end smallexample
@menu
* Source Files and Directories::
* Duplicate Sources in Projects::
* Object and Exec Directory::
* Main Subprograms::
* Tools Options in Project Files::
* Compiling with Project Files::
* Executable File Names::
* Avoid Duplication With Variables::
* Naming Schemes::
* Installation::
* Distributed support::
@end menu
@c ---------------------------------------------
@node Source Files and Directories
@subsection Source Files and Directories
@c ---------------------------------------------
@noindent
When you create a new project, the first thing to describe is how to find the
corresponding source files. This is the only settings that are needed by all
the tools that will use this project (builder, compiler, binder and linker for
the compilation, IDEs to edit the source files,@dots{}).
@cindex Source directories
First step is to declare the source directories, which are the directories
to be searched to find source files. In the case of the example,
the @file{common} directory is the only source directory.
@cindex @code{Source_Dirs}
There are several ways of defining source directories:
@itemize @bullet
@item When the attribute @b{Source_Dirs} is not used, a project contains a
single source directory which is the one where the project file itself
resides. In our example, if @file{build.gpr} is placed in the @file{common}
directory, the project has the needed implicit source directory.
@item The attribute @b{Source_Dirs} can be set to a list of path names, one
for each of the source directories. Such paths can either be absolute
names (for instance @file{"/usr/local/common/"} on UNIX), or relative to the
directory in which the project file resides (for instance "." if
@file{build.gpr} is inside @file{common/}, or "common" if it is one level up).
Each of the source directories must exist and be readable.
@cindex portability
The syntax for directories is platform specific. For portability, however,
the project manager will always properly translate UNIX-like path names to
the native format of specific platform. For instance, when the same project
file is to be used both on Unix and Windows, "/" should be used as the
directory separator rather than "\".
@item The attribute @b{Source_Dirs} can automatically include subdirectories
using a special syntax inspired by some UNIX shells. If any of the path in
the list ends with @emph{"**"}, then that path and all its subdirectories
(recursively) are included in the list of source directories. For instance,
@file{**} and @file{./**} represent the complete directory tree rooted at ".".
@cindex Source directories, recursive
@cindex @code{Excluded_Source_Dirs}
When using that construct, it can sometimes be convenient to also use the
attribute @b{Excluded_Source_Dirs}, which is also a list of paths. Each entry
specifies a directory whose immediate content, not including subdirs, is to
be excluded. It is also possible to exclude a complete directory subtree
using the "**" notation.
@cindex @code{Ignore_Source_Sub_Dirs}
It is often desirable to remove, from the source directories, directory
subtrees rooted at some subdirectories. An example is the subdirectories
created by a Version Control System such as Subversion that creates directory
subtrees rooted at subdirectories ".svn". To do that, attribute
@b{Ignore_Source_Sub_Dirs} can be used. It specifies the list of simple
file names for the roots of these undesirable directory subtrees.
@smallexample
@b{for} Source_Dirs @b{use} ("./**");
@b{for} Ignore_Source_Sub_Dirs @b{use} (".svn");
@end smallexample
@end itemize
@noindent
When applied to the simple example, and because we generally prefer to have
the project file at the toplevel directory rather than mixed with the sources,
we will create the following file
@smallexample
build.gpr
@b{project} Build @b{is}
@b{for} Source_Dirs @b{use} ("common"); -- <<<<
@b{end} Build;
@end smallexample
@noindent
Once source directories have been specified, one may need to indicate
source files of interest. By default, all source files present in the source
directories are considered by the project manager. When this is not desired,
it is possible to specify the list of sources to consider explicitly.
In such a case, only source file base names are indicated and not
their absolute or relative path names. The project manager is in charge of
locating the specified source files in the specified source directories.
@itemize @bullet
@item By default, the project manager search for all source files of all
specified languages in all the source directories.
Since the project manager was initially developed for Ada environments, the
default language is usually Ada and the above project file is complete: it
defines without ambiguity the sources composing the project: that is to say,
all the sources in subdirectory "common" for the default language (Ada) using
the default naming convention.
@cindex @code{Languages}
However, when compiling a multi-language application, or a pure C
application, the project manager must be told which languages are of
interest, which is done by setting the @b{Languages} attribute to a list of
strings, each of which is the name of a language. Tools like
@command{gnatmake} only know about Ada, while other tools like
@command{gprbuild} know about many more languages such as C, C++, Fortran,
assembly and others can be added dynamically.
@cindex Naming scheme
Even when using only Ada, the default naming might not be suitable. Indeed,
how does the project manager recognizes an "Ada file" from any other
file? Project files can describe the naming scheme used for source files,
and override the default (@pxref{Naming Schemes}). The default is the
standard GNAT extension (@file{.adb} for bodies and @file{.ads} for
specs), which is what is used in our example, explaining why no naming scheme
is explicitly specified.
@xref{Naming Schemes}.
@item @code{Source_Files}
@cindex @code{Source_Files}
In some cases, source directories might contain files that should not be
included in a project. One can specify the explicit list of file names to
be considered through the @b{Source_Files} attribute.
When this attribute is defined, instead of looking at every file in the
source directories, the project manager takes only those names into
consideration reports errors if they cannot be found in the source
directories or does not correspond to the naming scheme.
@item For various reasons, it is sometimes useful to have a project with no
sources (most of the time because the attributes defined in the project
file will be reused in other projects, as explained in
@pxref{Organizing Projects into Subsystems}. To do this, the attribute
@emph{Source_Files} is set to the empty list, i.e. @code{()}. Alternatively,
@emph{Source_Dirs} can be set to the empty list, with the same
result.
@item @code{Source_List_File}
@cindex @code{Source_List_File}
If there is a great number of files, it might be more convenient to use
the attribute @b{Source_List_File}, which specifies the full path of a file.
This file must contain a list of source file names (one per line, no
directory information) that are searched as if they had been defined
through @emph{Source_Files}. Such a file can easily be created through
external tools.
A warning is issued if both attributes @code{Source_Files} and
@code{Source_List_File} are given explicit values. In this case, the
attribute @code{Source_Files} prevails.
@item @code{Excluded_Source_Files}
@cindex @code{Excluded_Source_Files}
@cindex @code{Locally_Removed_Files}
@cindex @code{Excluded_Source_List_File}
Specifying an explicit list of files is not always convenient.It might be
more convenient to use the default search rules with specific exceptions.
This can be done thanks to the attribute @b{Excluded_Source_Files}
(or its synonym @b{Locally_Removed_Files}).
Its value is the list of file names that should not be taken into account.
This attribute is often used when extending a project,
@xref{Project Extension}. A similar attribute
@b{Excluded_Source_List_File} plays the same
role but takes the name of file containing file names similarly to
@code{Source_List_File}.
@end itemize
@noindent
In most simple cases, such as the above example, the default source file search
behavior provides the expected result, and we do not need to add anything after
setting @code{Source_Dirs}. The project manager automatically finds
@file{pack.ads}, @file{pack.adb} and @file{proc.adb} as source files of the
project.
Note that by default a warning is issued when a project has no sources attached
to it and this is not explicitly indicated in the project file.
@c ---------------------------------------------
@node Duplicate Sources in Projects
@subsection Duplicate Sources in Projects
@c ---------------------------------------------
@noindent
If the order of the source directories is known statically, that is if
@code{"/**"} is not used in the string list @code{Source_Dirs}, then there may
be several files with the same source file name sitting in different
directories of the project. In this case, only the file in the first directory
is considered as a source of the project and the others are hidden. If
@code{"/**"} is used in the string list @code{Source_Dirs}, it is an error
to have several files with the same source file name in the same directory
@code{"/**"} subtree, since there would be an ambiguity as to which one should
be used. However, two files with the same source file name may exist in two
single directories or directory subtrees. In this case, the one in the first
directory or directory subtree is a source of the project.
If there are two sources in different directories of the same @code{"/**"}
subtree, one way to resolve the problem is to exclude the directory of the
file that should not be used as a source of the project.
@c ---------------------------------------------
@node Object and Exec Directory
@subsection Object and Exec Directory
@c ---------------------------------------------
@noindent
The next step when writing a project is to indicate where the compiler should
put the object files. In fact, the compiler and other tools might create
several different kind of files (for GNAT, there is the object file and the ALI
file for instance). One of the important concepts in projects is that most
tools may consider source directories as read-only and do not attempt to create
new or temporary files there. Instead, all files are created in the object
directory. It is of course not true for project-aware IDEs, whose purpose it is
to create the source files.
@cindex @code{Object_Dir}
The object directory is specified through the @b{Object_Dir} attribute.
Its value is the path to the object directory, either absolute or
relative to the directory containing the project file. This
directory must already exist and be readable and writable, although
some tools have a switch to create the directory if needed (See
the switch @code{^-p^/CREATE_MISSING_DIRS^} for @command{gnatmake}
and @command{gprbuild}).
If the attribute @code{Object_Dir} is not specified, it defaults to
the project directory, that is the directory containing the project file.
For our example, we can specify the object dir in this way:
@smallexample
@b{project} Build @b{is}
@b{for} Source_Dirs @b{use} ("common");
@b{for} Object_Dir @b{use} "obj"; -- <<<<
@b{end} Build;
@end smallexample
@noindent
As mentioned earlier, there is a single object directory per project. As a
result, if you have an existing system where the object files are spread in
several directories, you can either move all of them into the same directory if
you want to build it with a single project file, or study the section on
subsystems (@pxref{Organizing Projects into Subsystems}) to see how each
separate object directory can be associated with one of the subsystem
constituting the application.
When the @command{linker} is called, it usually creates an executable. By
default, this executable is placed in the object directory of the project. It
might be convenient to store it in its own directory.
@cindex @code{Exec_Dir}
This can be done through the @code{Exec_Dir} attribute, which, like
@emph{Object_Dir} contains a single absolute or relative path and must point to
an existing and writable directory, unless you ask the tool to create it on
your behalf. When not specified, It defaults to the object directory and
therefore to the project file's directory if neither @emph{Object_Dir} nor
@emph{Exec_Dir} was specified.
In the case of the example, let's place the executable in the root
of the hierarchy, ie the same directory as @file{build.gpr}. Hence
the project file is now
@smallexample
@b{project} Build @b{is}
@b{for} Source_Dirs @b{use} ("common");
@b{for} Object_Dir @b{use} "obj";
@b{for} Exec_Dir @b{use} "."; -- <<<<
@b{end} Build;
@end smallexample
@c ---------------------------------------------
@node Main Subprograms
@subsection Main Subprograms
@c ---------------------------------------------
@noindent
In the previous section, executables were mentioned. The project manager needs
to be taught what they are. In a project file, an executable is indicated by
pointing to source file of the main subprogram. In C this is the file that
contains the @code{main} function, and in Ada the file that contains the main
unit.
There can be any number of such main files within a given project, and thus
several executables can be built in the context of a single project file. Of
course, one given executable might not (and in fact will not) need all the
source files referenced by the project. As opposed to other build environments
such as @command{makefile}, one does not need to specify the list of
dependencies of each executable, the project-aware builders knows enough of the
semantics of the languages to build ands link only the necessary elements.
@cindex @code{Main}
The list of main files is specified via the @b{Main} attribute. It contains
a list of file names (no directories). If a project defines this
attribute, it is not necessary to identify main files on the
command line when invoking a builder, and editors like
@command{GPS} will be able to create extra menus to spawn or debug the
corresponding executables.
@smallexample
@b{project} Build @b{is}
@b{for} Source_Dirs @b{use} ("common");
@b{for} Object_Dir @b{use} "obj";
@b{for} Exec_Dir @b{use} ".";
@b{for} Main @b{use} ("proc.adb"); -- <<<<
@b{end} Build;
@end smallexample
@noindent
If this attribute is defined in the project, then spawning the builder
with a command such as
@smallexample
gnatmake ^-Pbuild^/PROJECT_FILE=build^
@end smallexample
@noindent
automatically builds all the executables corresponding to the files
listed in the @emph{Main} attribute. It is possible to specify one
or more executables on the command line to build a subset of them.
@c ---------------------------------------------
@node Tools Options in Project Files
@subsection Tools Options in Project Files
@c ---------------------------------------------
@noindent
We now have a project file that fully describes our environment, and can be
used to build the application with a simple @command{gnatmake} command as seen
in the previous section. In fact, the empty project we showed immediately at
the beginning (with no attribute at all) could already fulfill that need if it
was put in the @file{common} directory.
Of course, we always want more control. This section will show you how to
specify the compilation switches that the various tools involved in the
building of the executable should use.
@cindex command line length
Since source names and locations are described into the project file, it is not
necessary to use switches on the command line for this purpose (switches such
as -I for gcc). This removes a major source of command line length overflow.
Clearly, the builders will have to communicate this information one way or
another to the underlying compilers and tools they call but they usually use
response files for this and thus should not be subject to command line
overflows.
Several tools are participating to the creation of an executable: the compiler
produces object files from the source files; the binder (in the Ada case)
creates an source file that takes care, among other things, of elaboration
issues and global variables initialization; and the linker gathers everything
into a single executable that users can execute. All these tools are known by
the project manager and will be called with user defined switches from the
project files. However, we need to introduce a new project file concept to
express which switches to be used for any of the tools involved in the build.
@cindex project file packages
A project file is subdivided into zero or more @b{packages}, each of which
contains the attributes specific to one tool (or one set of tools). Project
files use an Ada-like syntax for packages. Package names permitted in project
files are restricted to a predefined set (@pxref{Packages}), and the contents
of packages are limited to a small set of constructs and attributes
(@pxref{Attributes}).
Our example project file can be extended with the following empty packages. At
this stage, they could all be omitted since they are empty, but they show which
packages would be involved in the build process.
@smallexample
@b{project} Build @b{is}
@b{for} Source_Dirs @b{use} ("common");
@b{for} Object_Dir @b{use} "obj";
@b{for} Exec_Dir @b{use} ".";
@b{for} Main @b{use} ("proc.adb");
@b{package} Builder @b{is} --<<< for gnatmake and gprbuild
@b{end} Builder;
@b{package} Compiler @b{is} --<<< for the compiler
@b{end} Compiler;
@b{package} Binder @b{is} --<<< for the binder
@b{end} Binder;
@b{package} Linker @b{is} --<<< for the linker
@b{end} Linker;
@b{end} Build;
@end smallexample
@noindent
Let's first examine the compiler switches. As stated in the initial description
of the example, we want to compile all files with @option{^-O2^-O2^}. This is a
compiler switch, although it is usual, on the command line, to pass it to the
builder which then passes it to the compiler. It is recommended to use directly
the right package, which will make the setup easier to understand for other
people.
Several attributes can be used to specify the ^switches^switches^:
@table @asis
@item @b{Default_Switches}:
@cindex @code{Default_Switches}
This is the first mention in this manual of an @b{indexed attribute}. When
this attribute is defined, one must supply an @emph{index} in the form of a
literal string.
In the case of @emph{Default_Switches}, the index is the name of the
language to which the switches apply (since a different compiler will
likely be used for each language, and each compiler has its own set of
switches). The value of the attribute is a list of switches.
In this example, we want to compile all Ada source files with the ^switch^switch^
@option{^-O2^-O2^}, and the resulting project file is as follows
(only the @code{Compiler} package is shown):
@smallexample
@b{package} Compiler @b{is}
@b{for} Default_Switches ("Ada") @b{use} ("^-O2^-O2^");
@b{end} Compiler;
@end smallexample
@item @b{^Switches^Switches^}:
@cindex @code{^Switches^Switches^}
in some cases, we might want to use specific ^switches^switches^
for one or more files. For instance, compiling @file{proc.adb} might not be
possible at high level of optimization because of a compiler issue.
In such a case, the @emph{^Switches^Switches^}
attribute (indexed on the file name) can be used and will override the
switches defined by @emph{Default_Switches}. Our project file would
become:
@smallexample
package Compiler is
for Default_Switches ("Ada")
use ("^-O2^-O2^");
for ^Switches^Switches^ ("proc.adb")
use ("^-O0^-O0^");
end Compiler;
@end smallexample
@noindent
@code{^Switches^Switches^} may take a pattern as an index, such as in:
@smallexample
package Compiler is
for Default_Switches ("Ada")
use ("^-O2^-O2^");
for ^Switches^Switches^ ("pkg*")
use ("^-O0^-O0^");
end Compiler;
@end smallexample
@noindent
Sources @file{pkg.adb} and @file{pkg-child.adb} would be compiled with ^-O0^-O0^,
not ^-O2^-O2^.
@noindent
@code{^Switches^Switches^} can also be given a language name as index instead of a file
name in which case it has the same semantics as @emph{Default_Switches}.
However, indexes with wild cards are never valid for language name.
@item @b{Local_Configuration_Pragmas}:
@cindex @code{Local_Configuration_Pragmas}
this attribute may specify the path
of a file containing configuration pragmas for use by the Ada compiler,
such as @code{pragma Restrictions (No_Tasking)}. These pragmas will be
used for all the sources of the project.
@end table
The switches for the other tools are defined in a similar manner through the
@b{Default_Switches} and @b{^Switches^Switches^} attributes, respectively in the
@emph{Builder} package (for @command{gnatmake} and @command{gprbuild}),
the @emph{Binder} package (binding Ada executables) and the @emph{Linker}
package (for linking executables).
@c ---------------------------------------------
@node Compiling with Project Files
@subsection Compiling with Project Files
@c ---------------------------------------------
@noindent
Now that our project files are written, let's build our executable.
Here is the command we would use from the command line:
@smallexample
gnatmake ^-Pbuild^/PROJECT_FILE=build^
@end smallexample
@noindent
This will automatically build the executables specified through the
@emph{Main} attribute: for each, it will compile or recompile the
sources for which the object file does not exist or is not up-to-date; it
will then run the binder; and finally run the linker to create the
executable itself.
@command{gnatmake} only knows how to handle Ada files. By using
@command{gprbuild} as a builder, you could automatically manage C files the
same way: create the file @file{utils.c} in the @file{common} directory,
set the attribute @emph{Languages} to @code{"(Ada, C)"}, and run
@smallexample
gprbuild ^-Pbuild^/PROJECT_FILE=build^
@end smallexample
@noindent
Gprbuild knows how to recompile the C files and will
recompile them only if one of their dependencies has changed. No direct
indication on how to build the various elements is given in the
project file, which describes the project properties rather than a
set of actions to be executed. Here is the invocation of
@command{gprbuild} when building a multi-language program:
@smallexample
$ gprbuild -Pbuild
gcc -c proc.adb
gcc -c pack.adb
gcc -c utils.c
gprbind proc
...
gcc proc.o -o proc
@end smallexample
@noindent
Notice the three steps described earlier:
@itemize @bullet
@item The first three gcc commands correspond to the compilation phase.
@item The gprbind command corresponds to the post-compilation phase.
@item The last gcc command corresponds to the final link.
@end itemize
@noindent
@cindex @option{-v} option (for GPRbuild)
The default output of GPRbuild's execution is kept reasonably simple and easy
to understand. In particular, some of the less frequently used commands are not
shown, and some parameters are abbreviated. So it is not possible to rerun the
effect of the @command{gprbuild} command by cut-and-pasting its output.
GPRbuild's option @code{-v} provides a much more verbose output which includes,
among other information, more complete compilation, post-compilation and link
commands.
@c ---------------------------------------------
@node Executable File Names
@subsection Executable File Names
@c ---------------------------------------------
@noindent
@cindex @code{Executable}
By default, the executable name corresponding to a main file is
computed from the main source file name. Through the attribute
@b{Builder.Executable}, it is possible to change this default.
For instance, instead of building @command{proc} (or @command{proc.exe}
on Windows), we could configure our project file to build "proc1"
(resp proc1.exe) with the following addition:
@smallexample @c projectfile
project Build is
... -- same as before
package Builder is
for Executable ("proc.adb") use "proc1";
end Builder
end Build;
@end smallexample
@noindent
@cindex @code{Executable_Suffix}
Attribute @b{Executable_Suffix}, when specified, may change the suffix
of the executable files, when no attribute @code{Executable} applies:
its value replace the platform-specific executable suffix.
The default executable suffix is empty on UNIX and ".exe" on Windows.
It is also possible to change the name of the produced executable by using the
command line switch @option{-o}. When several mains are defined in the project,
it is not possible to use the @option{-o} switch and the only way to change the
names of the executable is provided by Attributes @code{Executable} and
@code{Executable_Suffix}.
@c ---------------------------------------------
@node Avoid Duplication With Variables
@subsection Avoid Duplication With Variables
@c ---------------------------------------------
@noindent
To illustrate some other project capabilities, here is a slightly more complex
project using similar sources and a main program in C:
@smallexample @c projectfile
project C_Main is
for Languages use ("Ada", "C");
for Source_Dirs use ("common");
for Object_Dir use "obj";
for Main use ("main.c");
package Compiler is
C_Switches := ("-pedantic");
for Default_Switches ("C") use C_Switches;
for Default_Switches ("Ada") use ("^-gnaty^-gnaty^");
for ^Switches^Switches^ ("main.c") use C_Switches & ("-g");
end Compiler;
end C_Main;
@end smallexample
@noindent
This project has many similarities with the previous one.
As expected, its @code{Main} attribute now refers to a C source.
The attribute @emph{Exec_Dir} is now omitted, thus the resulting
executable will be put in the directory @file{obj}.
The most noticeable difference is the use of a variable in the
@emph{Compiler} package to store settings used in several attributes.
This avoids text duplication, and eases maintenance (a single place to
modify if we want to add new switches for C files). We will revisit
the use of variables in the context of scenarios (@pxref{Scenarios in
Projects}).
In this example, we see how the file @file{main.c} can be compiled with
the switches used for all the other C files, plus @option{-g}.
In this specific situation the use of a variable could have been
replaced by a reference to the @code{Default_Switches} attribute:
@smallexample @c projectfile
for ^Switches^Switches^ ("c_main.c") use Compiler'Default_Switches ("C") & ("-g");
@end smallexample
@noindent
Note the tick (@emph{'}) used to refer to attributes defined in a package.
Here is the output of the GPRbuild command using this project:
@smallexample
$gprbuild -Pc_main
gcc -c -pedantic -g main.c
gcc -c -gnaty proc.adb
gcc -c -gnaty pack.adb
gcc -c -pedantic utils.c
gprbind main.bexch
...
gcc main.o -o main
@end smallexample
@noindent
The default switches for Ada sources,
the default switches for C sources (in the compilation of @file{lib.c}),
and the specific switches for @file{main.c} have all been taken into
account.
@c ---------------------------------------------
@node Naming Schemes
@subsection Naming Schemes
@c ---------------------------------------------
@noindent
Sometimes an Ada software system is ported from one compilation environment to
another (say GNAT), and the file are not named using the default GNAT
conventions. Instead of changing all the file names, which for a variety of
reasons might not be possible, you can define the relevant file naming scheme
in the @b{Naming} package of your project file.
The naming scheme has two distinct goals for the project manager: it
allows finding of source files when searching in the source
directories, and given a source file name it makes it possible to guess
the associated language, and thus the compiler to use.
Note that the use by the Ada compiler of pragmas Source_File_Name is not
supported when using project files. You must use the features described in this
paragraph. You can however specify other configuration pragmas.
The following attributes can be defined in package @code{Naming}:
@table @asis
@item @b{Casing}:
@cindex @code{Casing}
Its value must be one of @code{"lowercase"} (the default if
unspecified), @code{"uppercase"} or @code{"mixedcase"}. It describes the
casing of file names with regards to the Ada unit name. Given an Ada unit
My_Unit, the file name will respectively be @file{my_unit.adb} (lowercase),
@file{MY_UNIT.ADB} (uppercase) or @file{My_Unit.adb} (mixedcase).
On Windows, file names are case insensitive, so this attribute is
irrelevant.
@item @b{Dot_Replacement}:
@cindex @code{Dot_Replacement}
This attribute specifies the string that should replace the "." in unit
names. Its default value is @code{"-"} so that a unit
@code{Parent.Child} is expected to be found in the file
@file{parent-child.adb}. The replacement string must satisfy the following
requirements to avoid ambiguities in the naming scheme:
@itemize -
@item It must not be empty
@item It cannot start or end with an alphanumeric character
@item It cannot be a single underscore
@item It cannot start with an underscore followed by an alphanumeric
@item It cannot contain a dot @code{'.'} except if the entire string
is @code{"."}
@end itemize
@item @b{Spec_Suffix} and @b{Specification_Suffix}:
@cindex @code{Spec_Suffix}
@cindex @code{Specification_Suffix}
For Ada, these attributes give the suffix used in file names that contain
specifications. For other languages, they give the extension for files
that contain declaration (header files in C for instance). The attribute
is indexed on the language.
The two attributes are equivalent, but the latter is obsolescent.
If the value of the attribute is the empty string, it indicates to the
Project Manager that the only specifications/header files for the language
are those specified with attributes @code{Spec} or
@code{Specification_Exceptions}.
If @code{Spec_Suffix ("Ada")} is not specified, then the default is
@code{"^.ads^.ADS^"}.
A non empty value must satisfy the following requirements:
@itemize -
@item It must include at least one dot
@item If @code{Dot_Replacement} is a single dot, then it cannot include
more than one dot.
@end itemize
@item @b{Body_Suffix} and @b{Implementation_Suffix}:
@cindex @code{Body_Suffix}
@cindex @code{Implementation_Suffix}
These attributes give the extension used for file names that contain
code (bodies in Ada). They are indexed on the language. The second
version is obsolescent and fully replaced by the first attribute.
For each language of a project, one of these two attributes need to be
specified, either in the project itself or in the configuration project file.
If the value of the attribute is the empty string, it indicates to the
Project Manager that the only source files for the language
are those specified with attributes @code{Body} or
@code{Implementation_Exceptions}.
These attributes must satisfy the same requirements as @code{Spec_Suffix}.
In addition, they must be different from any of the values in
@code{Spec_Suffix}.
If @code{Body_Suffix ("Ada")} is not specified, then the default is
@code{"^.adb^.ADB^"}.
If @code{Body_Suffix ("Ada")} and @code{Spec_Suffix ("Ada")} end with the
same string, then a file name that ends with the longest of these two
suffixes will be a body if the longest suffix is @code{Body_Suffix ("Ada")}
or a spec if the longest suffix is @code{Spec_Suffix ("Ada")}.
If the suffix does not start with a '.', a file with a name exactly equal to
the suffix will also be part of the project (for instance if you define the
suffix as @code{Makefile.in}, a file called @file{Makefile.in} will be part
of the project. This capability is usually not interesting when building.
However, it might become useful when a project is also used to
find the list of source files in an editor, like the GNAT Programming System
(GPS).
@item @b{Separate_Suffix}:
@cindex @code{Separate_Suffix}
This attribute is specific to Ada. It denotes the suffix used in file names
that contain separate bodies. If it is not specified, then it defaults to
same value as @code{Body_Suffix ("Ada")}.
The value of this attribute cannot be the empty string.
Otherwise, the same rules apply as for the
@code{Body_Suffix} attribute. The only accepted index is "Ada".
@item @b{Spec} or @b{Specification}:
@cindex @code{Spec}
@cindex @code{Specification}
This attribute @code{Spec} can be used to define the source file name for a
given Ada compilation unit's spec. The index is the literal name of the Ada
unit (case insensitive). The value is the literal base name of the file that
contains this unit's spec (case sensitive or insensitive depending on the
operating system). This attribute allows the definition of exceptions to the
general naming scheme, in case some files do not follow the usual
convention.
When a source file contains several units, the relative position of the unit
can be indicated. The first unit in the file is at position 1
@smallexample @c projectfile
for Spec ("MyPack.MyChild") use "mypack.mychild.spec";
for Spec ("top") use "foo.a" at 1;
for Spec ("foo") use "foo.a" at 2;
@end smallexample
@item @b{Body} or @b{Implementation}:
@cindex @code{Body}
@cindex @code{Implementation}
These attribute play the same role as @emph{Spec} for Ada bodies.
@item @b{Specification_Exceptions} and @b{Implementation_Exceptions}:
@cindex @code{Specification_Exceptions}
@cindex @code{Implementation_Exceptions}
These attributes define exceptions to the naming scheme for languages
other than Ada. They are indexed on the language name, and contain
a list of file names respectively for headers and source code.
@end table
@ifclear vms
For example, the following package models the Apex file naming rules:
@smallexample @c projectfile
@group
package Naming is
for Casing use "lowercase";
for Dot_Replacement use ".";
for Spec_Suffix ("Ada") use ".1.ada";
for Body_Suffix ("Ada") use ".2.ada";
end Naming;
@end group
@end smallexample
@end ifclear
@ifset vms
For example, the following package models the DEC Ada file naming rules:
@smallexample @c projectfile
@group
package Naming is
for Casing use "lowercase";
for Dot_Replacement use "__";
for Spec_Suffix ("Ada") use "_.ada";
for Body_Suffix ("Ada") use ".ada";
end Naming;
@end group
@end smallexample
@noindent
(Note that @code{Casing} is @code{"lowercase"} because GNAT gets the file
names in lower case)
@end ifset
@c ---------------------------------------------
@node Installation
@subsection Installation
@c ---------------------------------------------
@noindent
After building an application or a library it is often required to
install it into the development environment. For instance this step is
required if the library is to be used by another application.
The @command{gprinstall} tool provides an easy way to install
libraries, executable or object code generated during the build. The
@b{Install} package can be used to change the default locations.
The following attributes can be defined in package @code{Install}:
@table @asis
@item @b{Active}
Whether the project is to be installed, values are @code{true}
(default) or @code{false}.
@item @b{Artifacts}
@cindex @code{Artifacts}
An array attribute to declare a set of files not part of the sources
to be installed. The array discriminant is the directory where the
file is to be installed. If a relative directory then Prefix (see
below) is prepended.
@item @b{Prefix}:
@cindex @code{Prefix}
Root directory for the installation.
@item @b{Exec_Subdir}
Subdirectory of @b{Prefix} where executables are to be
installed. Default is @b{bin}.
@item @b{Lib_Subdir}
Subdirectory of @b{Prefix} where directory with the library or object
files is to be installed. Default is @b{lib}.
@item @b{Sources_Subdir}
Subdirectory of @b{Prefix} where directory with sources is to be
installed. Default is @b{include}.
@item @b{Project_Subdir}
Subdirectory of @b{Prefix} where the generated project file is to be
installed. Default is @b{share/gpr}.
@end table
@c ---------------------------------------------
@node Distributed support
@subsection Distributed support
@c ---------------------------------------------
@noindent
For large projects the compilation time can become a limitation in
the development cycle. To cope with that, GPRbuild supports
distributed compilation.
The following attributes can be defined in package @code{Remote}:
@table @asis
@item @b{Root_Dir}:
@cindex @code{Root_Dir}
Root directory of the project's sources. The default value is the
project's directory.
@end table
@c ---------------------------------------------
@node Organizing Projects into Subsystems
@section Organizing Projects into Subsystems
@c ---------------------------------------------
@noindent
A @b{subsystem} is a coherent part of the complete system to be built. It is
represented by a set of sources and one single object directory. A system can
be composed of a single subsystem when it is simple as we have seen in the
first section. Complex systems are usually composed of several interdependent
subsystems. A subsystem is dependent on another subsystem if knowledge of the
other one is required to build it, and in particular if visibility on some of
the sources of this other subsystem is required. Each subsystem is usually
represented by its own project file.
In this section, the previous example is being extended. Let's assume some
sources of our @code{Build} project depend on other sources.
For instance, when building a graphical interface, it is usual to depend upon
a graphical library toolkit such as GtkAda. Furthermore, we also need
sources from a logging module we had previously written.
@menu
* Project Dependencies::
* Cyclic Project Dependencies::
* Sharing Between Projects::
* Global Attributes::
@end menu
@c ---------------------------------------------
@node Project Dependencies
@subsection Project Dependencies
@c ---------------------------------------------
@noindent
GtkAda comes with its own project file (appropriately called
@file{gtkada.gpr}), and we will assume we have already built a project
called @file{logging.gpr} for the logging module. With the information provided
so far in @file{build.gpr}, building the application would fail with an error
indicating that the gtkada and logging units that are relied upon by the sources
of this project cannot be found.
This is easily solved by adding the following @b{with} clauses at the beginning
of our project:
@smallexample @c projectfile
with "gtkada.gpr";
with "a/b/logging.gpr";
project Build is
... -- as before
end Build;
@end smallexample
@noindent
@cindex @code{Externally_Built}
When such a project is compiled, @command{gnatmake} will automatically
check the other projects and recompile their sources when needed. It will also
recompile the sources from @code{Build} when needed, and finally create the
executable. In some cases, the implementation units needed to recompile a
project are not available, or come from some third-party and you do not want to
recompile it yourself. In this case, the attribute @b{Externally_Built} to
"true" can be set, indicating to the builder that this project can be assumed
to be up-to-date, and should not be considered for recompilation. In Ada, if
the sources of this externally built project were compiled with another version
of the compiler or with incompatible options, the binder will issue an error.
The project's @code{with} clause has several effects. It provides source
visibility between projects during the compilation process. It also guarantees
that the necessary object files from @code{Logging} and @code{GtkAda} are
available when linking @code{Build}.
As can be seen in this example, the syntax for importing projects is similar
to the syntax for importing compilation units in Ada. However, project files
use literal strings instead of names, and the @code{with} clause identifies
project files rather than packages.
Each literal string after @code{with} is the path
(absolute or relative) to a project file. The @code{.gpr} extension is
optional, although we recommend adding it. If no extension is specified,
and no project file with the @file{^.gpr^.GPR^} extension is found, then
the file is searched for exactly as written in the @code{with} clause,
that is with no extension.
As mentioned above, the path after a @code{with} has to be a literal
string, and you cannot use concatenation, or lookup the value of external
variables to change the directories from which a project is loaded.
A solution if you need something like this is to use aggregate projects
(@pxref{Aggregate Projects}).
@cindex project path
When a relative path or a base name is used, the
project files are searched relative to each of the directories in the
@b{project path}. This path includes all the directories found with the
following algorithm, in that order, as soon as a matching file is found,
the search stops:
@itemize @bullet
@item First, the file is searched relative to the directory that contains the
current project file.
@item
@cindex @code{GPR_PROJECT_PATH_FILE}
@cindex @code{GPR_PROJECT_PATH}
@cindex @code{ADA_PROJECT_PATH}
Then it is searched relative to all the directories specified in the
^environment variables^logical names^ @b{GPR_PROJECT_PATH_FILE},
@b{GPR_PROJECT_PATH} and @b{ADA_PROJECT_PATH} (in that order) if they exist.
The value of @b{GPR_PROJECT_PATH_FILE}, when defined, is the path name of
a text file that contains project directory path names, one per line.
@b{GPR_PROJECT_PATH} and @b{ADA_PROJECT_PATH}, when defined, contain
project directory path names separated by directory separators.
@b{ADA_PROJECT_PATH} is used for compatibility, it is recommended to
use @b{GPR_PROJECT_PATH_FILE} or @b{GPR_PROJECT_PATH}.
@item Finally, it is searched relative to the default project directories.
Such directories depends on the tool used. The different locations searched
in the specified order are:
@itemize @bullet
@item @file{//lib/gnat}
(for @command{gnatmake} in all cases, and for @command{gprbuild} if option
@option{--target} is specified)
@item @file{//share/gpr}
(for @command{gnatmake} in all cases, and for @command{gprbuild} if option
@option{--target} is specified)
@item @file{/share/gpr/}
(for @command{gnatmake} and @command{gprbuild})
@item @file{/lib/gnat/}
(for @command{gnatmake} and @command{gprbuild})
@end itemize
In our example, @file{gtkada.gpr} is found in the predefined directory if
it was installed at the same root as GNAT.
@end itemize
@noindent
Some tools also support extending the project path from the command line,
generally through the @option{-aP}. You can see the value of the project
path by using the @command{gnatls -v} command.
Any symbolic link will be fully resolved in the directory of the
importing project file before the imported project file is examined.
Any source file in the imported project can be used by the sources of the
importing project, transitively.
Thus if @code{A} imports @code{B}, which imports @code{C}, the sources of
@code{A} may depend on the sources of @code{C}, even if @code{A} does not
import @code{C} explicitly. However, this is not recommended, because if
and when @code{B} ceases to import @code{C}, some sources in @code{A} will
no longer compile. @command{gprbuild} has a switch @option{--no-indirect-imports}
that will report such indirect dependencies.
One very important aspect of a project hierarchy is that
@b{a given source can only belong to one project} (otherwise the project manager
would not know which settings apply to it and when to recompile it). It means
that different project files do not usually share source directories or
when they do, they need to specify precisely which project owns which sources
using attribute @code{Source_Files} or equivalent. By contrast, 2 projects
can each own a source with the same base file name as long as they live in
different directories. The latter is not true for Ada Sources because of the
correlation between source files and Ada units.
@c ---------------------------------------------
@node Cyclic Project Dependencies
@subsection Cyclic Project Dependencies
@c ---------------------------------------------
@noindent
Cyclic dependencies are mostly forbidden:
if @code{A} imports @code{B} (directly or indirectly) then @code{B}
is not allowed to import @code{A}. However, there are cases when cyclic
dependencies would be beneficial. For these cases, another form of import
between projects exists: the @b{limited with}. A project @code{A} that
imports a project @code{B} with a straight @code{with} may also be imported,
directly or indirectly, by @code{B} through a @code{limited with}.
The difference between straight @code{with} and @code{limited with} is that
the name of a project imported with a @code{limited with} cannot be used in the
project importing it. In particular, its packages cannot be renamed and
its variables cannot be referred to.
@smallexample @c 0projectfile
with "b.gpr";
with "c.gpr";
project A is
For Exec_Dir use B'Exec_Dir; -- ok
end A;
limited with "a.gpr"; -- Cyclic dependency: A -> B -> A
project B is
For Exec_Dir use A'Exec_Dir; -- not ok
end B;
with "d.gpr";
project C is
end C;
limited with "a.gpr"; -- Cyclic dependency: A -> C -> D -> A
project D is
For Exec_Dir use A'Exec_Dir; -- not ok
end D;
@end smallexample
@c ---------------------------------------------
@node Sharing Between Projects
@subsection Sharing Between Projects
@c ---------------------------------------------
@noindent
When building an application, it is common to have similar needs in several of
the projects corresponding to the subsystems under construction. For instance,
they will all have the same compilation switches.
As seen before (@pxref{Tools Options in Project Files}), setting compilation
switches for all sources of a subsystem is simple: it is just a matter of
adding a @code{Compiler.Default_Switches} attribute to each project files with
the same value. Of course, that means duplication of data, and both places need
to be changed in order to recompile the whole application with different
switches. It can become a real problem if there are many subsystems and thus
many project files to edit.
There are two main approaches to avoiding this duplication:
@itemize @bullet
@item Since @file{build.gpr} imports @file{logging.gpr}, we could change it
to reference the attribute in Logging, either through a package renaming,
or by referencing the attribute. The following example shows both cases:
@smallexample @c projectfile
project Logging is
package Compiler is
for ^Switches^Switches^ ("Ada")
use ("^-O2^-O2^");
end Compiler;
package Binder is
for ^Switches^Switches^ ("Ada")
use ("-E");
end Binder;
end Logging;
with "logging.gpr";
project Build is
package Compiler renames Logging.Compiler;
package Binder is
for ^Switches^Switches^ ("Ada") use Logging.Binder'Switches ("Ada");
end Binder;
end Build;
@end smallexample
@noindent
The solution used for @code{Compiler} gets the same value for all
attributes of the package, but you cannot modify anything from the
package (adding extra switches or some exceptions). The second
version is more flexible, but more verbose.
If you need to refer to the value of a variable in an imported
project, rather than an attribute, the syntax is similar but uses
a "." rather than an apostrophe. For instance:
@smallexample @c projectfile
with "imported";
project Main is
Var1 := Imported.Var;
end Main;
@end smallexample
@item The second approach is to define the switches in a third project.
That project is setup without any sources (so that, as opposed to
the first example, none of the project plays a special role), and
will only be used to define the attributes. Such a project is
typically called @file{shared.gpr}.
@smallexample @c projectfile
abstract project Shared is
for Source_Files use (); -- no sources
package Compiler is
for ^Switches^Switches^ ("Ada")
use ("^-O2^-O2^");
end Compiler;
end Shared;
with "shared.gpr";
project Logging is
package Compiler renames Shared.Compiler;
end Logging;
with "shared.gpr";
project Build is
package Compiler renames Shared.Compiler;
end Build;
@end smallexample
@noindent
As for the first example, we could have chosen to set the attributes
one by one rather than to rename a package. The reason we explicitly
indicate that @code{Shared} has no sources is so that it can be created
in any directory and we are sure it shares no sources with @code{Build}
or @code{Logging}, which of course would be invalid.
@cindex project qualifier
Note the additional use of the @b{abstract} qualifier in @file{shared.gpr}.
This qualifier is optional, but helps convey the message that we do not
intend this project to have sources (@pxref{Qualified Projects} for
more qualifiers).
@end itemize
@c ---------------------------------------------
@node Global Attributes
@subsection Global Attributes
@c ---------------------------------------------
@noindent
We have already seen many examples of attributes used to specify a special
option of one of the tools involved in the build process. Most of those
attributes are project specific. That it to say, they only affect the invocation
of tools on the sources of the project where they are defined.
There are a few additional attributes that apply to all projects in a
hierarchy as long as they are defined on the "main" project.
The main project is the project explicitly mentioned on the command-line.
The project hierarchy is the "with"-closure of the main project.
Here is a list of commonly used global attributes:
@table @asis
@item @b{Builder.Global_Configuration_Pragmas}:
@cindex @code{Global_Configuration_Pragmas}
This attribute points to a file that contains configuration pragmas
to use when building executables. These pragmas apply for all
executables built from this project hierarchy. As we have seen before,
additional pragmas can be specified on a per-project basis by setting the
@code{Compiler.Local_Configuration_Pragmas} attribute.
@item @b{Builder.Global_Compilation_Switches}:
@cindex @code{Global_Compilation_Switches}
This attribute is a list of compiler switches to use when compiling any
source file in the project hierarchy. These switches are used in addition
to the ones defined in the @code{Compiler} package, which only apply to
the sources of the corresponding project. This attribute is indexed on
the name of the language.
@end table
Using such global capabilities is convenient. It can also lead to unexpected
behavior. Especially when several subsystems are shared among different main
projects and the different global attributes are not
compatible. Note that using aggregate projects can be a safer and more powerful
replacement to global attributes.
@c ---------------------------------------------
@node Scenarios in Projects
@section Scenarios in Projects
@c ---------------------------------------------
@noindent
Various aspects of the projects can be modified based on @b{scenarios}. These
are user-defined modes that change the behavior of a project. Typical
examples are the setup of platform-specific compiler options, or the use of
a debug and a release mode (the former would activate the generation of debug
information, when the second will focus on improving code optimization).
Let's enhance our example to support a debug and a release modes.The issue is to
let the user choose what kind of system he is building:
use @option{-g} as compiler switches in debug mode and @option{^-O2^-O2^}
in release mode. We will also setup the projects so that we do not share the
same object directory in both modes, otherwise switching from one to the other
might trigger more recompilations than needed or mix objects from the 2 modes.
One naive approach is to create two different project files, say
@file{build_debug.gpr} and @file{build_release.gpr}, that set the appropriate
attributes as explained in previous sections. This solution does not scale well,
because in presence of multiple projects depending on each other,
you will also have to duplicate the complete hierarchy and adapt the project
files to point to the right copies.
@cindex scenarios
Instead, project files support the notion of scenarios controlled
by external values. Such values can come from several sources (in decreasing
order of priority):
@table @asis
@item @b{Command line}:
@cindex @option{-X}
When launching @command{gnatmake} or @command{gprbuild}, the user can pass
extra @option{-X} switches to define the external value. In
our case, the command line might look like
@smallexample
gnatmake -Pbuild.gpr -Xmode=debug
or gnatmake -Pbuild.gpr -Xmode=release
@end smallexample
@item @b{^Environment variables^Logical names^}:
When the external value does not come from the command line, it can come from
the value of ^environment variables^logical names^ of the appropriate name.
In our case, if ^an environment variable^a logical name^ called "mode"
exist, its value will be taken into account.
@item @b{External function second parameter}
@end table
@cindex @code{external}
We now need to get that value in the project. The general form is to use
the predefined function @b{external} which returns the current value of
the external. For instance, we could setup the object directory to point to
either @file{obj/debug} or @file{obj/release} by changing our project to
@smallexample @c projectfile
project Build is
for Object_Dir use "obj/" & external ("mode", "debug");
... -- as before
end Build;
@end smallexample
@noindent
The second parameter to @code{external} is optional, and is the default
value to use if "mode" is not set from the command line or the environment.
In order to set the switches according to the different scenarios, other
constructs have to be introduced such as typed variables and case constructions.
@cindex typed variable
@cindex case construction
A @b{typed variable} is a variable that
can take only a limited number of values, similar to an enumeration in Ada.
Such a variable can then be used in a @b{case construction} and create conditional
sections in the project. The following example shows how this can be done:
@smallexample @c projectfile
project Build is
type Mode_Type is ("debug", "release"); -- all possible values
Mode : Mode_Type := external ("mode", "debug"); -- a typed variable
package Compiler is
case Mode is
when "debug" =>
for ^Switches^Switches^ ("Ada")
use ("-g");
when "release" =>
for ^Switches^Switches^ ("Ada")
use ("^-O2^-O2^");
end case;
end Compiler;
end Build;
@end smallexample
@noindent
The project has suddenly grown in size, but has become much more flexible.
@code{Mode_Type} defines the only valid values for the @code{mode} variable. If
any other value is read from the environment, an error is reported and the
project is considered as invalid.
The @code{Mode} variable is initialized with an external value
defaulting to @code{"debug"}. This default could be omitted and that would
force the user to define the value. Finally, we can use a case construction to set the
switches depending on the scenario the user has chosen.
Most aspects of the projects can depend on scenarios. The notable exception
are project dependencies (@code{with} clauses), which may not depend on a scenario.
Scenarios work the same way with @b{project hierarchies}: you can either
duplicate a variable similar to @code{Mode} in each of the project (as long
as the first argument to @code{external} is always the same and the type is
the same), or simply set the variable in the @file{shared.gpr} project
(@pxref{Sharing Between Projects}).
@c ---------------------------------------------
@node Library Projects
@section Library Projects
@c ---------------------------------------------
@noindent
So far, we have seen examples of projects that create executables. However,
it is also possible to create libraries instead. A @b{library} is a specific
type of subsystem where, for convenience, objects are grouped together
using system-specific means such as archives or windows DLLs.
Library projects provide a system- and language-independent way of building both @b{static}
and @b{dynamic} libraries. They also support the concept of @b{standalone
libraries} (SAL) which offers two significant properties: the elaboration
(e.g. initialization) of the library is either automatic or very simple;
a change in the
implementation part of the library implies minimal post-compilation actions on
the complete system and potentially no action at all for the rest of the
system in the case of dynamic SALs.
There is a restriction on shared library projects: by default, they are only
allowed to import other shared library projects. They are not allowed to
import non library projects or static library projects.
The GNAT Project Manager takes complete care of the library build, rebuild and
installation tasks, including recompilation of the source files for which
objects do not exist or are not up to date, assembly of the library archive, and
installation of the library (i.e., copying associated source, object and
@file{ALI} files to the specified location).
@menu
* Building Libraries::
* Using Library Projects::
* Stand-alone Library Projects::
* Installing a library with project files::
@end menu
@c ---------------------------------------------
@node Building Libraries
@subsection Building Libraries
@c ---------------------------------------------
@noindent
Let's enhance our example and transform the @code{logging} subsystem into a
library. In order to do so, a few changes need to be made to @file{logging.gpr}.
A number of specific attributes needs to be defined: at least @code{Library_Name}
and @code{Library_Dir}; in addition, a number of other attributes can be used
to specify specific aspects of the library. For readability, it is also
recommended (although not mandatory), to use the qualifier @code{library} in
front of the @code{project} keyword.
@table @asis
@item @b{Library_Name}:
@cindex @code{Library_Name}
This attribute is the name of the library to be built. There is no
restriction on the name of a library imposed by the project manager, except
for stand-alone libraries whose names must follow the syntax of Ada
identifiers; however, there may be system specific restrictions on the name.
In general, it is recommended to stick to alphanumeric characters (and
possibly single underscores) to help portability.
@item @b{Library_Dir}:
@cindex @code{Library_Dir}
This attribute is the path (absolute or relative) of the directory where
the library is to be installed. In the process of building a library,
the sources are compiled, the object files end up in the explicit or
implicit @code{Object_Dir} directory. When all sources of a library
are compiled, some of the compilation artifacts, including the library itself,
are copied to the library_dir directory. This directory must exists and be
writable. It must also be different from the object directory so that cleanup
activities in the Library_Dir do not affect recompilation needs.
@end table
Here is the new version of @file{logging.gpr} that makes it a library:
@smallexample @c projectfile
library project Logging is -- "library" is optional
for Library_Name use "logging"; -- will create "liblogging.a" on Unix
for Object_Dir use "obj";
for Library_Dir use "lib"; -- different from object_dir
end Logging;
@end smallexample
@noindent
Once the above two attributes are defined, the library project is valid and
is enough for building a library with default characteristics.
Other library-related attributes can be used to change the defaults:
@table @asis
@item @b{Library_Kind}:
@cindex @code{Library_Kind}
The value of this attribute must be either @code{"static"}, @code{"dynamic"} or
@code{"relocatable"} (the latter is a synonym for dynamic). It indicates
which kind of library should be built (the default is to build a
static library, that is an archive of object files that can potentially
be linked into a static executable). When the library is set to be dynamic,
a separate image is created that will be loaded independently, usually
at the start of the main program execution. Support for dynamic libraries is
very platform specific, for instance on Windows it takes the form of a DLL
while on GNU/Linux, it is a dynamic elf image whose suffix is usually
@file{.so}. Library project files, on the other hand, can be written in
a platform independent way so that the same project file can be used to build
a library on different operating systems.
If you need to build both a static and a dynamic library, it is recommended
use two different object directories, since in some cases some extra code
needs to be generated for the latter. For such cases, one can
either define two different project files, or a single one which uses scenarios
to indicate the various kinds of library to be built and their
corresponding object_dir.
@cindex @code{Library_ALI_Dir}
@item @b{Library_ALI_Dir}:
This attribute may be specified to indicate the directory where the ALI
files of the library are installed. By default, they are copied into the
@code{Library_Dir} directory, but as for the executables where we have a
separate @code{Exec_Dir} attribute, you might want to put them in a separate
directory since there can be hundreds of them. The same restrictions as for
the @code{Library_Dir} attribute apply.
@cindex @code{Library_Version}
@item @b{Library_Version}:
This attribute is platform dependent, and has no effect on VMS and Windows.
On Unix, it is used only for dynamic libraries as the internal
name of the library (the @code{"soname"}). If the library file name (built
from the @code{Library_Name}) is different from the @code{Library_Version},
then the library file will be a symbolic link to the actual file whose name
will be @code{Library_Version}. This follows the usual installation schemes
for dynamic libraries on many Unix systems.
@smallexample @c projectfile
@group
project Logging is
Version := "1";
for Library_Dir use "lib";
for Library_Name use "logging";
for Library_Kind use "dynamic";
for Library_Version use "liblogging.so." & Version;
end Logging;
@end group
@end smallexample
@noindent
After the compilation, the directory @file{lib} will contain both a
@file{libdummy.so.1} library and a symbolic link to it called
@file{libdummy.so}.
@cindex @code{Library_GCC}
@item @b{Library_GCC}:
This attribute is the name of the tool to use instead of "gcc" to link shared
libraries. A common use of this attribute is to define a wrapper script that
accomplishes specific actions before calling gcc (which itself is calling the
linker to build the library image).
@item @b{Library_Options}:
@cindex @code{Library_Options}
This attribute may be used to specify additional switches (last switches)
when linking a shared library.
@item @b{Leading_Library_Options}:
@cindex @code{Leading_Library_Options}
This attribute, that is taken into account only by @command{gprbuild}, may be
used to specified leading options (first switches) when linking a shared
library.
@cindex @code{Linker_Options}
@item @b{Linker.Linker_Options}:
This attribute specifies additional switches to be given to the linker when
linking an executable. It is ignored when defined in the main project and
taken into account in all other projects that are imported directly or
indirectly. These switches complement the @code{Linker.Switches}
defined in the main project. This is useful when a particular subsystem
depends on an external library: adding this dependency as a
@code{Linker_Options} in the project of the subsystem is more convenient than
adding it to all the @code{Linker.Switches} of the main projects that depend
upon this subsystem.
@end table
@c ---------------------------------------------
@node Using Library Projects
@subsection Using Library Projects
@c ---------------------------------------------
@noindent
When the builder detects that a project file is a library project file, it
recompiles all sources of the project that need recompilation and rebuild the
library if any of the sources have been recompiled. It then groups all object
files into a single file, which is a shared or a static library. This library
can later on be linked with multiple executables. Note that the use
of shard libraries reduces the size of the final executable and can also reduce
the memory footprint at execution time when the library is shared among several
executables.
It is also possible to build @b{multi-language libraries}. When using
@command{gprbuild} as a builder, multi-language library projects allow naturally
the creation of multi-language libraries . @command{gnatmake}, does not try to
compile non Ada sources. However, when the project is multi-language, it will
automatically link all object files found in the object directory, whether or
not they were compiled from an Ada source file. This specific behavior does not
apply to Ada-only projects which only take into account the objects
corresponding to the sources of the project.
A non-library project can import a library project. When the builder is invoked
on the former, the library of the latter is only rebuilt when absolutely
necessary. For instance, if a unit of the
library is not up-to-date but non of the executables need this unit, then the
unit is not recompiled and the library is not reassembled.
For instance, let's assume in our example that logging has the following
sources: @file{log1.ads}, @file{log1.adb}, @file{log2.ads} and
@file{log2.adb}. If @file{log1.adb} has been modified, then the library
@file{liblogging} will be rebuilt when compiling all the sources of
@code{Build} only if @file{proc.ads}, @file{pack.ads} or @file{pack.adb}
include a @code{"with Log1"}.
To ensure that all the sources in the @code{Logging} library are
up to date, and that all the sources of @code{Build} are also up to date,
the following two commands needs to be used:
@smallexample
gnatmake -Plogging.gpr
gnatmake -Pbuild.gpr
@end smallexample
@noindent
All @file{ALI} files will also be copied from the object directory to the
library directory. To build executables, @command{gnatmake} will use the
library rather than the individual object files.
@ifclear vms
Library projects can also be useful to describe a library that need to be used
but, for some reason, cannot be rebuilt. For instance, it is the case when some
of the library sources are not available. Such library projects need simply to
use the @code{Externally_Built} attribute as in the example below:
@smallexample @c projectfile
library project Extern_Lib is
for Languages use ("Ada", "C");
for Source_Dirs use ("lib_src");
for Library_Dir use "lib2";
for Library_Kind use "dynamic";
for Library_Name use "l2";
for Externally_Built use "true"; -- <<<<
end Extern_Lib;
@end smallexample
@noindent
In the case of externally built libraries, the @code{Object_Dir}
attribute does not need to be specified because it will never be
used.
The main effect of using such an externally built library project is mostly to
affect the linker command in order to reference the desired library. It can
also be achieved by using @code{Linker.Linker_Options} or @code{Linker.Switches}
in the project corresponding to the subsystem needing this external library.
This latter method is more straightforward in simple cases but when several
subsystems depend upon the same external library, finding the proper place
for the @code{Linker.Linker_Options} might not be easy and if it is
not placed properly, the final link command is likely to present ordering issues.
In such a situation, it is better to use the externally built library project
so that all other subsystems depending on it can declare this dependency thanks
to a project @code{with} clause, which in turn will trigger the builder to find
the proper order of libraries in the final link command.
@end ifclear
@c ---------------------------------------------
@node Stand-alone Library Projects
@subsection Stand-alone Library Projects
@c ---------------------------------------------
@noindent
@cindex standalone libraries
A @b{stand-alone library} is a library that contains the necessary code to
elaborate the Ada units that are included in the library. A stand-alone
library is a convenient way to add an Ada subsystem to a more global system
whose main is not in Ada since it makes the elaboration of the Ada part mostly
transparent. However, stand-alone libraries are also useful when the main is in
Ada: they provide a means for minimizing relinking & redeployment of complex
systems when localized changes are made.
The name of a stand-alone library, specified with attribute
@code{Library_Name}, must have the syntax of an Ada identifier.
The most prominent characteristic of a stand-alone library is that it offers a
distinction between interface units and implementation units. Only the former
are visible to units outside the library. A stand-alone library project is thus
characterised by a third attribute, usually @b{Library_Interface}, in addition
to the two attributes that make a project a Library Project
(@code{Library_Name} and @code{Library_Dir}). This third attribute may also be
@b{Interfaces}. @b{Library_Interface} only works when the interface is in Ada
and takes a list of units as parameter. @b{Interfaces} works for any supported
language and takes a list of sources as parameter.
@table @asis
@item @b{Library_Interface}:
@cindex @code{Library_Interface}
This attribute defines an explicit subset of the units of the project. Units
from projects importing this library project may only "with" units whose
sources are listed in the @code{Library_Interface}. Other sources are
considered implementation units.
@smallexample @c projectfile
@group
for Library_Dir use "lib";
for Library_Name use "loggin";
for Library_Interface use ("lib1", "lib2"); -- unit names
@end group
@end smallexample
@item @b{Interfaces}
This attribute defines an explicit subset of the source files of a project.
Sources from projects importing this project, can only depend on sources from
this subset. This attribute can be used on non library projects. It can also
be used as a replacement for attribute @code{Library_Interface}, in which
case, units have to be replaced by source files. For multi-language library
projects, it is the only way to make the project a Stand-Alone Library project
whose interface is not purely Ada.
@item @b{Library_Standalone}:
@cindex @code{Library_Standalone}
This attribute defines the kind of standalone library to
build. Values are either @code{standard} (the default), @code{no} or
@code{encapsulated}. When @code{standard} is used the code to elaborate and
finalize the library is embedded, when @code{encapsulated} is used the
library can furthermore only depends on static libraries (including
the GNAT runtime). This attribute can be set to @code{no} to make it clear
that the library should not be standalone in which case the
@code{Library_Interface} should not defined. Note that this attribute
only applies to shared libraries, so @code{Library_Kind} must be set
to @code{dynamic}.
@smallexample @c projectfile
@group
for Library_Dir use "lib";
for Library_Name use "loggin";
for Library_Kind use "dynamic";
for Library_Interface use ("lib1", "lib2"); -- unit names
for Library_Standalone use "encapsulated";
@end group
@end smallexample
@end table
In order to include the elaboration code in the stand-alone library, the binder
is invoked on the closure of the library units creating a package whose name
depends on the library name (^b~logging.ads/b^B$LOGGING.ADS/B^ in the example).
This binder-generated package includes @b{initialization} and @b{finalization}
procedures whose names depend on the library name (@code{logginginit} and
@code{loggingfinal} in the example). The object corresponding to this package is
included in the library.
@table @asis
@item @b{Library_Auto_Init}:
@cindex @code{Library_Auto_Init}
A dynamic stand-alone Library is automatically initialized
if automatic initialization of Stand-alone Libraries is supported on the
platform and if attribute @b{Library_Auto_Init} is not specified or
is specified with the value "true". A static Stand-alone Library is never
automatically initialized. Specifying "false" for this attribute
prevent automatic initialization.
When a non-automatically initialized stand-alone library is used in an
executable, its initialization procedure must be called before any service of
the library is used. When the main subprogram is in Ada, it may mean that the
initialization procedure has to be called during elaboration of another
package.
@item @b{Library_Dir}:
@cindex @code{Library_Dir}
For a stand-alone library, only the @file{ALI} files of the interface units
(those that are listed in attribute @code{Library_Interface}) are copied to
the library directory. As a consequence, only the interface units may be
imported from Ada units outside of the library. If other units are imported,
the binding phase will fail.
@item @b{Binder.Default_Switches}:
When a stand-alone library is bound, the switches that are specified in
the attribute @b{Binder.Default_Switches ("Ada")} are
used in the call to @command{gnatbind}.
@item @b{Library_Src_Dir}:
@cindex @code{Library_Src_Dir}
This attribute defines the location (absolute or relative to the project
directory) where the sources of the interface units are copied at
installation time.
These sources includes the specs of the interface units along with the closure
of sources necessary to compile them successfully. That may include bodies and
subunits, when pragmas @code{Inline} are used, or when there is a generic
units in the spec. This directory cannot point to the object directory or
one of the source directories, but it can point to the library directory,
which is the default value for this attribute.
@item @b{Library_Symbol_Policy}:
@cindex @code{Library_Symbol_Policy}
This attribute controls the export of symbols and, on some platforms (like
VMS) that have the notions of major and minor IDs built in the library
files, it controls the setting of these IDs. It is not supported on all
platforms (where it will just have no effect). It may have one of the
following values:
@itemize -
@item @code{"autonomous"} or @code{"default"}: exported symbols are not controlled
@item @code{"compliant"}: if attribute @b{Library_Reference_Symbol_File}
is not defined, then it is equivalent to policy "autonomous". If there
are exported symbols in the reference symbol file that are not in the
object files of the interfaces, the major ID of the library is increased.
If there are symbols in the object files of the interfaces that are not
in the reference symbol file, these symbols are put at the end of the list
in the newly created symbol file and the minor ID is increased.
@item @code{"controlled"}: the attribute @b{Library_Reference_Symbol_File} must be
defined. The library will fail to build if the exported symbols in the
object files of the interfaces do not match exactly the symbol in the
symbol file.
@item @code{"restricted"}: The attribute @b{Library_Symbol_File} must be defined.
The library will fail to build if there are symbols in the symbol file that
are not in the exported symbols of the object files of the interfaces.
Additional symbols in the object files are not added to the symbol file.
@item @code{"direct"}: The attribute @b{Library_Symbol_File} must be defined and
must designate an existing file in the object directory. This symbol file
is passed directly to the underlying linker without any symbol processing.
@end itemize
@item @b{Library_Reference_Symbol_File}
@cindex @code{Library_Reference_Symbol_File}
This attribute may define the path name of a reference symbol file that is
read when the symbol policy is either "compliant" or "controlled", on
platforms that support symbol control, such as VMS, when building a
stand-alone library. The path may be an absolute path or a path relative
to the project directory.
@item @b{Library_Symbol_File}
@cindex @code{Library_Symbol_File}
This attribute may define the name of the symbol file to be created when
building a stand-alone library when the symbol policy is either "compliant",
"controlled" or "restricted", on platforms that support symbol control,
such as VMS. When symbol policy is "direct", then a file with this name
must exist in the object directory.
@end table
@c ---------------------------------------------
@node Installing a library with project files
@subsection Installing a library with project files
@c ---------------------------------------------
@noindent
When using project files, a usable version of the library is created in the
directory specified by the @code{Library_Dir} attribute of the library
project file. Thus no further action is needed in order to make use of
the libraries that are built as part of the general application build.
You may want to install a library in a context different from where the library
is built. This situation arises with third party suppliers, who may want
to distribute a library in binary form where the user is not expected to be
able to recompile the library. The simplest option in this case is to provide
a project file slightly different from the one used to build the library, by
using the @code{externally_built} attribute. @ref{Using Library Projects}
Another option is to use @command{gprinstall} to install the library in a
different context than the build location. A project to use this library is
generated automatically by @command{gprinstall} which also copy, in the install
location, the minimum set of sources needed to use the library.
@ref{Installation}
@c ---------------------------------------------
@node Project Extension
@section Project Extension
@c ---------------------------------------------
@noindent
During development of a large system, it is sometimes necessary to use
modified versions of some of the source files, without changing the original
sources. This can be achieved through the @b{project extension} facility.
Suppose for instance that our example @code{Build} project is built every night
for the whole team, in some shared directory. A developer usually need to work
on a small part of the system, and might not want to have a copy of all the
sources and all the object files (mostly because that would require too much
disk space, time to recompile everything). He prefers to be able to override
some of the source files in his directory, while taking advantage of all the
object files generated at night.
Another example can be taken from large software systems, where it is common to have
multiple implementations of a common interface; in Ada terms, multiple
versions of a package body for the same spec. For example, one implementation
might be safe for use in tasking programs, while another might only be used
in sequential applications. This can be modeled in GNAT using the concept
of @emph{project extension}. If one project (the ``child'') @emph{extends}
another project (the ``parent'') then by default all source files of the
parent project are inherited by the child, but the child project can
override any of the parent's source files with new versions, and can also
add new files or remove unnecessary ones.
This facility is the project analog of a type extension in
object-oriented programming. Project hierarchies are permitted (an extending
project may itself be extended), and a project that
extends a project can also import other projects.
A third example is that of using project extensions to provide different
versions of the same system. For instance, assume that a @code{Common}
project is used by two development branches. One of the branches has now
been frozen, and no further change can be done to it or to @code{Common}.
However, the other development branch still needs evolution of @code{Common}.
Project extensions provide a flexible solution to create a new version
of a subsystem while sharing and reusing as much as possible from the original
one.
A project extension inherits implicitly all the sources and objects from the
project it extends. It is possible to create a new version of some of the
sources in one of the additional source dirs of the extending project. Those new
versions hide the original versions. Adding new sources or removing existing
ones is also possible. Here is an example on how to extend the project
@code{Build} from previous examples:
@smallexample @c projectfile
project Work extends "../bld/build.gpr" is
end Work;
@end smallexample
@noindent
The project after @b{extends} is the one being extended. As usual, it can be
specified using an absolute path, or a path relative to any of the directories
in the project path (@pxref{Project Dependencies}). This project does not
specify source or object directories, so the default value for these attribute
will be used that is to say the current directory (where project @code{Work} is
placed). We can already compile that project with
@smallexample
gnatmake -Pwork
@end smallexample
@noindent
If no sources have been placed in the current directory, this command
won't do anything, since this project does not change the
sources it inherited from @code{Build}, therefore all the object files
in @code{Build} and its dependencies are still valid and are reused
automatically.
Suppose we now want to supply an alternate version of @file{pack.adb}
but use the existing versions of @file{pack.ads} and @file{proc.adb}.
We can create the new file Work's current directory (likely
by copying the one from the @code{Build} project and making changes to
it. If new packages are needed at the same time, we simply create
new files in the source directory of the extending project.
When we recompile, @command{gnatmake} will now automatically recompile
this file (thus creating @file{pack.o} in the current directory) and
any file that depends on it (thus creating @file{proc.o}). Finally, the
executable is also linked locally.
Note that we could have obtained the desired behavior using project import
rather than project inheritance. A @code{base} project would contain the
sources for @file{pack.ads} and @file{proc.adb}, and @code{Work} would
import @code{base} and add @file{pack.adb}. In this scenario, @code{base}
cannot contain the original version of @file{pack.adb} otherwise there would be
2 versions of the same unit in the closure of the project and this is not
allowed. Generally speaking, it is not recommended to put the spec and the
body of a unit in different projects since this affects their autonomy and
reusability.
In a project file that extends another project, it is possible to
indicate that an inherited source is @b{not part} of the sources of the
extending project. This is necessary sometimes when a package spec has
been overridden and no longer requires a body: in this case, it is
necessary to indicate that the inherited body is not part of the sources
of the project, otherwise there will be a compilation error
when compiling the spec.
@cindex @code{Excluded_Source_Files}
@cindex @code{Excluded_Source_List_File}
For that purpose, the attribute @b{Excluded_Source_Files} is used.
Its value is a list of file names.
It is also possible to use attribute @code{Excluded_Source_List_File}.
Its value is the path of a text file containing one file name per
line.
@smallexample @c @projectfile
project Work extends "../bld/build.gpr" is
for Source_Files use ("pack.ads");
-- New spec of Pkg does not need a completion
for Excluded_Source_Files use ("pack.adb");
end Work;
@end smallexample
@noindent
All packages that are not declared in the extending project are inherited from
the project being extended, with their attributes, with the exception of
@code{Linker'Linker_Options} which is never inherited. In particular, an
extending project retains all the switches specified in the project being
extended.
At the project level, if they are not declared in the extending project, some
attributes are inherited from the project being extended. They are:
@code{Languages}, @code{Main} (for a root non library project) and
@code{Library_Name} (for a project extending a library project)
@menu
* Project Hierarchy Extension::
@end menu
@c ---------------------------------------------
@node Project Hierarchy Extension
@subsection Project Hierarchy Extension
@c ---------------------------------------------
@noindent
One of the fundamental restrictions in project extension is the following:
@b{A project is not allowed to import directly or indirectly at the same time an
extending project and one of its ancestors}.
By means of example, consider the following hierarchy of projects.
@smallexample
a.gpr contains package A1
b.gpr, imports a.gpr and contains B1, which depends on A1
c.gpr, imports b.gpr and contains C1, which depends on B1
@end smallexample
@noindent
If we want to locally extend the packages @code{A1} and @code{C1}, we need to
create several extending projects:
@smallexample
a_ext.gpr which extends a.gpr, and overrides A1
b_ext.gpr which extends b.gpr and imports a_ext.gpr
c_ext.gpr which extends c.gpr, imports b_ext.gpr and overrides C1
@end smallexample
@noindent
@smallexample @c projectfile
project A_Ext extends "a.gpr" is
for Source_Files use ("a1.adb", "a1.ads");
end A_Ext;
with "a_ext.gpr";
project B_Ext extends "b.gpr" is
end B_Ext;
with "b_ext.gpr";
project C_Ext extends "c.gpr" is
for Source_Files use ("c1.adb");
end C_Ext;
@end smallexample
@noindent
The extension @file{b_ext.gpr} is required, even though we are not overriding
any of the sources of @file{b.gpr} because otherwise @file{c_expr.gpr} would
import @file{b.gpr} which itself knows nothing about @file{a_ext.gpr}.
@cindex extends all
When extending a large system spanning multiple projects, it is often
inconvenient to extend every project in the hierarchy that is impacted by a
small change introduced in a low layer. In such cases, it is possible to create
an @b{implicit extension} of entire hierarchy using @b{extends all}
relationship.
When the project is extended using @code{extends all} inheritance, all projects
that are imported by it, both directly and indirectly, are considered virtually
extended. That is, the project manager creates implicit projects
that extend every project in the hierarchy; all these implicit projects do not
control sources on their own and use the object directory of
the "extending all" project.
It is possible to explicitly extend one or more projects in the hierarchy
in order to modify the sources. These extending projects must be imported by
the "extending all" project, which will replace the corresponding virtual
projects with the explicit ones.
When building such a project hierarchy extension, the project manager will
ensure that both modified sources and sources in implicit extending projects
that depend on them, are recompiled.
Thus, in our example we could create the following projects instead:
@smallexample
a_ext.gpr, extends a.gpr and overrides A1
c_ext.gpr, "extends all" c.gpr, imports a_ext.gpr and overrides C1
@end smallexample
@noindent
@smallexample @c projectfile
project A_Ext extends "a.gpr" is
for Source_Files use ("a1.adb", "a1.ads");
end A_Ext;
with "a_ext.gpr";
project C_Ext extends all "c.gpr" is
for Source_Files use ("c1.adb");
end C_Ext;
@end smallexample
@noindent
When building project @file{c_ext.gpr}, the entire modified project space is
considered for recompilation, including the sources of @file{b.gpr} that are
impacted by the changes in @code{A1} and @code{C1}.
@c ---------------------------------------------
@node Aggregate Projects
@section Aggregate Projects
@c ---------------------------------------------
@noindent
Aggregate projects are an extension of the project paradigm, and are
meant to solve a few specific use cases that cannot be solved directly
using standard projects. This section will go over a few of these use
cases to try to explain what you can use aggregate projects for.
@menu
* Building all main programs from a single project tree::
* Building a set of projects with a single command::
* Define a build environment::
* Performance improvements in builder::
* Syntax of aggregate projects::
* package Builder in aggregate projects::
@end menu
@c -----------------------------------------------------------
@node Building all main programs from a single project tree
@subsection Building all main programs from a single project tree
@c -----------------------------------------------------------
Most often, an application is organized into modules and submodules,
which are very conveniently represented as a project tree or graph
(the root project A @code{with}s the projects for each modules (say B and C),
which in turn @code{with} projects for submodules.
Very often, modules will build their own executables (for testing
purposes for instance), or libraries (for easier reuse in various
contexts).
However, if you build your project through @command{gnatmake} or
@command{gprbuild}, using a syntax similar to
@smallexample
gprbuild -PA.gpr
@end smallexample
this will only rebuild the main programs of project A, not those of the
imported projects B and C. Therefore you have to spawn several
@command{gnatmake} commands, one per project, to build all executables.
This is a little inconvenient, but more importantly is inefficient
because @command{gnatmake} needs to do duplicate work to ensure that sources are
up-to-date, and cannot easily compile things in parallel when using
the -j switch.
Also libraries are always rebuilt when building a project.
You could therefore define an aggregate project Agg that groups A, B
and C. Then, when you build with
@smallexample
gprbuild -PAgg.gpr
@end smallexample
this will build all mains from A, B and C.
@smallexample @c projectfile
aggregate project Agg is
for Project_Files use ("a.gpr", "b.gpr", "c.gpr");
end Agg;
@end smallexample
If B or C do not define any main program (through their Main
attribute), all their sources are built. When you do not group them
in the aggregate project, only those sources that are needed by A
will be built.
If you add a main to a project P not already explicitly referenced in the
aggregate project, you will need to add "p.gpr" in the list of project
files for the aggregate project, or the main will not be built when
building the aggregate project.
Aggregate projects are only supported with @command{gprbuild}, but not with
@command{gnatmake}.
@c ---------------------------------------------------------
@node Building a set of projects with a single command
@subsection Building a set of projects with a single command
@c ---------------------------------------------------------
One other case is when you have multiple applications and libraries
that are built independently from each other (but can be built in
parallel). For instance, you have a project tree rooted at A, and
another one (which might share some subprojects) rooted at B.
Using only @command{gprbuild}, you could do
@smallexample
gprbuild -PA.gpr
gprbuild -PB.gpr
@end smallexample
to build both. But again, @command{gprbuild} has to do some duplicate work for
those files that are shared between the two, and cannot truly build
things in parallel efficiently.
If the two projects are really independent, share no sources other
than through a common subproject, and have no source files with a
common basename, you could create a project C that imports A and
B. But these restrictions are often too strong, and one has to build
them independently. An aggregate project does not have these
limitations and can aggregate two project trees that have common
sources.
This scenario is particularly useful in environments like VxWorks 653
where the applications running in the multiple partitions can be built
in parallel through a single @command{gprbuild} command. This also works nicely
with Annex E.
@c ---------------------------------------------
@node Define a build environment
@subsection Define a build environment
@c ---------------------------------------------
The environment variables at the time you launch @command{gprbuild}
will influence the view these tools have of the project
(PATH to find the compiler, ADA_PROJECT_PATH or GPR_PROJECT_PATH to find the
projects, environment variables that are referenced in project files
through the "external" statement,...). Several command line switches
can be used to override those (-X or -aP), but on some systems and
with some projects, this might make the command line too long, and on
all systems often make it hard to read.
An aggregate project can be used to set the environment for all
projects built through that aggregate. One of the nice aspects is that
you can put the aggregate project under configuration management, and
make sure all your user have a consistent environment when
building. The syntax looks like
@smallexample @c projectfile
aggregate project Agg is
for Project_Files use ("A.gpr", "B.gpr");
for Project_Path use ("../dir1", "../dir1/dir2");
for External ("BUILD") use "PRODUCTION";
package Builder is
for ^Switches^Switches^ ("Ada") use ("-q");
end Builder;
end Agg;
@end smallexample
One of the often requested features in projects is to be able to
reference external variables in @code{with} statements, as in
@smallexample @c projectfile
with external("SETUP") & "path/prj.gpr"; -- ILLEGAL
project MyProject is
...
end MyProject;
@end smallexample
For various reasons, this isn't authorized. But using aggregate
projects provide an elegant solution. For instance, you could
use a project file like:
@smallexample @c projectfile
aggregate project Agg is
for Project_Path use (external("SETUP") & "path");
for Project_Files use ("myproject.gpr");
end Agg;
with "prj.gpr"; -- searched on Agg'Project_Path
project MyProject is
...
end MyProject;
@end smallexample
@c --------------------------------------------
@node Performance improvements in builder
@subsection Performance improvements in builder
@c --------------------------------------------
The loading of aggregate projects is optimized in @command{gprbuild},
so that all files are searched for only once on the disk
(thus reducing the number of system calls and contributing to faster
compilation times especially on systems with sources on remote
servers). As part of the loading, @command{gprbuild}
computes how and where a source file should be compiled, and even if it is
found several times in the aggregated projects it will be compiled only
once.
Since there is no ambiguity as to which switches should be used, files
can be compiled in parallel (through the usual -j switch) and this can
be done while maximizing the use of CPUs (compared to launching
multiple @command{gprbuild} and @command{gnatmake} commands in parallel).
@c -------------------------------------
@node Syntax of aggregate projects
@subsection Syntax of aggregate projects
@c -------------------------------------
An aggregate project follows the general syntax of project files. The
recommended extension is still @file{.gpr}. However, a special
@code{aggregate} qualifier must be put before the keyword
@code{project}.
An aggregate project cannot @code{with} any other project (standard or
aggregate), except an abstract project which can be used to share attribute
values. Also, aggregate projects cannot be extended or imported though a
@code{with} clause by any other project. Building other aggregate projects from
an aggregate project is done through the Project_Files attribute (see below).
An aggregate project does not have any source files directly (only
through other standard projects). Therefore a number of the standard
attributes and packages are forbidden in an aggregate project. Here is the
(non exhaustive) list:
@itemize @bullet
@item Languages
@item Source_Files, Source_List_File and other attributes dealing with
list of sources.
@item Source_Dirs, Exec_Dir and Object_Dir
@item Library_Dir, Library_Name and other library-related attributes
@item Main
@item Roots
@item Externally_Built
@item Inherit_Source_Path
@item Excluded_Source_Dirs
@item Locally_Removed_Files
@item Excluded_Source_Files
@item Excluded_Source_List_File
@item Interfaces
@end itemize
The only package that is authorized (albeit optional) is
Builder. Other packages (in particular Compiler, Binder and Linker)
are forbidden. It is an error to have any of these
(and such an error prevents the proper loading of the aggregate
project).
Three new attributes have been created, which can only be used in the
context of aggregate projects:
@table @asis
@item @b{Project_Files}:
@cindex @code{Project_Files}
This attribute is compulsory (or else we are not aggregating any project,
and thus not doing anything). It specifies a list of @file{.gpr} files
that are grouped in the aggregate. The list may be empty. The project
files can be either other aggregate projects, or standard projects. When
grouping standard projects, you can have both the root of a project tree
(and you do not need to specify all its imported projects), and any project
within the tree.
Basically, the idea is to specify all those projects that have
main programs you want to build and link, or libraries you want to
build. You can even specify projects that do not use the Main
attribute nor the @code{Library_*} attributes, and the result will be to
build all their source files (not just the ones needed by other
projects).
The file can include paths (absolute or relative). Paths are relative to
the location of the aggregate project file itself (if you use a base name,
we expect to find the .gpr file in the same directory as the aggregate
project file). The environment variables @code{ADA_PROJECT_PATH},
@code{GPR_PROJECT_PATH} and @code{GPR_PROJECT_PATH_FILE} are not used to find
the project files. The extension @file{.gpr} is mandatory, since this attribute
contains file names, not project names.
Paths can also include the @code{"*"} and @code{"**"} globbing patterns. The
latter indicates that any subdirectory (recursively) will be
searched for matching files. The latter (@code{"**"}) can only occur at the
last position in the directory part (ie @code{"a/**/*.gpr"} is supported, but
not @code{"**/a/*.gpr"}). Starting the pattern with @code{"**"} is equivalent
to starting with @code{"./**"}.
For now, the pattern @code{"*"} is only allowed in the filename part, not
in the directory part. This is mostly for efficiency reasons to limit the
number of system calls that are needed.
Here are a few valid examples:
@smallexample @c projectfile
for Project_Files use ("a.gpr", "subdir/b.gpr");
-- two specific projects relative to the directory of agg.gpr
for Project_Files use ("**/*.gpr");
-- all projects recursively
@end smallexample
@item @b{Project_Path}:
@cindex @code{Project_Path}
This attribute can be used to specify a list of directories in
which to look for project files in @code{with} statements.
When you specify a project in Project_Files
say @code{"x/y/a.gpr"}), and this projects imports a project "b.gpr", only
b.gpr is searched in the project path. a.gpr must be exactly at
/x/y/a.gpr.
This attribute, however, does not affect the search for the aggregated
project files specified with @code{Project_Files}.
Each aggregate project has its own (that is if agg1.gpr includes
agg2.gpr, they can potentially both have a different project path).
This project path is defined as the concatenation, in that order, of:
@itemize @bullet
@item the current directory;
@item followed by the command line -aP switches;
@item then the directories from the GPR_PROJECT_PATH and ADA_PROJECT_PATH environment
variables;
@item then the directories from the Project_Path attribute;
@item and finally the predefined directories.
@end itemize
In the example above, agg2.gpr's project path is not influenced by
the attribute agg1'Project_Path, nor is agg1 influenced by
agg2'Project_Path.
This can potentially lead to errors. In the following example:
@smallexample
+---------------+ +----------------+
| Agg1.gpr |-=--includes--=-->| Agg2.gpr |
| 'project_path| | 'project_path |
| | | |
+---------------+ +----------------+
: :
includes includes
: :
v v
+-------+ +---------+
| P.gpr |<---------- withs --------| Q.gpr |
+-------+---------\ +---------+
| |
withs |
| |
v v
+-------+ +---------+
| R.gpr | | R'.gpr |
+-------+ +---------+
@end smallexample
When looking for p.gpr, both aggregates find the same physical file on
the disk. However, it might happen that with their different project
paths, both aggregate projects would in fact find a different r.gpr.
Since we have a common project (p.gpr) "with"ing two different r.gpr,
this will be reported as an error by the builder.
Directories are relative to the location of the aggregate project file.
Here are a few valid examples:
@smallexample @c projectfile
for Project_Path use ("/usr/local/gpr", "gpr/");
@end smallexample
@item @b{External}:
@cindex @code{External}
This attribute can be used to set the value of environment
variables as retrieved through the @code{external} statement
in projects. It does not affect the environment variables
themselves (so for instance you cannot use it to change the value
of your PATH as seen from the spawned compiler).
This attribute affects the external values as seen in the rest of
the aggreate projects, and in the aggregated projects.
The exact value of external a variable comes from one of three
sources (each level overrides the previous levels):
@itemize @bullet
@item An External attribute in aggregate project, for instance
@code{for External ("BUILD_MODE") use "DEBUG"};
@item Environment variables
These override the value given by the attribute, so that
users can override the value set in the (presumably shared
with others in his team) aggregate project.
@item The -X command line switch to @command{gprbuild}
This always takes precedence.
@end itemize
This attribute is only taken into account in the main aggregate
project (i.e. the one specified on the command line to @command{gprbuild}),
and ignored in other aggregate projects. It is invalid
in standard projects.
The goal is to have a consistent value in all
projects that are built through the aggregate, which would not
be the case in the diamond case: A groups the aggregate
projects B and C, which both (either directly or indirectly)
build the project P. If B and C could set different values for
the environment variables, we would have two different views of
P, which in particular might impact the list of source files in P.
@end table
@c ----------------------------------------------
@node package Builder in aggregate projects
@subsection package Builder in aggregate projects
@c ----------------------------------------------
As we mentioned before, only the package Builder can be specified in
an aggregate project. In this package, only the following attributes
are valid:
@table @asis
@item @b{^Switches^Switches^}:
@cindex @code{^Switches^Switches^}
This attribute gives the list of switches to use for @command{gprbuild}.
Because no mains can be specified for aggregate projects, the only possible
index for attribute @code{Switches} is @code{others}. All other indexes will
be ignored.
Example:
@smallexample @c projectfile
for ^Switches^Switches^ (other) use ("-v", "-k", "-j8");
@end smallexample
These switches are only read from the main aggregate project (the
one passed on the command line), and ignored in all other aggregate
projects or projects.
It can only contain builder switches, not compiler switches.
@item @b{Global_Compilation_Switches}
@cindex @code{Global_Compilation_Switches}
This attribute gives the list of compiler switches for the various
languages. For instance,
@smallexample @c projectfile
for Global_Compilation_Switches ("Ada") use ("^O1^-O1^", "-g");
for Global_Compilation_Switches ("C") use ("^-O2^-O2^");
@end smallexample
This attribute is only taken into account in the aggregate project
specified on the command line, not in other aggregate projects.
In the projects grouped by that aggregate, the attribute
Builder.Global_Compilation_Switches is also ignored. However, the
attribute Compiler.Default_Switches will be taken into account (but
that of the aggregate have higher priority). The attribute
Compiler.Switches is also taken into account and can be used to
override the switches for a specific file. As a result, it always
has priority.
The rules are meant to avoid ambiguities when compiling. For
instance, aggregate project Agg groups the projects A and B, that
both depend on C. Here is an extra for all of these projects:
@smallexample @c projectfile
aggregate project Agg is
for Project_Files use ("a.gpr", "b.gpr");
package Builder is
for Global_Compilation_Switches ("Ada") use ("^-O2^-O2^");
end Builder;
end Agg;
with "c.gpr";
project A is
package Builder is
for Global_Compilation_Switches ("Ada") use ("^-O1^-O1^");
-- ignored
end Builder;
package Compiler is
for Default_Switches ("Ada")
use ("^-O1^-O1^", "-g");
for ^Switches^Switches^ ("a_file1.adb")
use ("^-O0^-O0^");
end Compiler;
end A;
with "c.gpr";
project B is
package Compiler is
for Default_Switches ("Ada") use ("^-O0^-O0^");
end Compiler;
end B;
project C is
package Compiler is
for Default_Switches ("Ada")
use ("^-O3^-O3^",
"^-gnatn^-gnatn^");
for ^Switches^Switches^ ("c_file1.adb")
use ("^-O0^-O0^", "-g");
end Compiler;
end C;
@end smallexample
then the following switches are used:
@itemize @bullet
@item all files from project A except a_file1.adb are compiled
with "^-O2^-O2^ -g", since the aggregate project has priority.
@item the file a_file1.adb is compiled with
"^-O0^-O0^", since the Compiler.Switches has priority
@item all files from project B are compiled with
"^-O2^-O2^", since the aggregate project has priority
@item all files from C are compiled with "^-O2^-O2^ -gnatn", except for
c_file1.adb which is compiled with "^-O0^-O0^ -g"
@end itemize
Even though C is seen through two paths (through A and through
B), the switches used by the compiler are unambiguous.
@item @b{Global_Configuration_Pragmas}
@cindex @code{Global_Configuration_Pragmas}
This attribute can be used to specify a file containing
configuration pragmas, to be passed to the Ada compiler. Since we
ignore the package Builder in other aggregate projects and projects,
only those pragmas defined in the main aggregate project will be
taken into account.
Projects can locally add to those by using the
@code{Compiler.Local_Configuration_Pragmas} attribute if they need.
@item @b{Global_Config_File}
@cindex @code{Global_Config_File}
This attribute, indexed with a language name, can be used to specify a config
when compiling sources of the language. For Ada, these files are configuration
pragmas files.
@end table
For projects that are built through the aggregate, the package Builder
is ignored, except for the Executable attribute which specifies the
name of the executables resulting from the link of the main programs, and
for the Executable_Suffix.
@c ---------------------------------------------
@node Aggregate Library Projects
@section Aggregate Library Projects
@c ---------------------------------------------
@noindent
Aggregate library projects make it possible to build a single library
using object files built using other standard or library
projects. This gives the flexibility to describe an application as
having multiple modules (a GUI, database access, ...) using different
project files (so possibly built with different compiler options) and
yet create a single library (static or relocatable) out of the
corresponding object files.
@menu
* Building aggregate library projects::
* Syntax of aggregate library projects::
@end menu
@c ---------------------------------------------
@node Building aggregate library projects
@subsection Building aggregate library projects
@c ---------------------------------------------
For example, we can define an aggregate project Agg that groups A, B
and C:
@smallexample @c projectfile
aggregate library project Agg is
for Project_Files use ("a.gpr", "b.gpr", "c.gpr");
for Library_Name use ("agg");
for Library_Dir use ("lagg");
end Agg;
@end smallexample
Then, when you build with:
@smallexample
gprbuild agg.gpr
@end smallexample
This will build all units from projects A, B and C and will create a
static library named @file{libagg.a} into the @file{lagg}
directory. An aggregate library project has the same set of
restriction as a standard library project.
Note that a shared aggregate library project cannot aggregates a
static library project. In platforms where a compiler option is
required to create relocatable object files, a Builder package in the
aggregate library project may be used:
@smallexample @c projectfile
aggregate library project Agg is
for Project_Files use ("a.gpr", "b.gpr", "c.gpr");
for Library_Name use ("agg");
for Library_Dir use ("lagg");
for Library_Kind use "relocatable";
package Builder is
for Global_Compilation_Switches ("Ada") use ("-fPIC");
end Builder;
end Agg;
@end smallexample
With the above aggregate library Builder package, the @code{-fPIC}
option will be passed to the compiler when building any source code
from projects @file{a.gpr}, @file{b.gpr} and @file{c.gpr}.
@c ---------------------------------------------
@node Syntax of aggregate library projects
@subsection Syntax of aggregate library projects
@c ---------------------------------------------
An aggregate library project follows the general syntax of project
files. The recommended extension is still @file{.gpr}. However, a special
@code{aggregate library} qualifier must be put before the keyword
@code{project}.
An aggregate library project cannot @code{with} any other project
(standard or aggregate), except an abstract project which can be used
to share attribute values.
An aggregate library project does not have any source files directly (only
through other standard projects). Therefore a number of the standard
attributes and packages are forbidden in an aggregate library
project. Here is the (non exhaustive) list:
@itemize @bullet
@item Languages
@item Source_Files, Source_List_File and other attributes dealing with
list of sources.
@item Source_Dirs, Exec_Dir and Object_Dir
@item Main
@item Roots
@item Externally_Built
@item Inherit_Source_Path
@item Excluded_Source_Dirs
@item Locally_Removed_Files
@item Excluded_Source_Files
@item Excluded_Source_List_File
@item Interfaces
@end itemize
The only package that is authorized (albeit optional) is Builder.
The Project_Files attribute (See @pxref{Aggregate Projects}) is used to
described the aggregated projects whose object files have to be
included into the aggregate library. The environment variables
@code{ADA_PROJECT_PATH}, @code{GPR_PROJECT_PATH} and
@code{GPR_PROJECT_PATH_FILE} are not used to find the project files.
@c ---------------------------------------------
@node Project File Reference
@section Project File Reference
@c ---------------------------------------------
@noindent
This section describes the syntactic structure of project files, the various
constructs that can be used. Finally, it ends with a summary of all available
attributes.
@menu
* Project Declaration::
* Qualified Projects::
* Declarations::
* Packages::
* Expressions::
* External Values::
* Typed String Declaration::
* Variables::
* Case Constructions::
* Attributes::
@end menu
@c ---------------------------------------------
@node Project Declaration
@subsection Project Declaration
@c ---------------------------------------------
@noindent
Project files have an Ada-like syntax. The minimal project file is:
@smallexample @c projectfile
@group
project Empty is
end Empty;
@end group
@end smallexample
@noindent
The identifier @code{Empty} is the name of the project.
This project name must be present after the reserved
word @code{end} at the end of the project file, followed by a semi-colon.
@b{Identifiers} (i.e.@: the user-defined names such as project or variable names)
have the same syntax as Ada identifiers: they must start with a letter,
and be followed by zero or more letters, digits or underscore characters;
it is also illegal to have two underscores next to each other. Identifiers
are always case-insensitive ("Name" is the same as "name").
@smallexample
simple_name ::= identifier
name ::= simple_name @{ . simple_name @}
@end smallexample
@noindent
@b{Strings} are used for values of attributes or as indexes for these
attributes. They are in general case sensitive, except when noted
otherwise (in particular, strings representing file names will be case
insensitive on some systems, so that "file.adb" and "File.adb" both
represent the same file).
@b{Reserved words} are the same as for standard Ada 95, and cannot
be used for identifiers. In particular, the following words are currently
used in project files, but others could be added later on. In bold are the
extra reserved words in project files: @code{all, at, case, end, for, is,
limited, null, others, package, renames, type, use, when, with, @b{extends},
@b{external}, @b{project}}.
@b{Comments} in project files have the same syntax as in Ada, two consecutive
hyphens through the end of the line.
A project may be an @b{independent project}, entirely defined by a single
project file. Any source file in an independent project depends only
on the predefined library and other source files in the same project.
But a project may also depend on other projects, either by importing them
through @b{with clauses}, or by @b{extending} at most one other project. Both
types of dependency can be used in the same project.
A path name denotes a project file. It can be absolute or relative.
An absolute path name includes a sequence of directories, in the syntax of
the host operating system, that identifies uniquely the project file in the
file system. A relative path name identifies the project file, relative
to the directory that contains the current project, or relative to a
directory listed in the environment variables ADA_PROJECT_PATH and
GPR_PROJECT_PATH. Path names are case sensitive if file names in the host
operating system are case sensitive. As a special case, the directory
separator can always be "/" even on Windows systems, so that project files
can be made portable across architectures.
The syntax of the environment variable ADA_PROJECT_PATH and
GPR_PROJECT_PATH is a list of directory names separated by colons on UNIX and
semicolons on Windows.
A given project name can appear only once in a context clause.
It is illegal for a project imported by a context clause to refer, directly
or indirectly, to the project in which this context clause appears (the
dependency graph cannot contain cycles), except when one of the with clause
in the cycle is a @b{limited with}.
@c ??? Need more details here
@smallexample @c projectfile
with "other_project.gpr";
project My_Project extends "extended.gpr" is
end My_Project;
@end smallexample
@noindent
These dependencies form a @b{directed graph}, potentially cyclic when using
@b{limited with}. The subprogram reflecting the @b{extends} relations is a
tree.
A project's @b{immediate sources} are the source files directly defined by
that project, either implicitly by residing in the project source directories,
or explicitly through any of the source-related attributes.
More generally, a project sources are the immediate sources of the project
together with the immediate sources (unless overridden) of any
project on which it depends directly or indirectly.
A @b{project hierarchy} can be created, where projects are children of
other projects. The name of such a child project must be @code{Parent.Child},
where @code{Parent} is the name of the parent project. In particular, this
makes all @code{with} clauses of the parent project automatically visible
in the child project.
@smallexample
project ::= context_clause project_declaration
context_clause ::= @{with_clause@}
with_clause ::= @i{with} path_name @{ , path_name @} ;
path_name ::= string_literal
project_declaration ::= simple_project_declaration | project_extension
simple_project_declaration ::=
@i{project} @i{}name @i{is}
@{declarative_item@}
@i{end} simple_name;
@end smallexample
@c ---------------------------------------------
@node Qualified Projects
@subsection Qualified Projects
@c ---------------------------------------------
@noindent
Before the reserved @code{project}, there may be one or two @b{qualifiers}, that
is identifiers or reserved words, to qualify the project.
The current list of qualifiers is:
@table @asis
@item @b{abstract}: qualifies a project with no sources. Such a
project must either have no declaration of attributes @code{Source_Dirs},
@code{Source_Files}, @code{Languages} or @code{Source_List_File}, or one of
@code{Source_Dirs}, @code{Source_Files}, or @code{Languages} must be declared
as empty. If it extends another project, the project it extends must also be a
qualified abstract project.
@item @b{standard}: a standard project is a non library project with sources.
This is the default (implicit) qualifier.
@item @b{aggregate}: a project whose sources are aggregated from other
project files.
@item @b{aggregate library}: a library whose sources are aggregated
from other project or library project files.
@item @b{library}: a library project must declare both attributes
@code{Library_Name} and @code{Library_Dir}.
@item @b{configuration}: a configuration project cannot be in a project tree.
It describes compilers and other tools to @command{gprbuild}.
@end table
@c ---------------------------------------------
@node Declarations
@subsection Declarations
@c ---------------------------------------------
@noindent
Declarations introduce new entities that denote types, variables, attributes,
and packages. Some declarations can only appear immediately within a project
declaration. Others can appear within a project or within a package.
@smallexample
declarative_item ::= simple_declarative_item
| typed_string_declaration
| package_declaration
simple_declarative_item ::= variable_declaration
| typed_variable_declaration
| attribute_declaration
| case_construction
| empty_declaration
empty_declaration ::= @i{null} ;
@end smallexample
@noindent
An empty declaration is allowed anywhere a declaration is allowed. It has
no effect.
@c ---------------------------------------------
@node Packages
@subsection Packages
@c ---------------------------------------------
@noindent
A project file may contain @b{packages}, that group attributes (typically
all the attributes that are used by one of the GNAT tools).
A package with a given name may only appear once in a project file.
The following packages are currently supported in project files
(See @pxref{Attributes} for the list of attributes that each can contain).
@table @code
@item Binder
This package specifies characteristics useful when invoking the binder either
directly via the @command{gnat} driver or when using a builder such as
@command{gnatmake} or @command{gprbuild}. @xref{Main Subprograms}.
@item Builder
This package specifies the compilation options used when building an
executable or a library for a project. Most of the options should be
set in one of @code{Compiler}, @code{Binder} or @code{Linker} packages,
but there are some general options that should be defined in this
package. @xref{Main Subprograms}, and @pxref{Executable File Names} in
particular.
@ifclear FSFEDITION
@item Check
This package specifies the options used when calling the checking tool
@command{gnatcheck} via the @command{gnat} driver. Its attribute
@b{Default_Switches} has the same semantics as for the package
@code{Builder}. The first string should always be @code{-rules} to specify
that all the other options belong to the @code{-rules} section of the
parameters to @command{gnatcheck}.
@end ifclear
@item Clean
This package specifies the options used when cleaning a project or a project
tree using the tools @command{gnatclean} or @command{gprclean}.
@item Compiler
This package specifies the compilation options used by the compiler for
each languages. @xref{Tools Options in Project Files}.
@item Cross_Reference
This package specifies the options used when calling the library tool
@command{gnatxref} via the @command{gnat} driver. Its attributes
@b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the
package @code{Builder}.
@ifclear FSFEDITION
@item Eliminate
This package specifies the options used when calling the tool
@command{gnatelim} via the @command{gnat} driver. Its attributes
@b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the
package @code{Builder}.
@end ifclear
@item Finder
This package specifies the options used when calling the search tool
@command{gnatfind} via the @command{gnat} driver. Its attributes
@b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the
package @code{Builder}.
@item ^Gnatls^Gnatls^
This package specifies the options to use when invoking @command{gnatls}
via the @command{gnat} driver.
@ifclear FSFEDITION
@item ^Gnatstub^Gnatstub^
This package specifies the options used when calling the tool
@command{gnatstub} via the @command{gnat} driver. Its attributes
@b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the
package @code{Builder}.
@end ifclear
@item IDE
This package specifies the options used when starting an integrated
development environment, for instance @command{GPS} or @command{Gnatbench}.
@item Install
This package specifies the options used when installing a project
with @command{gprinstall}. @xref{Installation}.
@item Linker
This package specifies the options used by the linker.
@xref{Main Subprograms}.
@ifclear FSFEDITION
@item Metrics
This package specifies the options used when calling the tool
@command{gnatmetric} via the @command{gnat} driver. Its attributes
@b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the
package @code{Builder}.
@end ifclear
@item Naming
This package specifies the naming conventions that apply
to the source files in a project. In particular, these conventions are
used to automatically find all source files in the source directories,
or given a file name to find out its language for proper processing.
@xref{Naming Schemes}.
@ifclear FSFEDITION
@item Pretty_Printer
This package specifies the options used when calling the formatting tool
@command{gnatpp} via the @command{gnat} driver. Its attributes
@b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the
package @code{Builder}.
@end ifclear
@item Remote
This package is used by @command{gprbuild} to describe how distributed
compilation should be done.
@item Stack
This package specifies the options used when calling the tool
@command{gnatstack} via the @command{gnat} driver. Its attributes
@b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the
package @code{Builder}.
@item Synchronize
This package specifies the options used when calling the tool
@command{gnatsync} via the @command{gnat} driver.
@end table
In its simplest form, a package may be empty:
@smallexample @c projectfile
@group
project Simple is
package Builder is
end Builder;
end Simple;
@end group
@end smallexample
@noindent
A package may contain @b{attribute declarations},
@b{variable declarations} and @b{case constructions}, as will be
described below.
When there is ambiguity between a project name and a package name,
the name always designates the project. To avoid possible confusion, it is
always a good idea to avoid naming a project with one of the
names allowed for packages or any name that starts with @code{gnat}.
A package can also be defined by a @b{renaming declaration}. The new package
renames a package declared in a different project file, and has the same
attributes as the package it renames. The name of the renamed package
must be the same as the name of the renaming package. The project must
contain a package declaration with this name, and the project
must appear in the context clause of the current project, or be its parent
project. It is not possible to add or override attributes to the renaming
project. If you need to do so, you should use an @b{extending declaration}
(see below).
Packages that are renamed in other project files often come from project files
that have no sources: they are just used as templates. Any modification in the
template will be reflected automatically in all the project files that rename
a package from the template. This is a very common way to share settings
between projects.
Finally, a package can also be defined by an @b{extending declaration}. This is
similar to a @b{renaming declaration}, except that it is possible to add or
override attributes.
@smallexample
package_declaration ::= package_spec | package_renaming | package_extension
package_spec ::=
@i{package} @i{}simple_name @i{is}
@{simple_declarative_item@}
@i{end} package_identifier ;
package_renaming ::==
@i{package} @i{}simple_name @i{renames} @i{}simple_name.package_identifier ;
package_extension ::==
@i{package} @i{}simple_name @i{extends} @i{}simple_name.package_identifier @i{is}
@{simple_declarative_item@}
@i{end} package_identifier ;
@end smallexample
@c ---------------------------------------------
@node Expressions
@subsection Expressions
@c ---------------------------------------------
@noindent
An expression is any value that can be assigned to an attribute or a
variable. It is either a literal value, or a construct requiring runtime
computation by the project manager. In a project file, the computed value of
an expression is either a string or a list of strings.
A string value is one of:
@itemize @bullet
@item A literal string, for instance @code{"comm/my_proj.gpr"}
@item The name of a variable that evaluates to a string (@pxref{Variables})
@item The name of an attribute that evaluates to a string (@pxref{Attributes})
@item An external reference (@pxref{External Values})
@item A concatenation of the above, as in @code{"prefix_" & Var}.
@end itemize
@noindent
A list of strings is one of the following:
@itemize @bullet
@item A parenthesized comma-separated list of zero or more string expressions, for
instance @code{(File_Name, "gnat.adc", File_Name & ".orig")} or @code{()}.
@item The name of a variable that evaluates to a list of strings
@item The name of an attribute that evaluates to a list of strings
@item A concatenation of a list of strings and a string (as defined above), for
instance @code{("A", "B") & "C"}
@item A concatenation of two lists of strings
@end itemize
@noindent
The following is the grammar for expressions
@smallexample
string_literal ::= "@{string_element@}" -- Same as Ada
string_expression ::= string_literal
| @i{variable_}name
| external_value
| attribute_reference
| ( string_expression @{ & string_expression @} )
string_list ::= ( string_expression @{ , string_expression @} )
| @i{string_variable}_name
| @i{string_}attribute_reference
term ::= string_expression | string_list
expression ::= term @{ & term @} -- Concatenation
@end smallexample
@noindent
Concatenation involves strings and list of strings. As soon as a list of
strings is involved, the result of the concatenation is a list of strings. The
following Ada declarations show the existing operators:
@smallexample @c ada
function "&" (X : String; Y : String) return String;
function "&" (X : String_List; Y : String) return String_List;
function "&" (X : String_List; Y : String_List) return String_List;
@end smallexample
@noindent
Here are some specific examples:
@smallexample @c projectfile
@group
List := () & File_Name; -- One string in this list
List2 := List & (File_Name & ".orig"); -- Two strings
Big_List := List & Lists2; -- Three strings
Illegal := "gnat.adc" & List2; -- Illegal, must start with list
@end group
@end smallexample
@c ---------------------------------------------
@node External Values
@subsection External Values
@c ---------------------------------------------
@noindent
An external value is an expression whose value is obtained from the command
that invoked the processing of the current project file (typically a
@command{gnatmake} or @command{gprbuild} command).
There are two kinds of external values, one that returns a single string, and
one that returns a string list.
The syntax of a single string external value is:
@smallexample
external_value ::= @i{external} ( string_literal [, string_literal] )
@end smallexample
@noindent
The first string_literal is the string to be used on the command line or
in the environment to specify the external value. The second string_literal,
if present, is the default to use if there is no specification for this
external value either on the command line or in the environment.
Typically, the external value will either exist in the
^environment variables^logical name^
or be specified on the command line through the
@option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}} switch. If both
are specified, then the command line value is used, so that a user can more
easily override the value.
The function @code{external} always returns a string. It is an error if the
value was not found in the environment and no default was specified in the
call to @code{external}.
An external reference may be part of a string expression or of a string
list expression, and can therefore appear in a variable declaration or
an attribute declaration.
Most of the time, this construct is used to initialize typed variables, which
are then used in @b{case} statements to control the value assigned to
attributes in various scenarios. Thus such variables are often called
@b{scenario variables}.
The syntax for a string list external value is:
@smallexample
external_value ::= @i{external_as_list} ( string_literal , string_literal )
@end smallexample
@noindent
The first string_literal is the string to be used on the command line or
in the environment to specify the external value. The second string_literal is
the separator between each component of the string list.
If the external value does not exist in the environment or on the command line,
the result is an empty list. This is also the case, if the separator is an
empty string or if the external value is only one separator.
Any separator at the beginning or at the end of the external value is
discarded. Then, if there is no separator in the external value, the result is
a string list with only one string. Otherwise, any string between the beginning
and the first separator, between two consecutive separators and between the
last separator and the end are components of the string list.
@smallexample
@i{external_as_list} ("SWITCHES", ",")
@end smallexample
@noindent
If the external value is "^-O2^-O2^,-g",
the result is ("^-O2^-O2^", "-g").
If the external value is ",^-O2^-O2^,-g,",
the result is also ("^-O2^-O2^", "-g").
if the external value is "^-gnatv^-gnatv^",
the result is ("^-gnatv^-gnatv^").
If the external value is ",,", the result is ("").
If the external value is ",", the result is (), the empty string list.
@c ---------------------------------------------
@node Typed String Declaration
@subsection Typed String Declaration
@c ---------------------------------------------
@noindent
A @b{type declaration} introduces a discrete set of string literals.
If a string variable is declared to have this type, its value
is restricted to the given set of literals. These are the only named
types in project files. A string type may only be declared at the project
level, not inside a package.
@smallexample
typed_string_declaration ::=
@i{type} @i{}_simple_name @i{is} ( string_literal @{, string_literal@} );
@end smallexample
@noindent
The string literals in the list are case sensitive and must all be different.
They may include any graphic characters allowed in Ada, including spaces.
Here is an example of a string type declaration:
@smallexample @c projectfile
type OS is ("NT", "nt", "Unix", "GNU/Linux", "other OS");
@end smallexample
@noindent
Variables of a string type are called @b{typed variables}; all other
variables are called @b{untyped variables}. Typed variables are
particularly useful in @code{case} constructions, to support conditional
attribute declarations. (@pxref{Case Constructions}).
A string type may be referenced by its name if it has been declared in the same
project file, or by an expanded name whose prefix is the name of the project
in which it is declared.
@c ---------------------------------------------
@node Variables
@subsection Variables
@c ---------------------------------------------
@noindent
@b{Variables} store values (strings or list of strings) and can appear
as part of an expression. The declaration of a variable creates the
variable and assigns the value of the expression to it. The name of the
variable is available immediately after the assignment symbol, if you
need to reuse its old value to compute the new value. Before the completion
of its first declaration, the value of a variable defaults to the empty
string ("").
A @b{typed} variable can be used as part of a @b{case} expression to
compute the value, but it can only be declared once in the project file,
so that all case constructions see the same value for the variable. This
provides more consistency and makes the project easier to understand.
The syntax for its declaration is identical to the Ada syntax for an
object declaration. In effect, a typed variable acts as a constant.
An @b{untyped} variable can be declared and overridden multiple times
within the same project. It is declared implicitly through an Ada
assignment. The first declaration establishes the kind of the variable
(string or list of strings) and successive declarations must respect
the initial kind. Assignments are executed in the order in which they
appear, so the new value replaces the old one and any subsequent reference
to the variable uses the new value.
A variable may be declared at the project file level, or within a package.
@smallexample
typed_variable_declaration ::=
@i{}simple_name : @i{}name := string_expression;
variable_declaration ::= @i{}simple_name := expression;
@end smallexample
@noindent
Here are some examples of variable declarations:
@smallexample @c projectfile
@group
This_OS : OS := external ("OS"); -- a typed variable declaration
That_OS := "GNU/Linux"; -- an untyped variable declaration
Name := "readme.txt";
Save_Name := Name & ".saved";
Empty_List := ();
List_With_One_Element := ("-gnaty");
List_With_Two_Elements := List_With_One_Element & "-gnatg";
Long_List := ("main.ada", "pack1_.ada", "pack1.ada", "pack2_.ada");
@end group
@end smallexample
@noindent
A @b{variable reference} may take several forms:
@itemize @bullet
@item The simple variable name, for a variable in the current package (if any)
or in the current project
@item An expanded name, whose prefix is a context name.
@end itemize
@noindent
A @b{context} may be one of the following:
@itemize @bullet
@item The name of an existing package in the current project
@item The name of an imported project of the current project
@item The name of an ancestor project (i.e., a project extended by the current
project, either directly or indirectly)
@item An expanded name whose prefix is an imported/parent project name, and
whose selector is a package name in that project.
@end itemize
@c ---------------------------------------------
@node Case Constructions
@subsection Case Constructions
@c ---------------------------------------------
@noindent
A @b{case} statement is used in a project file to effect conditional
behavior. Through this statement, you can set the value of attributes
and variables depending on the value previously assigned to a typed
variable.
All choices in a choice list must be distinct. Unlike Ada, the choice
lists of all alternatives do not need to include all values of the type.
An @code{others} choice must appear last in the list of alternatives.
The syntax of a @code{case} construction is based on the Ada case statement
(although the @code{null} statement for empty alternatives is optional).
The case expression must be a typed string variable, whose value is often
given by an external reference (@pxref{External Values}).
Each alternative starts with the reserved word @code{when}, either a list of
literal strings separated by the @code{"|"} character or the reserved word
@code{others}, and the @code{"=>"} token.
Each literal string must belong to the string type that is the type of the
case variable.
After each @code{=>}, there are zero or more statements. The only
statements allowed in a case construction are other case constructions,
attribute declarations and variable declarations. String type declarations and
package declarations are not allowed. Variable declarations are restricted to
variables that have already been declared before the case construction.
@smallexample
case_statement ::=
@i{case} @i{}name @i{is} @{case_item@} @i{end case} ;
case_item ::=
@i{when} discrete_choice_list =>
@{case_statement
| attribute_declaration
| variable_declaration
| empty_declaration@}
discrete_choice_list ::= string_literal @{| string_literal@} | @i{others}
@end smallexample
@noindent
Here is a typical example:
@smallexample @c projectfile
@group
project MyProj is
type OS_Type is ("GNU/Linux", "Unix", "NT", "VMS");
OS : OS_Type := external ("OS", "GNU/Linux");
package Compiler is
case OS is
when "GNU/Linux" | "Unix" =>
for ^Switches^Switches^ ("Ada")
use ("-gnath");
when "NT" =>
for ^Switches^Switches^ ("Ada")
use ("^-gnatP^-gnatP^");
when others =>
null;
end case;
end Compiler;
end MyProj;
@end group
@end smallexample
@c ---------------------------------------------
@node Attributes
@subsection Attributes
@c ---------------------------------------------
@menu
* Project Level Attributes::
* Package Binder Attributes::
* Package Builder Attributes::
@ifclear FSFEDITION
* Package Check Attributes::
@end ifclear
* Package Clean Attributes::
* Package Compiler Attributes::
* Package Cross_Reference Attributes::
@ifclear FSFEDITION
* Package Eliminate Attributes::
@end ifclear
* Package Finder Attributes::
* Package ^gnatls^gnatls^ Attributes::
@ifclear FSFEDITION
* Package ^gnatstub^gnatstub^ Attributes::
@end ifclear
* Package IDE Attributes::
* Package Install Attributes::
* Package Linker Attributes::
@ifclear FSFEDITION
* Package Metrics Attribute::
@end ifclear
* Package Naming Attributes::
@ifclear FSFEDITION
* Package Pretty_Printer Attributes::
@end ifclear
* Package Remote Attributes::
* Package Stack Attributes::
* Package Synchronize Attributes::
@end menu
@noindent
A project (and its packages) may have @b{attributes} that define
the project's properties. Some attributes have values that are strings;
others have values that are string lists.
@smallexample
attribute_declaration ::=
simple_attribute_declaration | indexed_attribute_declaration
simple_attribute_declaration ::= @i{for} attribute_designator @i{use} expression ;
indexed_attribute_declaration ::=
@i{for} @i{}simple_name ( string_literal) @i{use} expression ;
attribute_designator ::=
@i{}simple_name
| @i{}simple_name ( string_literal )
@end smallexample
@noindent
There are two categories of attributes: @b{simple attributes}
and @b{indexed attributes}.
Each simple attribute has a default value: the empty string (for string
attributes) and the empty list (for string list attributes).
An attribute declaration defines a new value for an attribute, and overrides
the previous value. The syntax of a simple attribute declaration is similar to
that of an attribute definition clause in Ada.
Some attributes are indexed. These attributes are mappings whose
domain is a set of strings. They are declared one association
at a time, by specifying a point in the domain and the corresponding image
of the attribute.
Like untyped variables and simple attributes, indexed attributes
may be declared several times. Each declaration supplies a new value for the
attribute, and replaces the previous setting.
Here are some examples of attribute declarations:
@smallexample @c projectfile
-- simple attributes
for Object_Dir use "objects";
for Source_Dirs use ("units", "test/drivers");
-- indexed attributes
for Body ("main") use "Main.ada";
for ^Switches^Switches^ ("main.ada")
use ("-v", "^-gnatv^-gnatv^");
for ^Switches^Switches^ ("main.ada") use Builder'Switches ("main.ada") & "-g";
-- indexed attributes copy (from package Builder in project Default)
-- The package name must always be specified, even if it is the current
-- package.
for Default_Switches use Default.Builder'Default_Switches;
@end smallexample
@noindent
Attributes references may appear anywhere in expressions, and are used
to retrieve the value previously assigned to the attribute. If an attribute
has not been set in a given package or project, its value defaults to the
empty string or the empty list.
@smallexample
attribute_reference ::= attribute_prefix ' @i{_}simple_name [ (string_literal) ]
attribute_prefix ::= @i{project}
| @i{}simple_name
| package_identifier
| @i{}simple_name . package_identifier
@end smallexample
@noindent
Examples are:
@smallexample @c projectfile
project'Object_Dir
Naming'Dot_Replacement
Imported_Project'Source_Dirs
Imported_Project.Naming'Casing
Builder'Default_Switches ("Ada")
@end smallexample
@noindent
The prefix of an attribute may be:
@itemize @bullet
@item @code{project} for an attribute of the current project
@item The name of an existing package of the current project
@item The name of an imported project
@item The name of a parent project that is extended by the current project
@item An expanded name whose prefix is imported/parent project name,
and whose selector is a package name
@end itemize
@noindent
In the following sections, all predefined attributes are succinctly described,
first the project level attributes, that is those attributes that are not in a
package, then the attributes in the different packages.
It is possible for different tools to create dynamically new packages with
attributes, or new attribute in predefined packages. These attributes are
not documented here.
The attributes under Configuration headings are usually found only in
configuration project files.
The characteristics of each attribute are indicated as follows:
@itemize @bullet
@item @b{Type of value}
The value of an attribute may be a single string, indicated by the word
"single", or a string list, indicated by the word "list".
@item @b{Read-only}
When the attribute is read-only, that is when it is not allowed to declare
the attribute, this is indicated by the words "read-only".
@item @b{Optional index}
If it is allowed in the value of the attribute (both single and list) to have
an optional index, this is indicated by the words "optional index".
@item @b{Indexed attribute}
When an it is an indexed attribute, this is indicated by the word "indexed".
@item @b{Case-sensitivity of the index}
For an indexed attribute, if the index is case-insensitive, this is indicated
by the words "case-insensitive index".
@item @b{File name index}
For an indexed attribute, when the index is a file name, this is indicated by
the words "file name index". The index may or may not be case-sensitive,
depending on the platform.
@item @b{others allowed in index}
For an indexed attribute, if it is allowed to use @b{others} as the index,
this is indicated by the words "others allowed".
When @b{others} is used as the index of an indexed attribute, the value of
the attribute indexed by @b{others} is used when no other index would apply.
@end itemize
@node Project Level Attributes
@subsubsection Project Level Attributes
@noindent
@itemize @bullet
@item @b{General}
@itemize @bullet
@item @b{Name}: single, read-only
The name of the project.
@item @b{Project_Dir}: single, read-only
The path name of the project directory.
@item @b{Main}: list, optional index
The list of main sources for the executables.
@item @b{Languages}: list
The list of languages of the sources of the project.
@item @b{Roots}: list, indexed, file name index
The index is the file name of an executable source. Indicates the list of units
from the main project that need to be bound and linked with their closures
with the executable. The index is either a file name, a language name or "*".
The roots for an executable source are those in @b{Roots} with an index that
is the executable source file name, if declared. Otherwise, they are those in
@b{Roots} with an index that is the language name of the executable source,
if present. Otherwise, they are those in @b{Roots ("*")}, if declared. If none
of these three possibilities are declared, then there are no roots for the
executable source.
@item @b{Externally_Built}: single
Indicates if the project is externally built.
Only case-insensitive values allowed are "true" and "false", the default.
@end itemize
@noindent
@item @b{Directories}
@itemize @bullet
@item @b{Object_Dir}: single
Indicates the object directory for the project.
@item @b{Exec_Dir}: single
Indicates the exec directory for the project, that is the directory where the
executables are.
@item @b{Source_Dirs}: list
The list of source directories of the project.
@item @b{Inherit_Source_Path}: list, indexed, case-insensitive index
Index is a language name. Value is a list of language names. Indicates that
in the source search path of the index language the source directories of
the languages in the list should be included.
Example:
for Inherit_Source_Path ("C++") use ("C");
@item @b{Exclude_Source_Dirs}: list
The list of directories that are included in Source_Dirs but are not source
directories of the project.
@item @b{Ignore_Source_Sub_Dirs}: list
Value is a list of simple names for subdirectories that are removed from the
list of source directories, including theur subdirectories.
@end itemize
@item @b{Source Files}
@itemize @bullet
@item @b{Source_Files}: list
Value is a list of source file simple names.
@item @b{Locally_Removed_Files}: list
Obsolescent. Equivalent to Excluded_Source_Files.
@item @b{Excluded_Source_Files}: list
Value is a list of simple file names that are not sources of the project.
Allows to remove sources that are inherited or found in the source directories
and that match the naming scheme.
@item @b{Source_List_File}: single
Value is a text file name that contains a list of source file simple names,
one on each line.
@item @b{Excluded_Source_List_File}: single
Value is a text file name that contains a list of file simple names that
are not sources of the project.
@item @b{Interfaces}: list
Value is a list of file names that constitutes the interfaces of the project.
@end itemize
@item @b{Aggregate Projects}
@itemize @bullet
@item @b{Project_Files}: list
Value is the list of aggregated projects.
@item @b{Project_Path}: list
Value is a list of directories that are added to the project search path when
looking for the aggregated projects.
@item @b{External}: single, indexed
Index is the name of an external reference. Value is the value of the
external reference to be used when parsing the aggregated projects.
@end itemize
@item @b{Libraries}
@itemize @bullet
@item @b{Library_Dir}: single
Value is the name of the library directory. This attribute needs to be
declared for each library project.
@item @b{Library_Name}: single
Value is the name of the library. This attribute needs to be declared or
inherited for each library project.
@item @b{Library_Kind}: single
Specifies the kind of library: static library (archive) or shared library.
Case-insensitive values must be one of "static" for archives (the default) or
"dynamic" or "relocatable" for shared libraries.
@item @b{Library_Version}: single
Value is the name of the library file.
@item @b{Library_Interface}: list
Value is the list of unit names that constitutes the interfaces
of a Stand-Alone Library project.
@item @b{Library_Standalone}: single
Specifies if a Stand-Alone Library (SAL) is encapsulated or not.
Only authorized case-insensitive values are "standard" for non encapsulated
SALs, "encapsulated" for encapsulated SALs or "no" for non SAL library project.
@item @b{Library_Encapsulated_Options}: list
Value is a list of options that need to be used when linking an encapsulated
Stand-Alone Library.
@item @b{Library_Encapsulated_Supported}: single
Indicates if encapsulated Stand-Alone Libraries are supported. Only
authorized case-insensitive values are "true" and "false" (the default).
@item @b{Library_Auto_Init}: single
Indicates if a Stand-Alone Library is auto-initialized. Only authorized
case-insentive values are "true" and "false".
@item @b{Leading_Library_Options}: list
Value is a list of options that are to be used at the beginning of
the command line when linking a shared library.
@item @b{Library_Options}: list
Value is a list of options that are to be used when linking a shared library.
@item @b{Library_Rpath_Options}: list, indexed, case-insensitive index
Index is a language name. Value is a list of options for an invocation of the
compiler of the language. This invocation is done for a shared library project
with sources of the language. The output of the invocation is the path name
of a shared library file. The directory name is to be put in the run path
option switch when linking the shared library for the project.
@item @b{Library_Src_Dir}: single
Value is the name of the directory where copies of the sources of the
interfaces of a Stand-Alone Library are to be copied.
@item @b{Library_ALI_Dir}: single
Value is the name of the directory where the ALI files of the interfaces
of a Stand-Alone Library are to be copied. When this attribute is not declared,
the directory is the library directory.
@item @b{Library_gcc}: single
Obsolescent attribute. Specify the linker driver used to link a shared library.
Use instead attribute Linker'Driver.
@item @b{Library_Symbol_File}: single
Value is the name of the library symbol file.
@item @b{Library_Symbol_Policy}: single
Indicates the symbol policy kind. Only authorized case-insensitive values are
"autonomous", "default", "compliant", "controlled" or "direct".
@item @b{Library_Reference_Symbol_File}: single
Value is the name of the reference symbol file.
@end itemize
@item @b{Configuration - General}
@itemize @bullet
@item @b{Default_Language}: single
Value is the case-insensitive name of the language of a project when attribute
Languages is not specified.
@item @b{Run_Path_Option}: list
Value is the list of switches to be used when specifying the run path option
in an executable.
@item @b{Run_Path_Origin}: single
Value is the the string that may replace the path name of the executable
directory in the run path options.
@item @b{Separate_Run_Path_Options}: single
Indicates if there may be or not several run path options specified when
linking an executable. Only authorized case-insensitive b=values are "true" or
"false" (the default).
@item @b{Toolchain_Version}: single, indexed, case-insensitive index
Index is a language name. Specify the version of a toolchain for a language.
@item @b{Toolchain_Description}: single, indexed, case-insensitive index
Obsolescent. No longer used.
@item @b{Object_Generated}: single, indexed, case-insensitive index
Index is a language name. Indicates if invoking the compiler for a language
produces an object file. Only authorized case-insensitive values are "false"
and "true" (the default).
@item @b{Objects_Linked}: single, indexed, case-insensitive index
Index is a language name. Indicates if the object files created by the compiler
for a language need to be linked in the executable. Only authorized
case-insensitive values are "false" and "true" (the default).
@item @b{Target}: single
Value is the name of the target platform.
@end itemize
@item @b{Configuration - Libraries}
@itemize @bullet
@item @b{Library_Builder}: single
Value is the path name of the application that is to be used to build
libraries. Usually the path name of "gprlib".
@item @b{Library_Support}: single
Indicates the level of support of libraries. Only authorized case-insensitive
values are "static_only", "full" or "none" (the default).
@end itemize
@item @b{Configuration - Archives}
@itemize @bullet
@item @b{Archive_Builder}: list
Value is the name of the application to be used to create a static library
(archive), followed by the options to be used.
@item @b{Archive_Builder_Append_Option}: list
Value is the list of options to be used when invoking the archive builder
to add project files into an archive.
@item @b{Archive_Indexer}: list
Value is the name of the archive indexer, followed by the required options.
@item @b{Archive_Suffix}: single
Value is the extension of archives. When not declared, the extension is ".a".
@item @b{Library_Partial_Linker}: list
Value is the name of the partial linker executable, followed by the required
options.
@end itemize
@item @b{Configuration - Shared Libraries}
@itemize @bullet
@item @b{Shared_Library_Prefix}: single
Value is the prefix in the name of shared library files. When not declared,
the prefix is "lib".
@item @b{Shared_Library_Suffix}: single
Value is the the extension of the name of shared library files. When not
declared, the extension is ".so".
@item @b{Symbolic_Link_Supported}: single
Indicates if symbolic links are supported on the platform. Only authorized
case-insensitive values are "true" and "false" (the default).
@item @b{Library_Major_Minor_Id_Supported}: single
Indicates if major and minor ids for shared library names are supported on
the platform. Only authorized case-insensitive values are "true" and "false"
(the default).
@item @b{Library_Auto_Init_Supported}: single
Indicates if auto-initialization of Stand-Alone Libraries is supported. Only
authorized case-insensitive values are "true" and "false" (the default).
@item @b{Shared_Library_Minimum_Switches}: list
Value is the list of required switches when linking a shared library.
@item @b{Library_Version_Switches}: list
Value is the list of switches to specify a internal name for a shared library.
@item @b{Library_Install_Name_Option}: single
Value is the name of the option that needs to be used, concatenated with the
path name of the library file, when linking a shared library.
@item @b{Runtime_Library_Dir}: single, indexed, case-insensitive index
Index is a language name. Value is the path name of the directory where the
runtime libraries are located.
@item @b{Runtime_Source_Dir}: single, indexed, case-insensitive index
Index is a language name. Value is the path name of the directory where the
sources of runtime libraries are located.
@end itemize
@end itemize
@node Package Binder Attributes
@subsubsection Package Binder Attributes
@itemize @bullet
@item @b{General}
@itemize @bullet
@item @b{Default_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is the list of switches to be used when binding
code of the language, if there is no applicable attribute ^Switches^Switches^.
@item @b{^Switches^Switches^}: list, optional index, indexed,
case-insensitive index, others allowed
Index is either a language name or a source file name. Value is the list of
switches to be used when binding code. Index is either the source file name
of the executable to be bound or the language name of the code to be bound.
@end itemize
@item @b{Configuration - Binding}
@itemize @bullet
@item @b{Driver}: single, indexed, case-insensitive index
Index is a language name. Value is the name of the application to be used when
binding code of the language.
@item @b{Required_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is the list of the required switches to be
used when binding code of the language.
@item @b{Prefix}: single, indexed, case-insensitive index
Index is a language name. Value is a prefix to be used for the binder exchange
file name for the language. Used to have different binder exchange file names
when binding different languages.
@item @b{Objects_Path}: single,indexed, case-insensitive index
Index is a language name. Value is the name of the environment variable that
contains the path for the object directories.
@item @b{Object_Path_File}: single,indexed, case-insensitive index
Index is a language name. Value is the name of the environment variable. The
value of the environment variable is the path name of a text file that
contains the list of object directories.
@end itemize
@end itemize
@node Package Builder Attributes
@subsubsection Package Builder Attributes
@itemize @bullet
@item @b{Default_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is the list of builder switches to be used when
building an executable of the language, if there is no applicable attribute
Switches.
@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index,
others allowed
Index is either a language name or a source file name. Value is the list of
builder switches to be used when building an executable. Index is either the
source file name of the executable to be built or its language name.
@item @b{Global_Compilation_Switches}: list, optional index, indexed,
case-insensitive index
Index is either a language name or a source file name. Value is the list of
compilation switches to be used when building an executable. Index is either
the source file name of the executable to be built or its language name.
@item @b{Executable}: single, indexed, case-insensitive index
Index is an executable source file name. Value is the simple file name of the
executable to be built.
@item @b{Executable_Suffix}: single
Value is the extension of the file names of executable. When not specified,
the extension is the default extension of executables on the platform.
@item @b{Global_Configuration_Pragmas}: single
Value is the file name of a configuration pragmas file that is specified to
the Ada compiler when compiling any Ada source in the project tree.
@item @b{Global_Config_File}: single, indexed, case-insensitive index
Index is a language name. Value is the file name of a configuration file that
is specified to the compiler when compiling any source of the language in the
project tree.
@end itemize
@ifclear FSFEDITION
@node Package Check Attributes
@subsubsection Package Check Attributes
@itemize @bullet
@item @b{Default_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is a list of switches to be used when invoking
@code{gnatcheck} for a source of the language, if there is no applicable
attribute ^Switches^Switches^.
@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index,
others allowed
Index is a source file name. Value is the list of switches to be used when
invoking @code{gnatcheck} for the source.
@end itemize
@end ifclear
@node Package Clean Attributes
@subsubsection Package Clean Attributes
@itemize @bullet
@item @b{^Switches^Switches^}: list
Value is a list of switches to be used by the cleaning application.
@item @b{Source_Artifact_Extensions}: list, indexed, case-insensitive index
Index is a language names. Value is the list of extensions for file names
derived from object file names that need to be cleaned in the object
directory of the project.
@item @b{Object_Artifact_Extensions}: list, indexed, case-insensitive index
Index is a language names. Value is the list of extensions for file names
derived from source file names that need to be cleaned in the object
directory of the project.
@item @b{Artifacts_In_Object_Dir}: single
Value is a list of file names expressed as regular expressions that are to be
deleted by gprclean in the object directory of the project.
@item @b{Artifacts_In_Exec_Dir}: single
Value is list of file names expressed as regular expressions that are to be
deleted by gprclean in the exec directory of the main project.
@end itemize
@node Package Compiler Attributes
@subsubsection Package Compiler Attributes
@itemize @bullet
@item @b{General}
@itemize @bullet
@item @b{Default_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is a list of switches to be used when invoking
the compiler for the language for a source of the project, if there is no
applicable attribute Switches.
@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index,
others allowed
Index is a source file name or a language name. Value is the list of switches
to be used when invoking the compiler for the source or for its language.
@item @b{Local_Configuration_Pragmas}: single
Value is the file name of a configuration pragmas file that is specified to
the Ada compiler when compiling any Ada source in the project.
@item @b{Local_Config_File}: single, indexed, case-insensitive index
Index is a language name. Value is the file name of a configuration file that
is specified to the compiler when compiling any source of the language in the
project.
@end itemize
@item @b{Configuration - Compiling}
@itemize @bullet
@item @b{Driver}: single, indexed, case-insensitive index
Index is a language name. Value is the name of the executable for the compiler
of the language.
@item @b{Language_Kind}: single, indexed, case-insensitive index
Index is a language name. Indicates the kind of the language, either file based
or unit based. Only authorized case-insensitive values are "unit_based" and
"file_based" (the default).
@item @b{Dependency_Kind}: single, indexed, case-insensitive index
Index is a language name. Indicates how the dependencies are handled for the
language. Only authorized case-insensitive values are "makefile", "ali_file",
"ali_closure" or "none" (the default).
@item @b{Required_Switches}: list, indexed, case-insensitive index
Equivalent to attribute Leading_Required_Switches.
@item @b{Leading_Required_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is the list of the minimum switches to be used
at the beginning of the command line when invoking the compiler for the
language.
@item @b{Trailing_Required_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is the list of the minimum switches to be used
at the end of the command line when invoking the compiler for the language.
@item @b{PIC_Option}: list, indexed, case-insensitive index
Index is a language name. Value is the list of switches to be used when
compiling a source of the language when the project is a shared library
project.
@item @b{Path_Syntax}: single, indexed, case-insensitive index
Index is a language name. Value is the kind of path syntax to be used when
invoking the compiler for the language. Only authorized case-insensitive
values are "canonical" and "host" (the default).
@item @b{Source_File_Switches}: single, indexed, case-insensitive index
Index is a language name. Value is a list of switches to be used just before
the path name of the source to compile when invoking the compiler for a source
of the language.
@item @b{Object_File_Suffix}: single, indexed, case-insensitive index
Index is a language name. Value is the extension of the object files created
by the compiler of the language. When not specified, the extension is the
default one for the platform.
@item @b{Object_File_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is the list of switches to be used by the
compiler of the language to specify the path name of the object file. When not
specified, the switch used is "-o".
@item @b{Multi_Unit_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is the list of switches to be used to compile
a unit in a multi unit source of the language. The index of the unit in the
source is concatenated with the last switches in the list.
@item @b{Multi_Unit_Object_Separator}: single, indexed, case-insensitive index
Index is a language name. Value is the string to be used in the object file
name before the index of the unit, when compiling a unit in a multi unit source
of the language.
@end itemize
@item @b{Configuration - Mapping Files}
@itemize @bullet
@item @b{Mapping_File_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is the list of switches to be used to specify
a mapping file when invoking the compiler for a source of the language.
@item @b{Mapping_Spec_Suffix}: single, indexed, case-insensitive index
Index is a language name. Value is the suffix to be used in a mapping file
to indicate that the source is a spec.
@item @b{Mapping_Body_Suffix}: single, indexed, case-insensitive index
Index is a language name. Value is the suffix to be used in a mapping file
to indicate that the source is a body.
@end itemize
@item @b{Configuration - Config Files}
@itemize @bullet
@item @b{Config_File_Switches}: list: single, indexed, case-insensitive index
Index is a language name. Value is the list of switches to specify to the
compiler of the language a configuration file.
@item @b{Config_Body_File_Name}: single, indexed, case-insensitive index
Index is a language name. Value is the template to be used to indicate a
configuration specific to a body of the language in a configuration
file.
@item @b{Config_Body_File_Name_Index}: single, indexed, case-insensitive index
Index is a language name. Value is the template to be used to indicate a
configuration specific to the body a unit in a multi unit source of the
language in a configuration file.
@item @b{Config_Body_File_Name_Pattern}: single, indexed,
case-insensitive index
Index is a language name. Value is the template to be used to indicate a
configuration for all bodies of the languages in a configuration file.
@item @b{Config_Spec_File_Name}: single, indexed, case-insensitive index
Index is a language name. Value is the template to be used to indicate a
configuration specific to a spec of the language in a configuration
file.
@item @b{Config_Spec_File_Name_Index}: single, indexed, case-insensitive index
Index is a language name. Value is the template to be used to indicate a
configuration specific to the spec a unit in a multi unit source of the
language in a configuration file.
@item @b{Config_Spec_File_Name_Pattern}: single, indexed,
case-insensitive index
Index is a language name. Value is the template to be used to indicate a
configuration for all specs of the languages in a configuration file.
@item @b{Config_File_Unique}: single, indexed, case-insensitive index
Index is a language name. Indicates if there should be only one configuration
file specified to the compiler of the language. Only authorized
case-insensitive values are "true" and "false" (the default).
@end itemize
@item @b{Configuration - Dependencies}
@itemize @bullet
@item @b{Dependency_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is the list of switches to be used to specify
to the compiler the dependency file when the dependency kind of the language is
file based, and when Dependency_Driver is not specified for the language.
@item @b{Dependency_Driver}: list, indexed, case-insensitive index
Index is a language name. Value is the name of the executable to be used to
create the dependency file for a source of the language, followed by the
required switches.
@end itemize
@item @b{Configuration - Search Paths}
@itemize @bullet
@item @b{Include_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is the list of switches to specify to the
compiler of the language to indicate a directory to look for sources.
@item @b{Include_Path}: single, indexed, case-insensitive index
Index is a language name. Value is the name of an environment variable that
contains the path of all the directories that the compiler of the language
may search for sources.
@item @b{Include_Path_File}: single, indexed, case-insensitive index
Index is a language name. Value is the name of an environment variable the
value of which is the path name of a text file that contains the directories
that the compiler of the language may search for sources.
@item @b{Object_Path_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is the list of switches to specify to the
compiler of the language the name of a text file that contains the list of
object directories. When this attribute is not declared, the text file is
not created.
@end itemize
@end itemize
@node Package Cross_Reference Attributes
@subsubsection Package Cross_Reference Attributes
@itemize @bullet
@item @b{Default_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is a list of switches to be used when invoking
@code{gnatxref} for a source of the language, if there is no applicable
attribute Switches.
@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index,
others allowed
Index is a source file name. Value is the list of switches to be used when
invoking @code{gnatxref} for the source.
@end itemize
@ifclear FSFEDITION
@node Package Eliminate Attributes
@subsubsection Package Eliminate Attributes
@itemize @bullet
@item @b{Default_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is a list of switches to be used when invoking
@code{gnatelim} for a source of the language, if there is no applicable
attribute Switches.
@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index,
others allowed
Index is a source file name. Value is the list of switches to be used when
invoking @code{gnatelim} for the source.
@end itemize
@end ifclear
@node Package Finder Attributes
@subsubsection Package Finder Attributes
@itemize @bullet
@item @b{Default_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is a list of switches to be used when invoking
@code{gnatfind} for a source of the language, if there is no applicable
attribute Switches.
@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index,
others allowed
Index is a source file name. Value is the list of switches to be used when
invoking @code{gnatfind} for the source.
@end itemize
@node Package ^gnatls^gnatls^ Attributes
@subsubsection Package ^gnatls^gnatls^ Attributes
@itemize @bullet
@item @b{^Switches^Switches^}: list
Value is a list of switches to be used when invoking @code{gnatls}.
@end itemize
@ifclear FSFEDITION
@node Package ^gnatstub^gnatstub^ Attributes
@subsubsection Package ^gnatstub^gnatstub^ Attributes
@itemize @bullet
@item @b{Default_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is a list of switches to be used when invoking
@code{gnatstub} for a source of the language, if there is no applicable
attribute ^Switches^Switches^.
@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index,
others allowed
Index is a source file name. Value is the list of switches to be used when
invoking @code{gnatstub} for the source.
@end itemize
@end ifclear
@node Package IDE Attributes
@subsubsection Package IDE Attributes
@itemize @bullet
@item @b{Default_Switches}: list, indexed
Index is the name of an external tool that the GNAT Programming System (GPS)
is supporting. Value is a list of switches to use when invoking that tool.
@item @b{Remote_Host}: single
Value is a string that designates the remote host in a cross-compilation
environment, to be used for remote compilation and debugging. This attribute
should not be specified when running on the local machine.
@item @b{Program_Host}: single
Value is a string that specifies the name of IP address of the embedded target
in a cross-compilation environment, on which the program should execute.
@item @b{Communication_Protocol}: single
Value is the name of the protocol to use to communicate with the target
in a cross-compilation environment, for example @code{"wtx"} or
@code{"vxworks"}.
@item @b{Compiler_Command}: single, indexed, case-insensitive index
Index is a language Name. Value is a string that denotes the command to be
used to invoke the compiler. The value of @code{Compiler_Command ("Ada")} is
expected to be compatible with @command{gnatmake}, in particular in
the handling of switches.
@item @b{Debugger_Command}: single
Value is a string that specifies the name of the debugger to be used, such as
gdb, powerpc-wrs-vxworks-gdb or gdb-4.
@item @b{^gnatlist^gnatlist^}: single
Value is a string that specifies the name of the @command{^gnatls^gnatls^} utility
to be used to retrieve information about the predefined path; for example,
@code{"^gnatls^gnatls^"}, @code{"powerpc-wrs-vxworks-gnatls"}.
@item @b{VCS_Kind}: single
Value is a string used to specify the Version Control System (VCS) to be used
for this project, for example "Subversion", "ClearCase". If the
value is set to "Auto", the IDE will try to detect the actual VCS used
on the list of supported ones.
@item @b{VCS_File_Check}: single
Value is a string that specifies the command used by the VCS to check
the validity of a file, either when the user explicitly asks for a check,
or as a sanity check before doing the check-in.
@item @b{VCS_Log_Check}: single
Value is a string that specifies the command used by the VCS to check
the validity of a log file.
@item @b{Documentation_Dir}: single
Value is the directory used to generate the documentation of source code.
@end itemize
@node Package Install Attributes
@subsubsection Package Install Attributes
@itemize @bullet
@item @b{Prefix}: single
Value is the install destination directory.
@item @b{Sources_Subdir}: single
Value is the sources directory or subdirectory of Prefix.
@item @b{Exec_Subdir}: single
Value is the executables directory or subdirectory of Prefix.
@item @b{Lib_Subdir}: single
Value is library directory or subdirectory of Prefix.
@item @b{Project_Subdir}: single
Value is the project directory or subdirectory of Prefix.
@item @b{Active}: single
Indicates that the project is to be installed or not. Case-insensitive value
"false" means that the project is not to be installed, all other values mean
that the project is to be installed.
@end itemize
@node Package Linker Attributes
@subsubsection Package Linker Attributes
@itemize @bullet
@item @b{General}
@itemize @bullet
@item @b{Required_Switches}: list
Value is a list of switches that are required when invoking the linker to link
an executable.
@item @b{Default_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is a list of switches for the linker when
linking an executable for a main source of the language, when there is no
applicable Switches.
@item @b{Leading_Switches}: list, optional index, indexed,
case-insensitive index, others allowed
Index is a source file name or a language name. Value is the list of switches
to be used at the beginning of the command line when invoking the linker to
build an executable for the source or for its language.
@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index,
others allowed
Index is a source file name or a language name. Value is the list of switches
to be used when invoking the linker to build an executable for the source or
for its language.
@item @b{Trailing_Switches}: list, optional index, indexed,
case-insensitive index, others allowed
Index is a source file name or a language name. Value is the list of switches
to be used at the end of the command line when invoking the linker to
build an executable for the source or for its language. These switches may
override the Required_Switches.
@item @b{Linker_Options}: list
Value is a list of switches/options that are to be added when linking an
executable from a project importing the current project directly or indirectly.
Linker_Options are not used when linking an executable from the current
project.
@item @b{Map_File_Option}: single
Value is the switch to specify the map file name that the linker needs to
create.
@end itemize
@item @b{Configuration - Linking}
@itemize @bullet
@item @b{Driver}: single
Value is the name of the linker executable.
@end itemize
@item @b{Configuration - Response Files}
@itemize @bullet
@item @b{Max_Command_Line_Length}: single
Value is the maximum number of character in the command line when invoking
the linker to link an executable.
@item @b{Response_File_Format}: single
Indicates the kind of response file to create when the length of the linking
command line is too large. Only authorized case-insensitive values are "none",
"gnu", "object_list", "gcc_gnu", "gcc_option_list" and "gcc_object_list".
@item @b{Response_File_Switches}: list
Value is the list of switches to specify a response file to the linker.
@end itemize
@end itemize
@ifclear FSFEDITION
@node Package Metrics Attribute
@subsubsection Package Metrics Attribute
@itemize @bullet
@item @b{Default_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is a list of switches to be used when invoking
@code{gnatmetric} for a source of the language, if there is no applicable
attribute Switches.
@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index,
others allowed
Index is a source file name. Value is the list of switches to be used when
invoking @code{gnatmetric} for the source.
@end itemize
@end ifclear
@node Package Naming Attributes
@subsubsection Package Naming Attributes
@itemize @bullet
@item @b{Specification_Suffix}: single, indexed, case-insensitive index
Equivalent to attribute Spec_Suffix.
@item @b{Spec_Suffix}: single, indexed, case-insensitive index
Index is a language name. Value is the extension of file names for specs of
the language.
@item @b{Implementation_Suffix}: single, indexed, case-insensitive index
Equivalent to attribute Body_Suffix.
@item @b{Body_Suffix}: single, indexed, case-insensitive index
Index is a language name. Value is the extension of file names for bodies of
the language.
@item @b{Separate_Suffix}: single
Value is the extension of file names for subunits of Ada.
@item @b{Casing}: single
Indicates the casing of sources of the Ada language. Only authorized
case-insensitive values are "lowercase", "uppercase" and "mixedcase".
@item @b{Dot_Replacement}: single
Value is the string that replace the dot of unit names in the source file names
of the Ada language.
@item @b{Specification}: single, optional index, indexed,
case-insensitive index
Equivalent to attribute Spec.
@item @b{Spec}: single, optional index, indexed, case-insensitive index
Index is a unit name. Value is the file name of the spec of the unit.
@item @b{Implementation}: single, optional index, indexed,
case-insensitive index
Equivalent to attribute Body.
@item @b{Body}: single, optional index, indexed, case-insensitive index
Index is a unit name. Value is the file name of the body of the unit.
@item @b{Specification_Exceptions}: list, indexed, case-insensitive index
Index is a language name. Value is a list of specs for the language that do not
necessarily follow the naming scheme for the language and that may or may not
be found in the source directories of the project.
@item @b{Implementation_Exceptions}: list, indexed, case-insensitive index
Index is a language name. Value is a list of bodies for the language that do not
necessarily follow the naming scheme for the language and that may or may not
be found in the source directories of the project.
@end itemize
@ifclear FSFEDITION
@node Package Pretty_Printer Attributes
@subsubsection Package Pretty_Printer Attributes
@itemize @bullet
@item @b{Default_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is a list of switches to be used when invoking
@code{gnatpp} for a source of the language, if there is no applicable
attribute Switches.
@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index,
others allowed
Index is a source file name. Value is the list of switches to be used when
invoking @code{gnatpp} for the source.
@end itemize
@end ifclear
@node Package Remote Attributes
@subsubsection Package Remote Attributes
@itemize @bullet
@item @b{Included_Patterns}: list
If this attribute is defined it sets the patterns to
synchronized from the master to the slaves. It is exclusive
with Excluded_Patterns, that is it is an error to define
both.
@item @b{Included_Artifact_Patterns}: list
If this attribute is defined it sets the patterns of compilation
artifacts to synchronized from the slaves to the build master.
This attribute replace the default hard-coded patterns.
@item @b{Excluded_Patterns}: list
Set of patterns to ignore when synchronizing sources from the build
master to the slaves. A set of predefined patterns are supported
(e.g. *.o, *.ali, *.exe, etc.), this attributes make it possible to
add some more patterns.
@item @b{Root_Dir}: single
Value is the root directory used by the slave machines.
@end itemize
@node Package Stack Attributes
@subsubsection Package Stack Attributes
@itemize @bullet
@item @b{^Switches^Switches^}: list
Value is the list of switches to be used when invoking @code{gnatstack}.
@end itemize
@node Package Synchronize Attributes
@subsubsection Package Synchronize Attributes
@itemize @bullet
@item @b{Default_Switches}: list, indexed, case-insensitive index
Index is a language name. Value is a list of switches to be used when invoking
@code{gnatsync} for a source of the language, if there is no applicable
attribute Switches.
@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index,
others allowed
Index is a source file name. Value is the list of switches to be used when
invoking @code{gnatsync} for the source.
@end itemize
gprbuild-gpl-2014-src/gnat/prj-tree.adb 0000644 0000767 0000145 00000274276 12323721731 017306 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . T R E E --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2014, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Osint; use Osint;
with Prj.Env; use Prj.Env;
with Prj.Err;
with Ada.Unchecked_Deallocation;
package body Prj.Tree is
Node_With_Comments : constant array (Project_Node_Kind) of Boolean :=
(N_Project => True,
N_With_Clause => True,
N_Project_Declaration => False,
N_Declarative_Item => False,
N_Package_Declaration => True,
N_String_Type_Declaration => True,
N_Literal_String => False,
N_Attribute_Declaration => True,
N_Typed_Variable_Declaration => True,
N_Variable_Declaration => True,
N_Expression => False,
N_Term => False,
N_Literal_String_List => False,
N_Variable_Reference => False,
N_External_Value => False,
N_Attribute_Reference => False,
N_Case_Construction => True,
N_Case_Item => True,
N_Comment_Zones => True,
N_Comment => True);
-- Indicates the kinds of node that may have associated comments
package Next_End_Nodes is new Table.Table
(Table_Component_Type => Project_Node_Id,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Next_End_Nodes");
-- A stack of nodes to indicates to what node the next "end" is associated
use Tree_Private_Part;
End_Of_Line_Node : Project_Node_Id := Empty_Node;
-- The node an end of line comment may be associated with
Previous_Line_Node : Project_Node_Id := Empty_Node;
-- The node an immediately following comment may be associated with
Previous_End_Node : Project_Node_Id := Empty_Node;
-- The node comments immediately following an "end" line may be
-- associated with.
Unkept_Comments : Boolean := False;
-- Set to True when some comments may not be associated with any node
function Comment_Zones_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
-- Returns the ID of the N_Comment_Zones node associated with node Node.
-- If there is not already an N_Comment_Zones node, create one and
-- associate it with node Node.
------------------
-- Add_Comments --
------------------
procedure Add_Comments
(To : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
Where : Comment_Location) is
Zone : Project_Node_Id := Empty_Node;
Previous : Project_Node_Id := Empty_Node;
begin
pragma Assert
(Present (To)
and then In_Tree.Project_Nodes.Table (To).Kind /= N_Comment);
Zone := In_Tree.Project_Nodes.Table (To).Comments;
if No (Zone) then
-- Create new N_Comment_Zones node
Project_Node_Table.Increment_Last (In_Tree.Project_Nodes);
In_Tree.Project_Nodes.Table
(Project_Node_Table.Last (In_Tree.Project_Nodes)) :=
(Kind => N_Comment_Zones,
Qualifier => Unspecified,
Expr_Kind => Undefined,
Location => No_Location,
Directory => No_Path,
Variables => Empty_Node,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
Path_Name => No_Path,
Value => No_Name,
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
Field4 => Empty_Node,
Flag1 => False,
Flag2 => False,
Comments => Empty_Node);
Zone := Project_Node_Table.Last (In_Tree.Project_Nodes);
In_Tree.Project_Nodes.Table (To).Comments := Zone;
end if;
if Where = End_Of_Line then
In_Tree.Project_Nodes.Table (Zone).Value := Comments.Table (1).Value;
else
-- Get each comments in the Comments table and link them to node To
for J in 1 .. Comments.Last loop
-- Create new N_Comment node
if (Where = After or else Where = After_End)
and then Token /= Tok_EOF
and then Comments.Table (J).Follows_Empty_Line
then
Comments.Table (1 .. Comments.Last - J + 1) :=
Comments.Table (J .. Comments.Last);
Comments.Set_Last (Comments.Last - J + 1);
return;
end if;
Project_Node_Table.Increment_Last (In_Tree.Project_Nodes);
In_Tree.Project_Nodes.Table
(Project_Node_Table.Last (In_Tree.Project_Nodes)) :=
(Kind => N_Comment,
Qualifier => Unspecified,
Expr_Kind => Undefined,
Flag1 => Comments.Table (J).Follows_Empty_Line,
Flag2 =>
Comments.Table (J).Is_Followed_By_Empty_Line,
Location => No_Location,
Directory => No_Path,
Variables => Empty_Node,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
Path_Name => No_Path,
Value => Comments.Table (J).Value,
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
Field4 => Empty_Node,
Comments => Empty_Node);
-- If this is the first comment, put it in the right field of
-- the node Zone.
if No (Previous) then
case Where is
when Before =>
In_Tree.Project_Nodes.Table (Zone).Field1 :=
Project_Node_Table.Last (In_Tree.Project_Nodes);
when After =>
In_Tree.Project_Nodes.Table (Zone).Field2 :=
Project_Node_Table.Last (In_Tree.Project_Nodes);
when Before_End =>
In_Tree.Project_Nodes.Table (Zone).Field3 :=
Project_Node_Table.Last (In_Tree.Project_Nodes);
when After_End =>
In_Tree.Project_Nodes.Table (Zone).Comments :=
Project_Node_Table.Last (In_Tree.Project_Nodes);
when End_Of_Line =>
null;
end case;
else
-- When it is not the first, link it to the previous one
In_Tree.Project_Nodes.Table (Previous).Comments :=
Project_Node_Table.Last (In_Tree.Project_Nodes);
end if;
-- This node becomes the previous one for the next comment, if
-- there is one.
Previous := Project_Node_Table.Last (In_Tree.Project_Nodes);
end loop;
end if;
-- Empty the Comments table, so that there is no risk to link the same
-- comments to another node.
Comments.Set_Last (0);
end Add_Comments;
--------------------------------
-- Associative_Array_Index_Of --
--------------------------------
function Associative_Array_Index_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Name_Id
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
return In_Tree.Project_Nodes.Table (Node).Value;
end Associative_Array_Index_Of;
----------------------------
-- Associative_Package_Of --
----------------------------
function Associative_Package_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration));
return In_Tree.Project_Nodes.Table (Node).Field3;
end Associative_Package_Of;
----------------------------
-- Associative_Project_Of --
----------------------------
function Associative_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration));
return In_Tree.Project_Nodes.Table (Node).Field2;
end Associative_Project_Of;
----------------------
-- Case_Insensitive --
----------------------
function Case_Insensitive
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Boolean
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
return In_Tree.Project_Nodes.Table (Node).Flag1;
end Case_Insensitive;
--------------------------------
-- Case_Variable_Reference_Of --
--------------------------------
function Case_Variable_Reference_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction);
return In_Tree.Project_Nodes.Table (Node).Field1;
end Case_Variable_Reference_Of;
----------------------
-- Comment_Zones_Of --
----------------------
function Comment_Zones_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
Zone : Project_Node_Id;
begin
pragma Assert (Present (Node));
Zone := In_Tree.Project_Nodes.Table (Node).Comments;
-- If there is not already an N_Comment_Zones associated, create a new
-- one and associate it with node Node.
if No (Zone) then
Project_Node_Table.Increment_Last (In_Tree.Project_Nodes);
Zone := Project_Node_Table.Last (In_Tree.Project_Nodes);
In_Tree.Project_Nodes.Table (Zone) :=
(Kind => N_Comment_Zones,
Qualifier => Unspecified,
Location => No_Location,
Directory => No_Path,
Expr_Kind => Undefined,
Variables => Empty_Node,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
Path_Name => No_Path,
Value => No_Name,
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
Field4 => Empty_Node,
Flag1 => False,
Flag2 => False,
Comments => Empty_Node);
In_Tree.Project_Nodes.Table (Node).Comments := Zone;
end if;
return Zone;
end Comment_Zones_Of;
-----------------------
-- Current_Item_Node --
-----------------------
function Current_Item_Node
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item);
return In_Tree.Project_Nodes.Table (Node).Field1;
end Current_Item_Node;
------------------
-- Current_Term --
------------------
function Current_Term
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Term);
return In_Tree.Project_Nodes.Table (Node).Field1;
end Current_Term;
--------------------------
-- Default_Project_Node --
--------------------------
function Default_Project_Node
(In_Tree : Project_Node_Tree_Ref;
Of_Kind : Project_Node_Kind;
And_Expr_Kind : Variable_Kind := Undefined) return Project_Node_Id
is
Result : Project_Node_Id;
Zone : Project_Node_Id;
Previous : Project_Node_Id;
begin
-- Create new node with specified kind and expression kind
Project_Node_Table.Increment_Last (In_Tree.Project_Nodes);
In_Tree.Project_Nodes.Table
(Project_Node_Table.Last (In_Tree.Project_Nodes)) :=
(Kind => Of_Kind,
Qualifier => Unspecified,
Location => No_Location,
Directory => No_Path,
Expr_Kind => And_Expr_Kind,
Variables => Empty_Node,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
Path_Name => No_Path,
Value => No_Name,
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
Field4 => Empty_Node,
Flag1 => False,
Flag2 => False,
Comments => Empty_Node);
-- Save the new node for the returned value
Result := Project_Node_Table.Last (In_Tree.Project_Nodes);
if Comments.Last > 0 then
-- If this is not a node with comments, then set the flag
if not Node_With_Comments (Of_Kind) then
Unkept_Comments := True;
elsif Of_Kind /= N_Comment and then Of_Kind /= N_Comment_Zones then
Project_Node_Table.Increment_Last (In_Tree.Project_Nodes);
In_Tree.Project_Nodes.Table
(Project_Node_Table.Last (In_Tree.Project_Nodes)) :=
(Kind => N_Comment_Zones,
Qualifier => Unspecified,
Expr_Kind => Undefined,
Location => No_Location,
Directory => No_Path,
Variables => Empty_Node,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
Path_Name => No_Path,
Value => No_Name,
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
Field4 => Empty_Node,
Flag1 => False,
Flag2 => False,
Comments => Empty_Node);
Zone := Project_Node_Table.Last (In_Tree.Project_Nodes);
In_Tree.Project_Nodes.Table (Result).Comments := Zone;
Previous := Empty_Node;
for J in 1 .. Comments.Last loop
-- Create a new N_Comment node
Project_Node_Table.Increment_Last (In_Tree.Project_Nodes);
In_Tree.Project_Nodes.Table
(Project_Node_Table.Last (In_Tree.Project_Nodes)) :=
(Kind => N_Comment,
Qualifier => Unspecified,
Expr_Kind => Undefined,
Flag1 => Comments.Table (J).Follows_Empty_Line,
Flag2 =>
Comments.Table (J).Is_Followed_By_Empty_Line,
Location => No_Location,
Directory => No_Path,
Variables => Empty_Node,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
Path_Name => No_Path,
Value => Comments.Table (J).Value,
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
Field4 => Empty_Node,
Comments => Empty_Node);
-- Link it to the N_Comment_Zones node, if it is the first,
-- otherwise to the previous one.
if No (Previous) then
In_Tree.Project_Nodes.Table (Zone).Field1 :=
Project_Node_Table.Last (In_Tree.Project_Nodes);
else
In_Tree.Project_Nodes.Table (Previous).Comments :=
Project_Node_Table.Last (In_Tree.Project_Nodes);
end if;
-- This new node will be the previous one for the next
-- N_Comment node, if there is one.
Previous := Project_Node_Table.Last (In_Tree.Project_Nodes);
end loop;
-- Empty the Comments table after all comments have been processed
Comments.Set_Last (0);
end if;
end if;
return Result;
end Default_Project_Node;
------------------
-- Directory_Of --
------------------
function Directory_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Path_Name_Type
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
return In_Tree.Project_Nodes.Table (Node).Directory;
end Directory_Of;
-------------------------
-- End_Of_Line_Comment --
-------------------------
function End_Of_Line_Comment
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Name_Id
is
Zone : Project_Node_Id := Empty_Node;
begin
pragma Assert (Present (Node));
Zone := In_Tree.Project_Nodes.Table (Node).Comments;
if No (Zone) then
return No_Name;
else
return In_Tree.Project_Nodes.Table (Zone).Value;
end if;
end End_Of_Line_Comment;
------------------------
-- Expression_Kind_Of --
------------------------
function Expression_Kind_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Variable_Kind
is
begin
pragma Assert
(Present (Node)
and then -- should use Nkind_In here ??? why not???
(In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind =
N_Typed_Variable_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Expression
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Term
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value));
return In_Tree.Project_Nodes.Table (Node).Expr_Kind;
end Expression_Kind_Of;
-------------------
-- Expression_Of --
-------------------
function Expression_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind =
N_Attribute_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind =
N_Typed_Variable_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind =
N_Variable_Declaration));
return In_Tree.Project_Nodes.Table (Node).Field1;
end Expression_Of;
-------------------------
-- Extended_Project_Of --
-------------------------
function Extended_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration);
return In_Tree.Project_Nodes.Table (Node).Field2;
end Extended_Project_Of;
------------------------------
-- Extended_Project_Path_Of --
------------------------------
function Extended_Project_Path_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Path_Name_Type
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
return Path_Name_Type (In_Tree.Project_Nodes.Table (Node).Value);
end Extended_Project_Path_Of;
--------------------------
-- Extending_Project_Of --
--------------------------
function Extending_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration);
return In_Tree.Project_Nodes.Table (Node).Field3;
end Extending_Project_Of;
---------------------------
-- External_Reference_Of --
---------------------------
function External_Reference_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value);
return In_Tree.Project_Nodes.Table (Node).Field1;
end External_Reference_Of;
-------------------------
-- External_Default_Of --
-------------------------
function External_Default_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref)
return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value);
return In_Tree.Project_Nodes.Table (Node).Field2;
end External_Default_Of;
------------------------
-- First_Case_Item_Of --
------------------------
function First_Case_Item_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction);
return In_Tree.Project_Nodes.Table (Node).Field2;
end First_Case_Item_Of;
---------------------
-- First_Choice_Of --
---------------------
function First_Choice_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref)
return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item);
return In_Tree.Project_Nodes.Table (Node).Field1;
end First_Choice_Of;
-------------------------
-- First_Comment_After --
-------------------------
function First_Comment_After
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
Zone : Project_Node_Id := Empty_Node;
begin
pragma Assert (Present (Node));
Zone := In_Tree.Project_Nodes.Table (Node).Comments;
if No (Zone) then
return Empty_Node;
else
return In_Tree.Project_Nodes.Table (Zone).Field2;
end if;
end First_Comment_After;
-----------------------------
-- First_Comment_After_End --
-----------------------------
function First_Comment_After_End
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref)
return Project_Node_Id
is
Zone : Project_Node_Id := Empty_Node;
begin
pragma Assert (Present (Node));
Zone := In_Tree.Project_Nodes.Table (Node).Comments;
if No (Zone) then
return Empty_Node;
else
return In_Tree.Project_Nodes.Table (Zone).Comments;
end if;
end First_Comment_After_End;
--------------------------
-- First_Comment_Before --
--------------------------
function First_Comment_Before
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
Zone : Project_Node_Id := Empty_Node;
begin
pragma Assert (Present (Node));
Zone := In_Tree.Project_Nodes.Table (Node).Comments;
if No (Zone) then
return Empty_Node;
else
return In_Tree.Project_Nodes.Table (Zone).Field1;
end if;
end First_Comment_Before;
------------------------------
-- First_Comment_Before_End --
------------------------------
function First_Comment_Before_End
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
Zone : Project_Node_Id := Empty_Node;
begin
pragma Assert (Present (Node));
Zone := In_Tree.Project_Nodes.Table (Node).Comments;
if No (Zone) then
return Empty_Node;
else
return In_Tree.Project_Nodes.Table (Zone).Field3;
end if;
end First_Comment_Before_End;
-------------------------------
-- First_Declarative_Item_Of --
-------------------------------
function First_Declarative_Item_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration));
if In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration then
return In_Tree.Project_Nodes.Table (Node).Field1;
else
return In_Tree.Project_Nodes.Table (Node).Field2;
end if;
end First_Declarative_Item_Of;
------------------------------
-- First_Expression_In_List --
------------------------------
function First_Expression_In_List
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String_List);
return In_Tree.Project_Nodes.Table (Node).Field1;
end First_Expression_In_List;
--------------------------
-- First_Literal_String --
--------------------------
function First_Literal_String
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind =
N_String_Type_Declaration);
return In_Tree.Project_Nodes.Table (Node).Field1;
end First_Literal_String;
----------------------
-- First_Package_Of --
----------------------
function First_Package_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Package_Declaration_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
return In_Tree.Project_Nodes.Table (Node).Packages;
end First_Package_Of;
--------------------------
-- First_String_Type_Of --
--------------------------
function First_String_Type_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
return In_Tree.Project_Nodes.Table (Node).Field3;
end First_String_Type_Of;
----------------
-- First_Term --
----------------
function First_Term
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Expression);
return In_Tree.Project_Nodes.Table (Node).Field1;
end First_Term;
-----------------------
-- First_Variable_Of --
-----------------------
function First_Variable_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Variable_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Project
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration));
return In_Tree.Project_Nodes.Table (Node).Variables;
end First_Variable_Of;
--------------------------
-- First_With_Clause_Of --
--------------------------
function First_With_Clause_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
return In_Tree.Project_Nodes.Table (Node).Field1;
end First_With_Clause_Of;
------------------------
-- Follows_Empty_Line --
------------------------
function Follows_Empty_Line
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Boolean
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Comment);
return In_Tree.Project_Nodes.Table (Node).Flag1;
end Follows_Empty_Line;
----------
-- Hash --
----------
function Hash (N : Project_Node_Id) return Header_Num is
begin
return Header_Num (N mod Project_Node_Id (Header_Num'Last));
end Hash;
----------------
-- Initialize --
----------------
procedure Initialize (Tree : Project_Node_Tree_Ref) is
begin
Project_Node_Table.Init (Tree.Project_Nodes);
Projects_Htable.Reset (Tree.Projects_HT);
end Initialize;
--------------------
-- Override_Flags --
--------------------
procedure Override_Flags
(Self : in out Environment;
Flags : Prj.Processing_Flags)
is
begin
Self.Flags := Flags;
end Override_Flags;
----------------
-- Initialize --
----------------
procedure Initialize
(Self : out Environment;
Flags : Processing_Flags)
is
begin
-- Do not reset the external references, in case we are reloading a
-- project, since we want to preserve the current environment. But we
-- still need to ensure that the external references are properly
-- initialized.
Prj.Ext.Initialize (Self.External);
Self.Flags := Flags;
end Initialize;
-------------------------
-- Initialize_And_Copy --
-------------------------
procedure Initialize_And_Copy
(Self : out Environment;
Copy_From : Environment)
is
begin
Self.Flags := Copy_From.Flags;
Prj.Ext.Initialize (Self.External, Copy_From => Copy_From.External);
Prj.Env.Copy (From => Copy_From.Project_Path, To => Self.Project_Path);
end Initialize_And_Copy;
----------
-- Free --
----------
procedure Free (Self : in out Environment) is
begin
Prj.Ext.Free (Self.External);
Free (Self.Project_Path);
end Free;
----------
-- Free --
----------
procedure Free (Proj : in out Project_Node_Tree_Ref) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Project_Node_Tree_Data, Project_Node_Tree_Ref);
begin
if Proj /= null then
Project_Node_Table.Free (Proj.Project_Nodes);
Projects_Htable.Reset (Proj.Projects_HT);
Unchecked_Free (Proj);
end if;
end Free;
-------------------------------
-- Is_Followed_By_Empty_Line --
-------------------------------
function Is_Followed_By_Empty_Line
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Boolean
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Comment);
return In_Tree.Project_Nodes.Table (Node).Flag2;
end Is_Followed_By_Empty_Line;
----------------------
-- Is_Extending_All --
----------------------
function Is_Extending_All
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Boolean
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Project
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause));
return In_Tree.Project_Nodes.Table (Node).Flag2;
end Is_Extending_All;
-------------------------
-- Is_Not_Last_In_List --
-------------------------
function Is_Not_Last_In_List
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Boolean
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause);
return In_Tree.Project_Nodes.Table (Node).Flag1;
end Is_Not_Last_In_List;
-------------------------------------
-- Imported_Or_Extended_Project_Of --
-------------------------------------
function Imported_Or_Extended_Project_Of
(Project : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
With_Name : Name_Id) return Project_Node_Id
is
With_Clause : Project_Node_Id;
Result : Project_Node_Id := Empty_Node;
begin
-- First check all the imported projects
With_Clause := First_With_Clause_Of (Project, In_Tree);
while Present (With_Clause) loop
-- Only non limited imported project may be used as prefix of
-- variables or attributes.
Result := Non_Limited_Project_Node_Of (With_Clause, In_Tree);
while Present (Result) loop
if Name_Of (Result, In_Tree) = With_Name then
return Result;
end if;
Result :=
Extended_Project_Of
(Project_Declaration_Of (Result, In_Tree), In_Tree);
end loop;
With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
end loop;
-- If it is not an imported project, it might be an extended project
if No (With_Clause) then
Result := Project;
loop
Result :=
Extended_Project_Of
(Project_Declaration_Of (Result, In_Tree), In_Tree);
exit when No (Result)
or else Name_Of (Result, In_Tree) = With_Name;
end loop;
end if;
return Result;
end Imported_Or_Extended_Project_Of;
-------------
-- Kind_Of --
-------------
function Kind_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Kind
is
begin
pragma Assert (Present (Node));
return In_Tree.Project_Nodes.Table (Node).Kind;
end Kind_Of;
-----------------
-- Location_Of --
-----------------
function Location_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Source_Ptr
is
begin
pragma Assert (Present (Node));
return In_Tree.Project_Nodes.Table (Node).Location;
end Location_Of;
-------------
-- Name_Of --
-------------
function Name_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Name_Id
is
begin
pragma Assert (Present (Node));
return In_Tree.Project_Nodes.Table (Node).Name;
end Name_Of;
--------------------
-- Next_Case_Item --
--------------------
function Next_Case_Item
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item);
return In_Tree.Project_Nodes.Table (Node).Field3;
end Next_Case_Item;
------------------
-- Next_Comment --
------------------
function Next_Comment
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Comment);
return In_Tree.Project_Nodes.Table (Node).Comments;
end Next_Comment;
---------------------------
-- Next_Declarative_Item --
---------------------------
function Next_Declarative_Item
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item);
return In_Tree.Project_Nodes.Table (Node).Field2;
end Next_Declarative_Item;
-----------------------------
-- Next_Expression_In_List --
-----------------------------
function Next_Expression_In_List
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Expression);
return In_Tree.Project_Nodes.Table (Node).Field2;
end Next_Expression_In_List;
-------------------------
-- Next_Literal_String --
-------------------------
function Next_Literal_String
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref)
return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String);
return In_Tree.Project_Nodes.Table (Node).Field1;
end Next_Literal_String;
-----------------------------
-- Next_Package_In_Project --
-----------------------------
function Next_Package_In_Project
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration);
return In_Tree.Project_Nodes.Table (Node).Field3;
end Next_Package_In_Project;
----------------------
-- Next_String_Type --
----------------------
function Next_String_Type
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref)
return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind =
N_String_Type_Declaration);
return In_Tree.Project_Nodes.Table (Node).Field2;
end Next_String_Type;
---------------
-- Next_Term --
---------------
function Next_Term
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term);
return In_Tree.Project_Nodes.Table (Node).Field2;
end Next_Term;
-------------------
-- Next_Variable --
-------------------
function Next_Variable
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind =
N_Typed_Variable_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind =
N_Variable_Declaration));
return In_Tree.Project_Nodes.Table (Node).Field3;
end Next_Variable;
-------------------------
-- Next_With_Clause_Of --
-------------------------
function Next_With_Clause_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause);
return In_Tree.Project_Nodes.Table (Node).Field2;
end Next_With_Clause_Of;
--------
-- No --
--------
function No (Node : Project_Node_Id) return Boolean is
begin
return Node = Empty_Node;
end No;
---------------------------------
-- Non_Limited_Project_Node_Of --
---------------------------------
function Non_Limited_Project_Node_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause));
return In_Tree.Project_Nodes.Table (Node).Field3;
end Non_Limited_Project_Node_Of;
-------------------
-- Package_Id_Of --
-------------------
function Package_Id_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Package_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration);
return In_Tree.Project_Nodes.Table (Node).Pkg_Id;
end Package_Id_Of;
---------------------
-- Package_Node_Of --
---------------------
function Package_Node_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
return In_Tree.Project_Nodes.Table (Node).Field2;
end Package_Node_Of;
------------------
-- Path_Name_Of --
------------------
function Path_Name_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Path_Name_Type
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Project
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause));
return In_Tree.Project_Nodes.Table (Node).Path_Name;
end Path_Name_Of;
-------------
-- Present --
-------------
function Present (Node : Project_Node_Id) return Boolean is
begin
return Node /= Empty_Node;
end Present;
----------------------------
-- Project_Declaration_Of --
----------------------------
function Project_Declaration_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
return In_Tree.Project_Nodes.Table (Node).Field2;
end Project_Declaration_Of;
--------------------------
-- Project_Qualifier_Of --
--------------------------
function Project_Qualifier_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Qualifier
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
return In_Tree.Project_Nodes.Table (Node).Qualifier;
end Project_Qualifier_Of;
-----------------------
-- Parent_Project_Of --
-----------------------
function Parent_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
return In_Tree.Project_Nodes.Table (Node).Field4;
end Parent_Project_Of;
-------------------------------------------
-- Project_File_Includes_Unkept_Comments --
-------------------------------------------
function Project_File_Includes_Unkept_Comments
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Boolean
is
Declaration : constant Project_Node_Id :=
Project_Declaration_Of (Node, In_Tree);
begin
return In_Tree.Project_Nodes.Table (Declaration).Flag1;
end Project_File_Includes_Unkept_Comments;
---------------------
-- Project_Node_Of --
---------------------
function Project_Node_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
return In_Tree.Project_Nodes.Table (Node).Field1;
end Project_Node_Of;
-----------------------------------
-- Project_Of_Renamed_Package_Of --
-----------------------------------
function Project_Of_Renamed_Package_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration);
return In_Tree.Project_Nodes.Table (Node).Field1;
end Project_Of_Renamed_Package_Of;
--------------------------
-- Remove_Next_End_Node --
--------------------------
procedure Remove_Next_End_Node is
begin
Next_End_Nodes.Decrement_Last;
end Remove_Next_End_Node;
-----------------
-- Reset_State --
-----------------
procedure Reset_State is
begin
End_Of_Line_Node := Empty_Node;
Previous_Line_Node := Empty_Node;
Previous_End_Node := Empty_Node;
Unkept_Comments := False;
Comments.Set_Last (0);
end Reset_State;
----------------------
-- Restore_And_Free --
----------------------
procedure Restore_And_Free (S : in out Comment_State) is
procedure Unchecked_Free is new
Ada.Unchecked_Deallocation (Comment_Array, Comments_Ptr);
begin
End_Of_Line_Node := S.End_Of_Line_Node;
Previous_Line_Node := S.Previous_Line_Node;
Previous_End_Node := S.Previous_End_Node;
Next_End_Nodes.Set_Last (0);
Unkept_Comments := S.Unkept_Comments;
Comments.Set_Last (0);
for J in S.Comments'Range loop
Comments.Increment_Last;
Comments.Table (Comments.Last) := S.Comments (J);
end loop;
Unchecked_Free (S.Comments);
end Restore_And_Free;
----------
-- Save --
----------
procedure Save (S : out Comment_State) is
Cmts : constant Comments_Ptr := new Comment_Array (1 .. Comments.Last);
begin
for J in 1 .. Comments.Last loop
Cmts (J) := Comments.Table (J);
end loop;
S :=
(End_Of_Line_Node => End_Of_Line_Node,
Previous_Line_Node => Previous_Line_Node,
Previous_End_Node => Previous_End_Node,
Unkept_Comments => Unkept_Comments,
Comments => Cmts);
end Save;
----------
-- Scan --
----------
procedure Scan (In_Tree : Project_Node_Tree_Ref) is
Empty_Line : Boolean := False;
begin
-- If there are comments, then they will not be kept. Set the flag and
-- clear the comments.
if Comments.Last > 0 then
Unkept_Comments := True;
Comments.Set_Last (0);
end if;
-- Loop until a token other that End_Of_Line or Comment is found
loop
Prj.Err.Scanner.Scan;
case Token is
when Tok_End_Of_Line =>
if Prev_Token = Tok_End_Of_Line then
Empty_Line := True;
if Comments.Last > 0 then
Comments.Table (Comments.Last).Is_Followed_By_Empty_Line
:= True;
end if;
end if;
when Tok_Comment =>
-- If this is a line comment, add it to the comment table
if Prev_Token = Tok_End_Of_Line
or else Prev_Token = No_Token
then
Comments.Increment_Last;
Comments.Table (Comments.Last) :=
(Value => Comment_Id,
Follows_Empty_Line => Empty_Line,
Is_Followed_By_Empty_Line => False);
-- Otherwise, it is an end of line comment. If there is an
-- end of line node specified, associate the comment with
-- this node.
elsif Present (End_Of_Line_Node) then
declare
Zones : constant Project_Node_Id :=
Comment_Zones_Of (End_Of_Line_Node, In_Tree);
begin
In_Tree.Project_Nodes.Table (Zones).Value := Comment_Id;
end;
-- Otherwise, this end of line node cannot be kept
else
Unkept_Comments := True;
Comments.Set_Last (0);
end if;
Empty_Line := False;
when others =>
-- If there are comments, where the first comment is not
-- following an empty line, put the initial uninterrupted
-- comment zone with the node of the preceding line (either
-- a Previous_Line or a Previous_End node), if any.
if Comments.Last > 0 and then
not Comments.Table (1).Follows_Empty_Line
then
if Present (Previous_Line_Node) then
Add_Comments
(To => Previous_Line_Node,
Where => After,
In_Tree => In_Tree);
elsif Present (Previous_End_Node) then
Add_Comments
(To => Previous_End_Node,
Where => After_End,
In_Tree => In_Tree);
end if;
end if;
-- If there are still comments and the token is "end", then
-- put these comments with the Next_End node, if any;
-- otherwise, these comments cannot be kept. Always clear
-- the comments.
if Comments.Last > 0 and then Token = Tok_End then
if Next_End_Nodes.Last > 0 then
Add_Comments
(To => Next_End_Nodes.Table (Next_End_Nodes.Last),
Where => Before_End,
In_Tree => In_Tree);
else
Unkept_Comments := True;
end if;
Comments.Set_Last (0);
end if;
-- Reset the End_Of_Line, Previous_Line and Previous_End nodes
-- so that they are not used again.
End_Of_Line_Node := Empty_Node;
Previous_Line_Node := Empty_Node;
Previous_End_Node := Empty_Node;
-- And return
exit;
end case;
end loop;
end Scan;
------------------------------------
-- Set_Associative_Array_Index_Of --
------------------------------------
procedure Set_Associative_Array_Index_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Name_Id)
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
In_Tree.Project_Nodes.Table (Node).Value := To;
end Set_Associative_Array_Index_Of;
--------------------------------
-- Set_Associative_Package_Of --
--------------------------------
procedure Set_Associative_Package_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration);
In_Tree.Project_Nodes.Table (Node).Field3 := To;
end Set_Associative_Package_Of;
--------------------------------
-- Set_Associative_Project_Of --
--------------------------------
procedure Set_Associative_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind =
N_Attribute_Declaration));
In_Tree.Project_Nodes.Table (Node).Field2 := To;
end Set_Associative_Project_Of;
--------------------------
-- Set_Case_Insensitive --
--------------------------
procedure Set_Case_Insensitive
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Boolean)
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
In_Tree.Project_Nodes.Table (Node).Flag1 := To;
end Set_Case_Insensitive;
------------------------------------
-- Set_Case_Variable_Reference_Of --
------------------------------------
procedure Set_Case_Variable_Reference_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction);
In_Tree.Project_Nodes.Table (Node).Field1 := To;
end Set_Case_Variable_Reference_Of;
---------------------------
-- Set_Current_Item_Node --
---------------------------
procedure Set_Current_Item_Node
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item);
In_Tree.Project_Nodes.Table (Node).Field1 := To;
end Set_Current_Item_Node;
----------------------
-- Set_Current_Term --
----------------------
procedure Set_Current_Term
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Term);
In_Tree.Project_Nodes.Table (Node).Field1 := To;
end Set_Current_Term;
----------------------
-- Set_Directory_Of --
----------------------
procedure Set_Directory_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Path_Name_Type)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
In_Tree.Project_Nodes.Table (Node).Directory := To;
end Set_Directory_Of;
---------------------
-- Set_End_Of_Line --
---------------------
procedure Set_End_Of_Line (To : Project_Node_Id) is
begin
End_Of_Line_Node := To;
end Set_End_Of_Line;
----------------------------
-- Set_Expression_Kind_Of --
----------------------------
procedure Set_Expression_Kind_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Variable_Kind)
is
begin
pragma Assert
(Present (Node)
and then -- should use Nkind_In here ??? why not???
(In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind =
N_Typed_Variable_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Expression
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Term
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value));
In_Tree.Project_Nodes.Table (Node).Expr_Kind := To;
end Set_Expression_Kind_Of;
-----------------------
-- Set_Expression_Of --
-----------------------
procedure Set_Expression_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind =
N_Attribute_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind =
N_Typed_Variable_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind =
N_Variable_Declaration));
In_Tree.Project_Nodes.Table (Node).Field1 := To;
end Set_Expression_Of;
-------------------------------
-- Set_External_Reference_Of --
-------------------------------
procedure Set_External_Reference_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value);
In_Tree.Project_Nodes.Table (Node).Field1 := To;
end Set_External_Reference_Of;
-----------------------------
-- Set_External_Default_Of --
-----------------------------
procedure Set_External_Default_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value);
In_Tree.Project_Nodes.Table (Node).Field2 := To;
end Set_External_Default_Of;
----------------------------
-- Set_First_Case_Item_Of --
----------------------------
procedure Set_First_Case_Item_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction);
In_Tree.Project_Nodes.Table (Node).Field2 := To;
end Set_First_Case_Item_Of;
-------------------------
-- Set_First_Choice_Of --
-------------------------
procedure Set_First_Choice_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item);
In_Tree.Project_Nodes.Table (Node).Field1 := To;
end Set_First_Choice_Of;
-----------------------------
-- Set_First_Comment_After --
-----------------------------
procedure Set_First_Comment_After
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree);
begin
In_Tree.Project_Nodes.Table (Zone).Field2 := To;
end Set_First_Comment_After;
---------------------------------
-- Set_First_Comment_After_End --
---------------------------------
procedure Set_First_Comment_After_End
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree);
begin
In_Tree.Project_Nodes.Table (Zone).Comments := To;
end Set_First_Comment_After_End;
------------------------------
-- Set_First_Comment_Before --
------------------------------
procedure Set_First_Comment_Before
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree);
begin
In_Tree.Project_Nodes.Table (Zone).Field1 := To;
end Set_First_Comment_Before;
----------------------------------
-- Set_First_Comment_Before_End --
----------------------------------
procedure Set_First_Comment_Before_End
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree);
begin
In_Tree.Project_Nodes.Table (Zone).Field2 := To;
end Set_First_Comment_Before_End;
------------------------
-- Set_Next_Case_Item --
------------------------
procedure Set_Next_Case_Item
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item);
In_Tree.Project_Nodes.Table (Node).Field3 := To;
end Set_Next_Case_Item;
----------------------
-- Set_Next_Comment --
----------------------
procedure Set_Next_Comment
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Comment);
In_Tree.Project_Nodes.Table (Node).Comments := To;
end Set_Next_Comment;
-----------------------------------
-- Set_First_Declarative_Item_Of --
-----------------------------------
procedure Set_First_Declarative_Item_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration));
if In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration then
In_Tree.Project_Nodes.Table (Node).Field1 := To;
else
In_Tree.Project_Nodes.Table (Node).Field2 := To;
end if;
end Set_First_Declarative_Item_Of;
----------------------------------
-- Set_First_Expression_In_List --
----------------------------------
procedure Set_First_Expression_In_List
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String_List);
In_Tree.Project_Nodes.Table (Node).Field1 := To;
end Set_First_Expression_In_List;
------------------------------
-- Set_First_Literal_String --
------------------------------
procedure Set_First_Literal_String
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind =
N_String_Type_Declaration);
In_Tree.Project_Nodes.Table (Node).Field1 := To;
end Set_First_Literal_String;
--------------------------
-- Set_First_Package_Of --
--------------------------
procedure Set_First_Package_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Package_Declaration_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
In_Tree.Project_Nodes.Table (Node).Packages := To;
end Set_First_Package_Of;
------------------------------
-- Set_First_String_Type_Of --
------------------------------
procedure Set_First_String_Type_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
In_Tree.Project_Nodes.Table (Node).Field3 := To;
end Set_First_String_Type_Of;
--------------------
-- Set_First_Term --
--------------------
procedure Set_First_Term
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Expression);
In_Tree.Project_Nodes.Table (Node).Field1 := To;
end Set_First_Term;
---------------------------
-- Set_First_Variable_Of --
---------------------------
procedure Set_First_Variable_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Variable_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Project
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration));
In_Tree.Project_Nodes.Table (Node).Variables := To;
end Set_First_Variable_Of;
------------------------------
-- Set_First_With_Clause_Of --
------------------------------
procedure Set_First_With_Clause_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
In_Tree.Project_Nodes.Table (Node).Field1 := To;
end Set_First_With_Clause_Of;
--------------------------
-- Set_Is_Extending_All --
--------------------------
procedure Set_Is_Extending_All
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref)
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Project
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause));
In_Tree.Project_Nodes.Table (Node).Flag2 := True;
end Set_Is_Extending_All;
-----------------------------
-- Set_Is_Not_Last_In_List --
-----------------------------
procedure Set_Is_Not_Last_In_List
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref)
is
begin
pragma Assert
(Present (Node)
and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause);
In_Tree.Project_Nodes.Table (Node).Flag1 := True;
end Set_Is_Not_Last_In_List;
-----------------
-- Set_Kind_Of --
-----------------
procedure Set_Kind_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Kind)
is
begin
pragma Assert (Present (Node));
In_Tree.Project_Nodes.Table (Node).Kind := To;
end Set_Kind_Of;
---------------------
-- Set_Location_Of --
---------------------
procedure Set_Location_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Source_Ptr)
is
begin
pragma Assert (Present (Node));
In_Tree.Project_Nodes.Table (Node).Location := To;
end Set_Location_Of;
-----------------------------
-- Set_Extended_Project_Of --
-----------------------------
procedure Set_Extended_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration);
In_Tree.Project_Nodes.Table (Node).Field2 := To;
end Set_Extended_Project_Of;
----------------------------------
-- Set_Extended_Project_Path_Of --
----------------------------------
procedure Set_Extended_Project_Path_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Path_Name_Type)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
In_Tree.Project_Nodes.Table (Node).Value := Name_Id (To);
end Set_Extended_Project_Path_Of;
------------------------------
-- Set_Extending_Project_Of --
------------------------------
procedure Set_Extending_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration);
In_Tree.Project_Nodes.Table (Node).Field3 := To;
end Set_Extending_Project_Of;
-----------------
-- Set_Name_Of --
-----------------
procedure Set_Name_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Name_Id)
is
begin
pragma Assert (Present (Node));
In_Tree.Project_Nodes.Table (Node).Name := To;
end Set_Name_Of;
-------------------------------
-- Set_Next_Declarative_Item --
-------------------------------
procedure Set_Next_Declarative_Item
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item);
In_Tree.Project_Nodes.Table (Node).Field2 := To;
end Set_Next_Declarative_Item;
-----------------------
-- Set_Next_End_Node --
-----------------------
procedure Set_Next_End_Node (To : Project_Node_Id) is
begin
Next_End_Nodes.Increment_Last;
Next_End_Nodes.Table (Next_End_Nodes.Last) := To;
end Set_Next_End_Node;
---------------------------------
-- Set_Next_Expression_In_List --
---------------------------------
procedure Set_Next_Expression_In_List
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Expression);
In_Tree.Project_Nodes.Table (Node).Field2 := To;
end Set_Next_Expression_In_List;
-----------------------------
-- Set_Next_Literal_String --
-----------------------------
procedure Set_Next_Literal_String
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String);
In_Tree.Project_Nodes.Table (Node).Field1 := To;
end Set_Next_Literal_String;
---------------------------------
-- Set_Next_Package_In_Project --
---------------------------------
procedure Set_Next_Package_In_Project
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration);
In_Tree.Project_Nodes.Table (Node).Field3 := To;
end Set_Next_Package_In_Project;
--------------------------
-- Set_Next_String_Type --
--------------------------
procedure Set_Next_String_Type
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind =
N_String_Type_Declaration);
In_Tree.Project_Nodes.Table (Node).Field2 := To;
end Set_Next_String_Type;
-------------------
-- Set_Next_Term --
-------------------
procedure Set_Next_Term
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Term);
In_Tree.Project_Nodes.Table (Node).Field2 := To;
end Set_Next_Term;
-----------------------
-- Set_Next_Variable --
-----------------------
procedure Set_Next_Variable
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind =
N_Typed_Variable_Declaration
or else
In_Tree.Project_Nodes.Table (Node).Kind =
N_Variable_Declaration));
In_Tree.Project_Nodes.Table (Node).Field3 := To;
end Set_Next_Variable;
-----------------------------
-- Set_Next_With_Clause_Of --
-----------------------------
procedure Set_Next_With_Clause_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause);
In_Tree.Project_Nodes.Table (Node).Field2 := To;
end Set_Next_With_Clause_Of;
-----------------------
-- Set_Package_Id_Of --
-----------------------
procedure Set_Package_Id_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Package_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration);
In_Tree.Project_Nodes.Table (Node).Pkg_Id := To;
end Set_Package_Id_Of;
-------------------------
-- Set_Package_Node_Of --
-------------------------
procedure Set_Package_Node_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
In_Tree.Project_Nodes.Table (Node).Field2 := To;
end Set_Package_Node_Of;
----------------------
-- Set_Path_Name_Of --
----------------------
procedure Set_Path_Name_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Path_Name_Type)
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Project
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause));
In_Tree.Project_Nodes.Table (Node).Path_Name := To;
end Set_Path_Name_Of;
---------------------------
-- Set_Previous_End_Node --
---------------------------
procedure Set_Previous_End_Node (To : Project_Node_Id) is
begin
Previous_End_Node := To;
end Set_Previous_End_Node;
----------------------------
-- Set_Previous_Line_Node --
----------------------------
procedure Set_Previous_Line_Node (To : Project_Node_Id) is
begin
Previous_Line_Node := To;
end Set_Previous_Line_Node;
--------------------------------
-- Set_Project_Declaration_Of --
--------------------------------
procedure Set_Project_Declaration_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
In_Tree.Project_Nodes.Table (Node).Field2 := To;
end Set_Project_Declaration_Of;
------------------------------
-- Set_Project_Qualifier_Of --
------------------------------
procedure Set_Project_Qualifier_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Qualifier)
is
begin
pragma Assert
(Present (Node)
and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
In_Tree.Project_Nodes.Table (Node).Qualifier := To;
end Set_Project_Qualifier_Of;
---------------------------
-- Set_Parent_Project_Of --
---------------------------
procedure Set_Parent_Project_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
In_Tree.Project_Nodes.Table (Node).Field4 := To;
end Set_Parent_Project_Of;
-----------------------------------------------
-- Set_Project_File_Includes_Unkept_Comments --
-----------------------------------------------
procedure Set_Project_File_Includes_Unkept_Comments
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Boolean)
is
Declaration : constant Project_Node_Id :=
Project_Declaration_Of (Node, In_Tree);
begin
In_Tree.Project_Nodes.Table (Declaration).Flag1 := To;
end Set_Project_File_Includes_Unkept_Comments;
-------------------------
-- Set_Project_Node_Of --
-------------------------
procedure Set_Project_Node_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id;
Limited_With : Boolean := False)
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
In_Tree.Project_Nodes.Table (Node).Field1 := To;
if In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause
and then not Limited_With
then
In_Tree.Project_Nodes.Table (Node).Field3 := To;
end if;
end Set_Project_Node_Of;
---------------------------------------
-- Set_Project_Of_Renamed_Package_Of --
---------------------------------------
procedure Set_Project_Of_Renamed_Package_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration);
In_Tree.Project_Nodes.Table (Node).Field1 := To;
end Set_Project_Of_Renamed_Package_Of;
-------------------------
-- Set_Source_Index_Of --
-------------------------
procedure Set_Source_Index_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Int)
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String
or else
In_Tree.Project_Nodes.Table (Node).Kind =
N_Attribute_Declaration));
In_Tree.Project_Nodes.Table (Node).Src_Index := To;
end Set_Source_Index_Of;
------------------------
-- Set_String_Type_Of --
------------------------
procedure Set_String_Type_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Project_Node_Id)
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind =
N_Variable_Reference
or else
In_Tree.Project_Nodes.Table (Node).Kind =
N_Typed_Variable_Declaration)
and then
In_Tree.Project_Nodes.Table (To).Kind = N_String_Type_Declaration);
if In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference then
In_Tree.Project_Nodes.Table (Node).Field3 := To;
else
In_Tree.Project_Nodes.Table (Node).Field2 := To;
end if;
end Set_String_Type_Of;
-------------------------
-- Set_String_Value_Of --
-------------------------
procedure Set_String_Value_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
To : Name_Id)
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Comment
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String));
In_Tree.Project_Nodes.Table (Node).Value := To;
end Set_String_Value_Of;
---------------------
-- Source_Index_Of --
---------------------
function Source_Index_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Int
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String
or else
In_Tree.Project_Nodes.Table (Node).Kind =
N_Attribute_Declaration));
return In_Tree.Project_Nodes.Table (Node).Src_Index;
end Source_Index_Of;
--------------------
-- String_Type_Of --
--------------------
function String_Type_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind =
N_Variable_Reference
or else
In_Tree.Project_Nodes.Table (Node).Kind =
N_Typed_Variable_Declaration));
if In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference then
return In_Tree.Project_Nodes.Table (Node).Field3;
else
return In_Tree.Project_Nodes.Table (Node).Field2;
end if;
end String_Type_Of;
---------------------
-- String_Value_Of --
---------------------
function String_Value_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref) return Name_Id
is
begin
pragma Assert
(Present (Node)
and then
(In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Comment
or else
In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String));
return In_Tree.Project_Nodes.Table (Node).Value;
end String_Value_Of;
--------------------
-- Value_Is_Valid --
--------------------
function Value_Is_Valid
(For_Typed_Variable : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
Value : Name_Id) return Boolean
is
begin
pragma Assert
(Present (For_Typed_Variable)
and then
(In_Tree.Project_Nodes.Table (For_Typed_Variable).Kind =
N_Typed_Variable_Declaration));
declare
Current_String : Project_Node_Id :=
First_Literal_String
(String_Type_Of (For_Typed_Variable, In_Tree),
In_Tree);
begin
while Present (Current_String)
and then
String_Value_Of (Current_String, In_Tree) /= Value
loop
Current_String :=
Next_Literal_String (Current_String, In_Tree);
end loop;
return Present (Current_String);
end;
end Value_Is_Valid;
-------------------------------
-- There_Are_Unkept_Comments --
-------------------------------
function There_Are_Unkept_Comments return Boolean is
begin
return Unkept_Comments;
end There_Are_Unkept_Comments;
--------------------
-- Create_Project --
--------------------
function Create_Project
(In_Tree : Project_Node_Tree_Ref;
Name : Name_Id;
Full_Path : Path_Name_Type;
Is_Config_File : Boolean := False) return Project_Node_Id
is
Project : Project_Node_Id;
Qualifier : Project_Qualifier := Unspecified;
begin
Project := Default_Project_Node (In_Tree, N_Project);
Set_Name_Of (Project, In_Tree, Name);
Set_Directory_Of
(Project, In_Tree,
Path_Name_Type (Get_Directory (File_Name_Type (Full_Path))));
Set_Path_Name_Of (Project, In_Tree, Full_Path);
Set_Project_Declaration_Of
(Project, In_Tree,
Default_Project_Node (In_Tree, N_Project_Declaration));
if Is_Config_File then
Qualifier := Configuration;
end if;
if not Is_Config_File then
Prj.Tree.Tree_Private_Part.Projects_Htable.Set
(In_Tree.Projects_HT,
Name,
Prj.Tree.Tree_Private_Part.Project_Name_And_Node'
(Name => Name,
Display_Name => Name,
Resolved_Path => No_Path,
Node => Project,
Extended => False,
From_Extended => False,
Proj_Qualifier => Qualifier));
end if;
return Project;
end Create_Project;
----------------
-- Add_At_End --
----------------
procedure Add_At_End
(Tree : Project_Node_Tree_Ref;
Parent : Project_Node_Id;
Expr : Project_Node_Id;
Add_Before_First_Pkg : Boolean := False;
Add_Before_First_Case : Boolean := False)
is
Real_Parent : Project_Node_Id;
New_Decl, Decl, Next : Project_Node_Id;
Last, L : Project_Node_Id;
begin
if Kind_Of (Expr, Tree) /= N_Declarative_Item then
New_Decl := Default_Project_Node (Tree, N_Declarative_Item);
Set_Current_Item_Node (New_Decl, Tree, Expr);
else
New_Decl := Expr;
end if;
if Kind_Of (Parent, Tree) = N_Project then
Real_Parent := Project_Declaration_Of (Parent, Tree);
else
Real_Parent := Parent;
end if;
Decl := First_Declarative_Item_Of (Real_Parent, Tree);
if Decl = Empty_Node then
Set_First_Declarative_Item_Of (Real_Parent, Tree, New_Decl);
else
loop
Next := Next_Declarative_Item (Decl, Tree);
exit when Next = Empty_Node
or else
(Add_Before_First_Pkg
and then Kind_Of (Current_Item_Node (Next, Tree), Tree) =
N_Package_Declaration)
or else
(Add_Before_First_Case
and then Kind_Of (Current_Item_Node (Next, Tree), Tree) =
N_Case_Construction);
Decl := Next;
end loop;
-- In case Expr is in fact a range of declarative items
Last := New_Decl;
loop
L := Next_Declarative_Item (Last, Tree);
exit when L = Empty_Node;
Last := L;
end loop;
-- In case Expr is in fact a range of declarative items
Last := New_Decl;
loop
L := Next_Declarative_Item (Last, Tree);
exit when L = Empty_Node;
Last := L;
end loop;
Set_Next_Declarative_Item (Last, Tree, Next);
Set_Next_Declarative_Item (Decl, Tree, New_Decl);
end if;
end Add_At_End;
---------------------------
-- Create_Literal_String --
---------------------------
function Create_Literal_String
(Str : Namet.Name_Id;
Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
Node : Project_Node_Id;
begin
Node := Default_Project_Node (Tree, N_Literal_String, Prj.Single);
Set_Next_Literal_String (Node, Tree, Empty_Node);
Set_String_Value_Of (Node, Tree, Str);
return Node;
end Create_Literal_String;
---------------------------
-- Enclose_In_Expression --
---------------------------
function Enclose_In_Expression
(Node : Project_Node_Id;
Tree : Project_Node_Tree_Ref) return Project_Node_Id
is
Expr : Project_Node_Id;
begin
if Kind_Of (Node, Tree) /= N_Expression then
Expr := Default_Project_Node (Tree, N_Expression, Single);
Set_First_Term
(Expr, Tree, Default_Project_Node (Tree, N_Term, Single));
Set_Current_Term (First_Term (Expr, Tree), Tree, Node);
return Expr;
else
return Node;
end if;
end Enclose_In_Expression;
--------------------
-- Create_Package --
--------------------
function Create_Package
(Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id;
Pkg : String) return Project_Node_Id
is
Pack : Project_Node_Id;
N : Name_Id;
begin
Name_Len := Pkg'Length;
Name_Buffer (1 .. Name_Len) := Pkg;
N := Name_Find;
-- Check if the package already exists
Pack := First_Package_Of (Project, Tree);
while Pack /= Empty_Node loop
if Prj.Tree.Name_Of (Pack, Tree) = N then
return Pack;
end if;
Pack := Next_Package_In_Project (Pack, Tree);
end loop;
-- Create the package and add it to the declarative item
Pack := Default_Project_Node (Tree, N_Package_Declaration);
Set_Name_Of (Pack, Tree, N);
-- Find the correct package id to use
Set_Package_Id_Of (Pack, Tree, Package_Node_Id_Of (N));
-- Add it to the list of packages
Set_Next_Package_In_Project
(Pack, Tree, First_Package_Of (Project, Tree));
Set_First_Package_Of (Project, Tree, Pack);
Add_At_End (Tree, Project_Declaration_Of (Project, Tree), Pack);
return Pack;
end Create_Package;
----------------------
-- Create_Attribute --
----------------------
function Create_Attribute
(Tree : Project_Node_Tree_Ref;
Prj_Or_Pkg : Project_Node_Id;
Name : Name_Id;
Index_Name : Name_Id := No_Name;
Kind : Variable_Kind := List;
At_Index : Integer := 0;
Value : Project_Node_Id := Empty_Node) return Project_Node_Id
is
Node : constant Project_Node_Id :=
Default_Project_Node (Tree, N_Attribute_Declaration, Kind);
Case_Insensitive : Boolean;
Pkg : Package_Node_Id;
Start_At : Attribute_Node_Id;
Expr : Project_Node_Id;
begin
Set_Name_Of (Node, Tree, Name);
if Index_Name /= No_Name then
Set_Associative_Array_Index_Of (Node, Tree, Index_Name);
end if;
if Prj_Or_Pkg /= Empty_Node then
Add_At_End (Tree, Prj_Or_Pkg, Node);
end if;
-- Find out the case sensitivity of the attribute
if Prj_Or_Pkg /= Empty_Node
and then Kind_Of (Prj_Or_Pkg, Tree) = N_Package_Declaration
then
Pkg := Prj.Attr.Package_Node_Id_Of (Name_Of (Prj_Or_Pkg, Tree));
Start_At := First_Attribute_Of (Pkg);
else
Start_At := Attribute_First;
end if;
Start_At := Attribute_Node_Id_Of (Name, Start_At);
Case_Insensitive :=
Attribute_Kind_Of (Start_At) = Case_Insensitive_Associative_Array;
Tree.Project_Nodes.Table (Node).Flag1 := Case_Insensitive;
if At_Index /= 0 then
if Attribute_Kind_Of (Start_At) =
Optional_Index_Associative_Array
or else Attribute_Kind_Of (Start_At) =
Optional_Index_Case_Insensitive_Associative_Array
then
-- Results in: for Name ("index" at index) use "value";
-- This is currently only used for executables.
Set_Source_Index_Of (Node, Tree, To => Int (At_Index));
else
-- Results in: for Name ("index") use "value" at index;
-- ??? This limitation makes no sense, we should be able to
-- set the source index on an expression.
pragma Assert (Kind_Of (Value, Tree) = N_Literal_String);
Set_Source_Index_Of (Value, Tree, To => Int (At_Index));
end if;
end if;
if Value /= Empty_Node then
Expr := Enclose_In_Expression (Value, Tree);
Set_Expression_Of (Node, Tree, Expr);
end if;
return Node;
end Create_Attribute;
end Prj.Tree;
gprbuild-gpl-2014-src/gnat/fname.adb 0000644 0000767 0000145 00000016366 12323721731 016636 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- F N A M E --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, 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 3, 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. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- and . If the location is within an
-- instantiation, then the instance location is appended, enclosed in
-- square brackets (which can nest if necessary). Note that this routine
-- is used only for internal compiler debugging output purposes (which
-- is why the somewhat cryptic use of brackets is acceptable).
procedure wl (P : Source_Ptr);
pragma Export (Ada, wl);
-- Equivalent to Write_Location (P); Write_Eol; for calls from GDB
procedure Write_Time_Stamp (S : Source_File_Index);
-- Writes time stamp of specified file in YY-MM-DD HH:MM.SS format
procedure Tree_Read;
-- Initializes internal tables from current tree file using the relevant
-- Table.Tree_Read routines.
procedure Tree_Write;
-- Writes out internal tables to current tree file using the relevant
-- Table.Tree_Write routines.
private
pragma Inline (File_Name);
pragma Inline (Full_File_Name);
pragma Inline (File_Type);
pragma Inline (Reference_Name);
pragma Inline (Full_Ref_Name);
pragma Inline (Debug_Source_Name);
pragma Inline (Full_Debug_Name);
pragma Inline (Instance);
pragma Inline (License);
pragma Inline (Num_SRef_Pragmas);
pragma Inline (First_Mapped_Line);
pragma Inline (Source_Text);
pragma Inline (Source_First);
pragma Inline (Source_Last);
pragma Inline (Time_Stamp);
pragma Inline (Source_Checksum);
pragma Inline (Last_Source_Line);
pragma Inline (Keyword_Casing);
pragma Inline (Identifier_Casing);
pragma Inline (Inlined_Call);
pragma Inline (Inlined_Body);
pragma Inline (Template);
pragma Inline (Unit);
pragma Inline (Set_Keyword_Casing);
pragma Inline (Set_Identifier_Casing);
pragma Inline (Last_Source_File);
pragma Inline (Num_Source_Files);
pragma Inline (Num_Source_Lines);
No_Instance_Id : constant Instance_Id := 0;
-------------------------
-- Source_Lines Tables --
-------------------------
type Lines_Table_Type is
array (Physical_Line_Number) of Source_Ptr;
-- Type used for lines table. The entries are indexed by physical line
-- numbers. The values are the starting Source_Ptr values for the start
-- of the corresponding physical line. Note that we make this a bogus
-- big array, sized as required, so that we avoid the use of fat pointers.
type Lines_Table_Ptr is access all Lines_Table_Type;
-- Type used for pointers to line tables
type Logical_Lines_Table_Type is
array (Physical_Line_Number) of Logical_Line_Number;
-- Type used for logical lines table. This table is used if a source
-- reference pragma is present. It is indexed by physical line numbers,
-- and contains the corresponding logical line numbers. An entry that
-- corresponds to a source reference pragma is set to No_Line_Number.
-- Note that we make this a bogus big array, sized as required, so that
-- we avoid the use of fat pointers.
type Logical_Lines_Table_Ptr is access all Logical_Lines_Table_Type;
-- Type used for pointers to logical line tables
-----------------------
-- Source_File Table --
-----------------------
-- See earlier descriptions for meanings of public fields
type Source_File_Record is record
File_Name : File_Name_Type;
Reference_Name : File_Name_Type;
Debug_Source_Name : File_Name_Type;
Full_Debug_Name : File_Name_Type;
Full_File_Name : File_Name_Type;
Full_Ref_Name : File_Name_Type;
Instance : Instance_Id;
Num_SRef_Pragmas : Nat;
First_Mapped_Line : Logical_Line_Number;
Source_Text : Source_Buffer_Ptr;
Source_First : Source_Ptr;
Source_Last : Source_Ptr;
Source_Checksum : Word;
Last_Source_Line : Physical_Line_Number;
Template : Source_File_Index;
Unit : Unit_Number_Type;
Time_Stamp : Time_Stamp_Type;
File_Type : Type_Of_File;
Inlined_Call : Source_Ptr;
Inlined_Body : Boolean;
License : License_Type;
Keyword_Casing : Casing_Type;
Identifier_Casing : Casing_Type;
-- The following fields are for internal use only (i.e. only in the
-- body of Sinput or its children, with no direct access by clients).
Sloc_Adjust : Source_Ptr;
-- A value to be added to Sloc values for this file to reference the
-- corresponding lines table. This is zero for the non-instantiation
-- case, and set so that the addition references the ultimate template
-- for the instantiation case. See Sinput-L for further details.
Lines_Table : Lines_Table_Ptr;
-- Pointer to lines table for this source. Updated as additional
-- lines are accessed using the Skip_Line_Terminators procedure.
-- Note: the lines table for an instantiation entry refers to the
-- original line numbers of the template see Sinput-L for details.
Logical_Lines_Table : Logical_Lines_Table_Ptr;
-- Pointer to logical lines table for this source. Non-null only if
-- a source reference pragma has been processed. Updated as lines
-- are accessed using the Skip_Line_Terminators procedure.
Lines_Table_Max : Physical_Line_Number;
-- Maximum subscript values for currently allocated Lines_Table
-- and (if present) the allocated Logical_Lines_Table. The value
-- Max_Source_Line gives the maximum used value, this gives the
-- maximum allocated value.
end record;
-- The following representation clause ensures that the above record
-- has no holes. We do this so that when instances of this record are
-- written by Tree_Gen, we do not write uninitialized values to the file.
AS : constant Pos := Standard'Address_Size;
for Source_File_Record use record
File_Name at 0 range 0 .. 31;
Reference_Name at 4 range 0 .. 31;
Debug_Source_Name at 8 range 0 .. 31;
Full_Debug_Name at 12 range 0 .. 31;
Full_File_Name at 16 range 0 .. 31;
Full_Ref_Name at 20 range 0 .. 31;
Instance at 48 range 0 .. 31;
Num_SRef_Pragmas at 24 range 0 .. 31;
First_Mapped_Line at 28 range 0 .. 31;
Source_First at 32 range 0 .. 31;
Source_Last at 36 range 0 .. 31;
Source_Checksum at 40 range 0 .. 31;
Last_Source_Line at 44 range 0 .. 31;
Template at 52 range 0 .. 31;
Unit at 56 range 0 .. 31;
Time_Stamp at 60 range 0 .. 8 * Time_Stamp_Length - 1;
File_Type at 74 range 0 .. 7;
Inlined_Call at 88 range 0 .. 31;
Inlined_Body at 75 range 0 .. 7;
License at 76 range 0 .. 7;
Keyword_Casing at 77 range 0 .. 7;
Identifier_Casing at 78 range 0 .. 15;
Sloc_Adjust at 80 range 0 .. 31;
Lines_Table_Max at 84 range 0 .. 31;
-- The following fields are pointers, so we have to specialize their
-- lengths using pointer size, obtained above as Standard'Address_Size.
Source_Text at 92 range 0 .. AS - 1;
Lines_Table at 92 range AS .. AS * 2 - 1;
Logical_Lines_Table at 92 range AS * 2 .. AS * 3 - 1;
end record;
for Source_File_Record'Size use 92 * 8 + AS * 3;
-- This ensures that we did not leave out any fields
package Source_File is new Table.Table (
Table_Component_Type => Source_File_Record,
Table_Index_Type => Source_File_Index,
Table_Low_Bound => 1,
Table_Initial => Alloc.Source_File_Initial,
Table_Increment => Alloc.Source_File_Increment,
Table_Name => "Source_File");
-- Auxiliary table containing source location of instantiations. Index 0
-- is used for code that does not come from an instance.
package Instances is new Table.Table (
Table_Component_Type => Source_Ptr,
Table_Index_Type => Instance_Id,
Table_Low_Bound => 0,
Table_Initial => Alloc.Source_File_Initial,
Table_Increment => Alloc.Source_File_Increment,
Table_Name => "Instances");
-----------------
-- Subprograms --
-----------------
procedure Alloc_Line_Tables
(S : in out Source_File_Record;
New_Max : Nat);
-- Allocate or reallocate the lines table for the given source file so
-- that it can accommodate at least New_Max lines. Also allocates or
-- reallocates logical lines table if source ref pragmas are present.
procedure Add_Line_Tables_Entry
(S : in out Source_File_Record;
P : Source_Ptr);
-- Increment line table size by one (reallocating the lines table if
-- needed) and set the new entry to contain the value P. Also bumps
-- the Source_Line_Count field. If source reference pragmas are
-- present, also increments logical lines table size by one, and
-- sets new entry.
procedure Trim_Lines_Table (S : Source_File_Index);
-- Set lines table size for entry S in the source file table to
-- correspond to the current value of Num_Source_Lines, releasing
-- any unused storage. This is used by Sinput.L and Sinput.D.
end Sinput;
gprbuild-gpl-2014-src/gnat/csets.ads 0000644 0000767 0000145 00000012264 12323721731 016703 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- C S E T S --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, 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 3, 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. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- = is correct.
-- If it is correct, the external reference is Added.
procedure Reset (Self : External_References);
-- Clear the internal data structure that stores the external references
-- and free any allocated memory.
private
-- Use a Static_HTable, rather than a Simple_HTable
-- The issue is that we need to be able to copy the contents of the table
-- (in Initialize), but this isn't doable for Simple_HTable for which
-- iterators do not return the key.
type Name_To_Name;
type Name_To_Name_Ptr is access all Name_To_Name;
type Name_To_Name is record
Key : Name_Id;
Value : Name_Id;
Source : External_Source;
Next : Name_To_Name_Ptr;
end record;
procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr);
function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr;
function Get_Key (E : Name_To_Name_Ptr) return Name_Id;
package Name_To_Name_HTable is new GNAT.Dynamic_HTables.Static_HTable
(Header_Num => Header_Num,
Element => Name_To_Name,
Elmt_Ptr => Name_To_Name_Ptr,
Null_Ptr => null,
Set_Next => Set_Next,
Next => Next,
Key => Name_Id,
Get_Key => Get_Key,
Hash => Hash,
Equal => "=");
-- General type for htables associating name_id to name_id. This is in
-- particular used to store the values of external references.
type Instance_Access is access all Name_To_Name_HTable.Instance;
type External_References is record
Refs : Instance_Access;
-- External references are stored in this hash table (and manipulated
-- through subprogrames in prj-ext.ads). External references are
-- project-tree specific so that one can load the same tree twice but
-- have two views of it, for instance.
end record;
No_External_Refs : constant External_References := (Refs => null);
end Prj.Ext;
gprbuild-gpl-2014-src/gnat/errout.adb 0000644 0000767 0000145 00000326676 12323721731 017100 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E R R O U T --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Warning: Error messages can be generated during Gigi processing by direct
-- calls to error message routines, so it is essential that the processing
-- in this body be consistent with the requirements for the Gigi processing
-- environment, and that in particular, no disallowed table expansion is
-- allowed to occur.
with Atree; use Atree;
with Casing; use Casing;
with Csets; use Csets;
with Debug; use Debug;
with Einfo; use Einfo;
with Erroutc; use Erroutc;
with Fname; use Fname;
with Gnatvsn; use Gnatvsn;
with Hostparm; use Hostparm;
with Lib; use Lib;
with Opt; use Opt;
with Nlists; use Nlists;
with Output; use Output;
with Scans; use Scans;
with Sem_Aux; use Sem_Aux;
with Sinput; use Sinput;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stylesw; use Stylesw;
with Uname; use Uname;
package body Errout is
Errors_Must_Be_Ignored : Boolean := False;
-- Set to True by procedure Set_Ignore_Errors (True), when calls to error
-- message procedures should be ignored (when parsing irrelevant text in
-- sources being preprocessed).
Finalize_Called : Boolean := False;
-- Set True if the Finalize routine has been called
Warn_On_Instance : Boolean;
-- Flag set true for warning message to be posted on instance
------------------------------------
-- Table of Non-Instance Messages --
------------------------------------
-- This table contains an entry for every error message processed by the
-- Error_Msg routine that is not posted on generic (or inlined) instance.
-- As explained in further detail in the Error_Msg procedure body, this
-- table is used to avoid posting redundant messages on instances.
type NIM_Record is record
Msg : String_Ptr;
Loc : Source_Ptr;
end record;
-- Type used to store text and location of one message
package Non_Instance_Msgs is new Table.Table (
Table_Component_Type => NIM_Record,
Table_Index_Type => Int,
Table_Low_Bound => 1,
Table_Initial => 100,
Table_Increment => 100,
Table_Name => "Non_Instance_Msgs");
-----------------------
-- Local Subprograms --
-----------------------
procedure Error_Msg_Internal
(Msg : String;
Sptr : Source_Ptr;
Optr : Source_Ptr;
Msg_Cont : Boolean);
-- This is the low level routine used to post messages after dealing with
-- the issue of messages placed on instantiations (which get broken up
-- into separate calls in Error_Msg). Sptr is the location on which the
-- flag will be placed in the output. In the case where the flag is on
-- the template, this points directly to the template, not to one of the
-- instantiation copies of the template. Optr is the original location
-- used to flag the error, and this may indeed point to an instantiation
-- copy. So typically we can see Optr pointing to the template location
-- in an instantiation copy when Sptr points to the source location of
-- the actual instantiation (i.e the line with the new). Msg_Cont is
-- set true if this is a continuation message.
function No_Warnings (N : Node_Or_Entity_Id) return Boolean;
-- Determines if warnings should be suppressed for the given node
function OK_Node (N : Node_Id) return Boolean;
-- Determines if a node is an OK node to place an error message on (return
-- True) or if the error message should be suppressed (return False). A
-- message is suppressed if the node already has an error posted on it,
-- or if it refers to an Etype that has an error posted on it, or if
-- it references an Entity that has an error posted on it.
procedure Output_Source_Line
(L : Physical_Line_Number;
Sfile : Source_File_Index;
Errs : Boolean);
-- Outputs text of source line L, in file S, together with preceding line
-- number, as described above for Output_Line_Number. The Errs parameter
-- indicates if there are errors attached to the line, which forces
-- listing on, even in the presence of pragma List (Off).
procedure Set_Msg_Insertion_Column;
-- Handle column number insertion (@ insertion character)
procedure Set_Msg_Insertion_Node;
-- Handle node (name from node) insertion (& insertion character)
procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr);
-- Handle type reference (right brace insertion character). Flag is the
-- location of the flag, which is provided for the internal call to
-- Set_Msg_Insertion_Line_Number,
procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True);
-- Handle unit name insertion ($ insertion character). Depending on Boolean
-- parameter Suffix, (spec) or (body) is appended after the unit name.
procedure Set_Msg_Node (Node : Node_Id);
-- Add the sequence of characters for the name associated with the given
-- node to the current message. For N_Designator, N_Selected_Component,
-- N_Defining_Program_Unit_Name, and N_Expanded_Name, the Prefix is
-- included as well.
procedure Set_Msg_Text (Text : String; Flag : Source_Ptr);
-- Add a sequence of characters to the current message. The characters may
-- be one of the special insertion characters (see documentation in spec).
-- Flag is the location at which the error is to be posted, which is used
-- to determine whether or not the # insertion needs a file name. The
-- variables Msg_Buffer are set on return Msglen.
procedure Set_Posted (N : Node_Id);
-- Sets the Error_Posted flag on the given node, and all its parents that
-- are subexpressions and then on the parent non-subexpression construct
-- that contains the original expression. If that parent is a named
-- association, the flag is further propagated to its parent. This is done
-- in order to guard against cascaded errors. Note that this call has an
-- effect for a serious error only.
procedure Set_Qualification (N : Nat; E : Entity_Id);
-- Outputs up to N levels of qualification for the given entity. For
-- example, the entity A.B.C.D will output B.C. if N = 2.
function Special_Msg_Delete
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id) return Boolean;
-- This function is called from Error_Msg_NEL, passing the message Msg,
-- node N on which the error is to be posted, and the entity or node E
-- to be used for an & insertion in the message if any. The job of this
-- procedure is to test for certain cascaded messages that we would like
-- to suppress. If the message is to be suppressed then we return True.
-- If the message should be generated (the normal case) False is returned.
procedure Unwind_Internal_Type (Ent : in out Entity_Id);
-- This procedure is given an entity id for an internal type, i.e. a type
-- with an internal name. It unwinds the type to try to get to something
-- reasonably printable, generating prefixes like "subtype of", "access
-- to", etc along the way in the buffer. The value in Ent on return is the
-- final name to be printed. Hopefully this is not an internal name, but in
-- some internal name cases, it is an internal name, and has to be printed
-- anyway (although in this case the message has been killed if possible).
-- The global variable Class_Flag is set to True if the resulting entity
-- should have 'Class appended to its name (see Add_Class procedure), and
-- is otherwise unchanged.
procedure VMS_Convert;
-- This procedure has no effect if called when the host is not OpenVMS. If
-- the host is indeed OpenVMS, then the error message stored in Msg_Buffer
-- is scanned for appearances of switch names which need converting to
-- corresponding VMS qualifier names. See Gnames/Vnames table in Errout
-- spec for precise definition of the conversion that is performed by this
-- routine in OpenVMS mode.
function Warn_Insertion return String;
-- This is called for warning messages only (so Warning_Msg_Char is set)
-- and returns a corresponding string to use at the beginning of generated
-- auxiliary messages, such as "in instantiation at ...".
-- 'a' .. 'z' returns "?x?"
-- 'A' .. 'Z' returns "?X?"
-- '*' returns "?*?"
-- '$' returns "?$?info: "
-- ' ' returns " "
-- No other settings are valid
-----------------------
-- Change_Error_Text --
-----------------------
procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String) is
Save_Next : Error_Msg_Id;
Err_Id : Error_Msg_Id := Error_Id;
begin
Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr);
Errors.Table (Error_Id).Text := new String'(Msg_Buffer (1 .. Msglen));
-- If in immediate error message mode, output modified error message now
-- This is just a bit tricky, because we want to output just a single
-- message, and the messages we modified is already linked in. We solve
-- this by temporarily resetting its forward pointer to empty.
if Debug_Flag_OO then
Save_Next := Errors.Table (Error_Id).Next;
Errors.Table (Error_Id).Next := No_Error_Msg;
Write_Eol;
Output_Source_Line
(Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Sfile, True);
Output_Error_Msgs (Err_Id);
Errors.Table (Error_Id).Next := Save_Next;
end if;
end Change_Error_Text;
------------------------
-- Compilation_Errors --
------------------------
function Compilation_Errors return Boolean is
begin
if not Finalize_Called then
raise Program_Error;
else
return Erroutc.Compilation_Errors;
end if;
end Compilation_Errors;
--------------------------------------
-- Delete_Warning_And_Continuations --
--------------------------------------
procedure Delete_Warning_And_Continuations (Msg : Error_Msg_Id) is
Id : Error_Msg_Id;
begin
pragma Assert (not Errors.Table (Msg).Msg_Cont);
Id := Msg;
loop
declare
M : Error_Msg_Object renames Errors.Table (Id);
begin
if not M.Deleted then
M.Deleted := True;
Warnings_Detected := Warnings_Detected - 1;
if M.Warn_Err then
Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
end if;
end if;
Id := M.Next;
exit when Id = No_Error_Msg;
exit when not Errors.Table (Id).Msg_Cont;
end;
end loop;
end Delete_Warning_And_Continuations;
---------------
-- Error_Msg --
---------------
-- Error_Msg posts a flag at the given location, except that if the
-- Flag_Location points within a generic template and corresponds to an
-- instantiation of this generic template, then the actual message will be
-- posted on the generic instantiation, along with additional messages
-- referencing the generic declaration.
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
Sindex : Source_File_Index;
-- Source index for flag location
Orig_Loc : Source_Ptr;
-- Original location of Flag_Location (i.e. location in original
-- template in instantiation case, otherwise unchanged).
begin
-- It is a fatal error to issue an error message when scanning from the
-- internal source buffer (see Sinput for further documentation)
pragma Assert (Sinput.Source /= Internal_Source_Ptr);
-- Return if all errors are to be ignored
if Errors_Must_Be_Ignored then
return;
end if;
-- If we already have messages, and we are trying to place a message at
-- No_Location or in package Standard, then just ignore the attempt
-- since we assume that what is happening is some cascaded junk. Note
-- that this is safe in the sense that proceeding will surely bomb.
if Flag_Location < First_Source_Ptr
and then Total_Errors_Detected > 0
then
return;
end if;
-- Start of processing for new message
Sindex := Get_Source_File_Index (Flag_Location);
Prescan_Message (Msg);
Orig_Loc := Original_Location (Flag_Location);
-- If the current location is in an instantiation, the issue arises of
-- whether to post the message on the template or the instantiation.
-- The way we decide is to see if we have posted the same message on
-- the template when we compiled the template (the template is always
-- compiled before any instantiations). For this purpose, we use a
-- separate table of messages. The reason we do this is twofold:
-- First, the messages can get changed by various processing
-- including the insertion of tokens etc, making it hard to
-- do the comparison.
-- Second, we will suppress a warning on a template if it is not in
-- the current extended source unit. That's reasonable and means we
-- don't want the warning on the instantiation here either, but it
-- does mean that the main error table would not in any case include
-- the message.
if Flag_Location = Orig_Loc then
Non_Instance_Msgs.Append ((new String'(Msg), Flag_Location));
Warn_On_Instance := False;
-- Here we have an instance message
else
-- Delete if debug flag off, and this message duplicates a message
-- already posted on the corresponding template
if not Debug_Flag_GG then
for J in Non_Instance_Msgs.First .. Non_Instance_Msgs.Last loop
if Msg = Non_Instance_Msgs.Table (J).Msg.all
and then Non_Instance_Msgs.Table (J).Loc = Orig_Loc
then
return;
end if;
end loop;
end if;
-- No duplicate, so error/warning will be posted on instance
Warn_On_Instance := Is_Warning_Msg;
end if;
-- Ignore warning message that is suppressed for this location. Note
-- that style checks are not considered warning messages for this
-- purpose.
if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) /= No_String
then
return;
-- For style messages, check too many messages so far
elsif Is_Style_Msg
and then Maximum_Messages /= 0
and then Warnings_Detected >= Maximum_Messages
then
return;
end if;
-- The idea at this stage is that we have two kinds of messages
-- First, we have those messages that are to be placed as requested at
-- Flag_Location. This includes messages that have nothing to do with
-- generics, and also messages placed on generic templates that reflect
-- an error in the template itself. For such messages we simply call
-- Error_Msg_Internal to place the message in the requested location.
if Instantiation (Sindex) = No_Location then
Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False);
return;
end if;
-- If we are trying to flag an error in an instantiation, we may have
-- a generic contract violation. What we generate in this case is:
-- instantiation error at ...
-- original error message
-- or
-- warning: in instantiation at
-- warning: original warning message
-- All these messages are posted at the location of the top level
-- instantiation. If there are nested instantiations, then the
-- instantiation error message can be repeated, pointing to each
-- of the relevant instantiations.
-- Note: the instantiation mechanism is also shared for inlining of
-- subprogram bodies when front end inlining is done. In this case the
-- messages have the form:
-- in inlined body at ...
-- original error message
-- or
-- warning: in inlined body at
-- warning: original warning message
-- OK, here we have an instantiation error, and we need to generate the
-- error on the instantiation, rather than on the template.
declare
Actual_Error_Loc : Source_Ptr;
-- Location of outer level instantiation in instantiation case, or
-- just a copy of Flag_Location in the normal case. This is the
-- location where all error messages will actually be posted.
Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc;
-- Save possible location set for caller's message. We need to use
-- Error_Msg_Sloc for the location of the instantiation error but we
-- have to preserve a possible original value.
X : Source_File_Index;
Msg_Cont_Status : Boolean;
-- Used to label continuation lines in instantiation case with
-- proper Msg_Cont status.
begin
-- Loop to find highest level instantiation, where all error
-- messages will be placed.
X := Sindex;
loop
Actual_Error_Loc := Instantiation (X);
X := Get_Source_File_Index (Actual_Error_Loc);
exit when Instantiation (X) = No_Location;
end loop;
-- Since we are generating the messages at the instantiation point in
-- any case, we do not want the references to the bad lines in the
-- instance to be annotated with the location of the instantiation.
Suppress_Instance_Location := True;
Msg_Cont_Status := False;
-- Loop to generate instantiation messages
Error_Msg_Sloc := Flag_Location;
X := Get_Source_File_Index (Flag_Location);
while Instantiation (X) /= No_Location loop
-- Suppress instantiation message on continuation lines
if Msg (Msg'First) /= '\' then
-- Case of inlined body
if Inlined_Body (X) then
if Is_Warning_Msg or Is_Style_Msg then
Error_Msg_Internal
(Warn_Insertion & "in inlined body #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
else
Error_Msg_Internal
("error in inlined body #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
end if;
-- Case of generic instantiation
else
if Is_Warning_Msg or else Is_Style_Msg then
Error_Msg_Internal
(Warn_Insertion & "in instantiation #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
else
Error_Msg_Internal
("instantiation error #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
end if;
end if;
end if;
Error_Msg_Sloc := Instantiation (X);
X := Get_Source_File_Index (Error_Msg_Sloc);
Msg_Cont_Status := True;
end loop;
Suppress_Instance_Location := False;
Error_Msg_Sloc := Save_Error_Msg_Sloc;
-- Here we output the original message on the outer instantiation
Error_Msg_Internal
(Msg, Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
end;
end Error_Msg;
--------------------------------
-- Error_Msg_Ada_2012_Feature --
--------------------------------
procedure Error_Msg_Ada_2012_Feature (Feature : String; Loc : Source_Ptr) is
begin
if Ada_Version < Ada_2012 then
Error_Msg (Feature & " is an Ada 2012 feature", Loc);
if No (Ada_Version_Pragma) then
Error_Msg ("\unit must be compiled with -gnat2012 switch", Loc);
else
Error_Msg_Sloc := Sloc (Ada_Version_Pragma);
Error_Msg ("\incompatible with Ada version set#", Loc);
end if;
end if;
end Error_Msg_Ada_2012_Feature;
------------------
-- Error_Msg_AP --
------------------
procedure Error_Msg_AP (Msg : String) is
S1 : Source_Ptr;
C : Character;
begin
-- If we had saved the Scan_Ptr value after scanning the previous
-- token, then we would have exactly the right place for putting
-- the flag immediately at hand. However, that would add at least
-- two instructions to a Scan call *just* to service the possibility
-- of an Error_Msg_AP call. So instead we reconstruct that value.
-- We have two possibilities, start with Prev_Token_Ptr and skip over
-- the current token, which is made harder by the possibility that this
-- token may be in error, or start with Token_Ptr and work backwards.
-- We used to take the second approach, but it's hard because of
-- comments, and harder still because things that look like comments
-- can appear inside strings. So now we take the first approach.
-- Note: in the case where there is no previous token, Prev_Token_Ptr
-- is set to Source_First, which is a reasonable position for the
-- error flag in this situation.
S1 := Prev_Token_Ptr;
C := Source (S1);
-- If the previous token is a string literal, we need a special approach
-- since there may be white space inside the literal and we don't want
-- to stop on that white space.
-- Note: since this is an error recovery issue anyway, it is not worth
-- worrying about special UTF_32 line terminator characters here.
if Prev_Token = Tok_String_Literal then
loop
S1 := S1 + 1;
if Source (S1) = C then
S1 := S1 + 1;
exit when Source (S1) /= C;
elsif Source (S1) in Line_Terminator then
exit;
end if;
end loop;
-- Character literal also needs special handling
elsif Prev_Token = Tok_Char_Literal then
S1 := S1 + 3;
-- Otherwise we search forward for the end of the current token, marked
-- by a line terminator, white space, a comment symbol or if we bump
-- into the following token (i.e. the current token).
-- Again, it is not worth worrying about UTF_32 special line terminator
-- characters in this context, since this is only for error recovery.
else
while Source (S1) not in Line_Terminator
and then Source (S1) /= ' '
and then Source (S1) /= ASCII.HT
and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-')
and then S1 /= Token_Ptr
loop
S1 := S1 + 1;
end loop;
end if;
-- S1 is now set to the location for the flag
Error_Msg (Msg, S1);
end Error_Msg_AP;
------------------
-- Error_Msg_BC --
------------------
procedure Error_Msg_BC (Msg : String) is
begin
-- If we are at end of file, post the flag after the previous token
if Token = Tok_EOF then
Error_Msg_AP (Msg);
-- If we are at start of file, post the flag at the current token
elsif Token_Ptr = Source_First (Current_Source_File) then
Error_Msg_SC (Msg);
-- If the character before the current token is a space or a horizontal
-- tab, then we place the flag on this character (in the case of a tab
-- we would really like to place it in the "last" character of the tab
-- space, but that it too much trouble to worry about).
elsif Source (Token_Ptr - 1) = ' '
or else Source (Token_Ptr - 1) = ASCII.HT
then
Error_Msg (Msg, Token_Ptr - 1);
-- If there is no space or tab before the current token, then there is
-- no room to place the flag before the token, so we place it on the
-- token instead (this happens for example at the start of a line).
else
Error_Msg (Msg, Token_Ptr);
end if;
end Error_Msg_BC;
-------------------
-- Error_Msg_CRT --
-------------------
procedure Error_Msg_CRT (Feature : String; N : Node_Id) is
CNRT : constant String := " not allowed in no run time mode";
CCRT : constant String := " not supported by configuration>";
S : String (1 .. Feature'Length + 1 + CCRT'Length);
L : Natural;
begin
S (1) := '|';
S (2 .. Feature'Length + 1) := Feature;
L := Feature'Length + 2;
if No_Run_Time_Mode then
S (L .. L + CNRT'Length - 1) := CNRT;
L := L + CNRT'Length - 1;
else pragma Assert (Configurable_Run_Time_Mode);
S (L .. L + CCRT'Length - 1) := CCRT;
L := L + CCRT'Length - 1;
end if;
Error_Msg_N (S (1 .. L), N);
Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1;
end Error_Msg_CRT;
------------------
-- Error_Msg_PT --
------------------
procedure Error_Msg_PT (Typ : Node_Id; Subp : Node_Id) is
begin
Error_Msg_NE
("first formal of & must be of mode `OUT`, `IN OUT` or " &
"access-to-variable", Typ, Subp);
Error_Msg_N
("\in order to be overridden by protected procedure or entry " &
"(RM 9.4(11.9/2))", Typ);
end Error_Msg_PT;
-----------------
-- Error_Msg_F --
-----------------
procedure Error_Msg_F (Msg : String; N : Node_Id) is
begin
Error_Msg_NEL (Msg, N, N, Sloc (First_Node (N)));
end Error_Msg_F;
------------------
-- Error_Msg_FE --
------------------
procedure Error_Msg_FE
(Msg : String;
N : Node_Id;
E : Node_Or_Entity_Id)
is
begin
Error_Msg_NEL (Msg, N, E, Sloc (First_Node (N)));
end Error_Msg_FE;
------------------------
-- Error_Msg_Internal --
------------------------
procedure Error_Msg_Internal
(Msg : String;
Sptr : Source_Ptr;
Optr : Source_Ptr;
Msg_Cont : Boolean)
is
Next_Msg : Error_Msg_Id;
-- Pointer to next message at insertion point
Prev_Msg : Error_Msg_Id;
-- Pointer to previous message at insertion point
Temp_Msg : Error_Msg_Id;
Warn_Err : Boolean;
-- Set if warning to be treated as error
procedure Handle_Serious_Error;
-- Internal procedure to do all error message handling for a serious
-- error message, other than bumping the error counts and arranging
-- for the message to be output.
--------------------------
-- Handle_Serious_Error --
--------------------------
procedure Handle_Serious_Error is
begin
-- Turn off code generation if not done already
if Operating_Mode = Generate_Code then
Operating_Mode := Check_Semantics;
Expander_Active := False;
end if;
-- Set the fatal error flag in the unit table unless we are in
-- Try_Semantics mode. This stops the semantics from being performed
-- if we find a serious error. This is skipped if we are currently
-- dealing with the configuration pragma file.
if not Try_Semantics and then Current_Source_Unit /= No_Unit then
Set_Fatal_Error (Get_Source_Unit (Sptr));
end if;
end Handle_Serious_Error;
-- Start of processing for Error_Msg_Internal
begin
if Raise_Exception_On_Error /= 0 then
raise Error_Msg_Exception;
end if;
Continuation := Msg_Cont;
Continuation_New_Line := False;
Suppress_Message := False;
Kill_Message := False;
Set_Msg_Text (Msg, Sptr);
-- Kill continuation if parent message killed
if Continuation and Last_Killed then
return;
end if;
-- Return without doing anything if message is suppressed
if Suppress_Message
and then not All_Errors_Mode
and then not Is_Warning_Msg
and then not Is_Unconditional_Msg
then
if not Continuation then
Last_Killed := True;
end if;
return;
end if;
-- Return without doing anything if message is killed and this is not
-- the first error message. The philosophy is that if we get a weird
-- error message and we already have had a message, then we hope the
-- weird message is a junk cascaded message
if Kill_Message
and then not All_Errors_Mode
and then Total_Errors_Detected /= 0
then
if not Continuation then
Last_Killed := True;
end if;
return;
end if;
-- Special check for warning message to see if it should be output
if Is_Warning_Msg then
-- Immediate return if warning message and warnings are suppressed
if Warnings_Suppressed (Optr) /= No_String
or else
Warnings_Suppressed (Sptr) /= No_String
then
Cur_Msg := No_Error_Msg;
return;
end if;
-- If the flag location is in the main extended source unit then for
-- sure we want the warning since it definitely belongs
if In_Extended_Main_Source_Unit (Sptr) then
null;
-- If the main unit has not been read yet. the warning must be on
-- a configuration file: gnat.adc or user-defined. This means we
-- are not parsing the main unit yet, so skip following checks.
elsif No (Cunit (Main_Unit)) then
null;
-- If the flag location is not in the main extended source unit, then
-- we want to eliminate the warning, unless it is in the extended
-- main code unit and we want warnings on the instance.
elsif In_Extended_Main_Code_Unit (Sptr) and then Warn_On_Instance then
null;
-- Keep warning if debug flag G set
elsif Debug_Flag_GG then
null;
-- Keep warning if message text contains !!
elsif Has_Double_Exclam then
null;
-- Here is where we delete a warning from a with'ed unit
else
Cur_Msg := No_Error_Msg;
if not Continuation then
Last_Killed := True;
end if;
return;
end if;
end if;
-- If message is to be ignored in special ignore message mode, this is
-- where we do this special processing, bypassing message output.
if Ignore_Errors_Enable > 0 then
if Is_Serious_Error then
Handle_Serious_Error;
end if;
return;
end if;
-- If error message line length set, and this is a continuation message
-- then all we do is to append the text to the text of the last message
-- with a comma space separator (eliminating a possible (style) or
-- info prefix).
if Error_Msg_Line_Length /= 0 and then Continuation then
Cur_Msg := Errors.Last;
declare
Oldm : String_Ptr := Errors.Table (Cur_Msg).Text;
Newm : String (1 .. Oldm'Last + 2 + Msglen);
Newl : Natural;
M : Natural;
begin
-- First copy old message to new one and free it
Newm (Oldm'Range) := Oldm.all;
Newl := Oldm'Length;
Free (Oldm);
-- Remove (style) or info: at start of message
if Msglen > 8 and then Msg_Buffer (1 .. 8) = "(style) " then
M := 9;
elsif Msglen > 6 and then Msg_Buffer (1 .. 6) = "info: " then
M := 7;
else
M := 1;
end if;
-- Now deal with separation between messages. Normally this is
-- simply comma space, but there are some special cases.
-- If continuation new line, then put actual NL character in msg
if Continuation_New_Line then
Newl := Newl + 1;
Newm (Newl) := ASCII.LF;
-- If continuation message is enclosed in parentheses, then
-- special treatment (don't need a comma, and we want to combine
-- successive parenthetical remarks into a single one with
-- separating commas).
elsif Msg_Buffer (M) = '(' and then Msg_Buffer (Msglen) = ')' then
-- Case where existing message ends in right paren, remove
-- and separate parenthetical remarks with a comma.
if Newm (Newl) = ')' then
Newm (Newl) := ',';
Msg_Buffer (M) := ' ';
-- Case where we are adding new parenthetical comment
else
Newl := Newl + 1;
Newm (Newl) := ' ';
end if;
-- Case where continuation not in parens and no new line
else
Newm (Newl + 1 .. Newl + 2) := ", ";
Newl := Newl + 2;
end if;
-- Append new message
Newm (Newl + 1 .. Newl + Msglen - M + 1) :=
Msg_Buffer (M .. Msglen);
Newl := Newl + Msglen - M + 1;
Errors.Table (Cur_Msg).Text := new String'(Newm (1 .. Newl));
-- Update warning msg flag and message doc char if needed
if Is_Warning_Msg then
if not Errors.Table (Cur_Msg).Warn then
Errors.Table (Cur_Msg).Warn := True;
Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
elsif Warning_Msg_Char /= ' ' then
Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
end if;
end if;
end;
return;
end if;
-- Here we build a new error object
Errors.Append
((Text => new String'(Msg_Buffer (1 .. Msglen)),
Next => No_Error_Msg,
Prev => No_Error_Msg,
Sptr => Sptr,
Optr => Optr,
Sfile => Get_Source_File_Index (Sptr),
Line => Get_Physical_Line_Number (Sptr),
Col => Get_Column_Number (Sptr),
Warn => Is_Warning_Msg,
Info => Is_Info_Msg,
Warn_Err => False, -- reset below
Warn_Chr => Warning_Msg_Char,
Style => Is_Style_Msg,
Serious => Is_Serious_Error,
Uncond => Is_Unconditional_Msg,
Msg_Cont => Continuation,
Deleted => False));
Cur_Msg := Errors.Last;
-- Test if warning to be treated as error
Warn_Err :=
Is_Warning_Msg
and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen))
or else
Warning_Treated_As_Error (Get_Warning_Tag (Cur_Msg)));
-- Propagate Warn_Err to this message and preceding continuations
for J in reverse 1 .. Errors.Last loop
Errors.Table (J).Warn_Err := Warn_Err;
exit when not Errors.Table (J).Msg_Cont;
end loop;
-- If immediate errors mode set, output error message now. Also output
-- now if the -d1 debug flag is set (so node number message comes out
-- just before actual error message)
if Debug_Flag_OO or else Debug_Flag_1 then
Write_Eol;
Output_Source_Line
(Errors.Table (Cur_Msg).Line, Errors.Table (Cur_Msg).Sfile, True);
Temp_Msg := Cur_Msg;
Output_Error_Msgs (Temp_Msg);
-- If not in immediate errors mode, then we insert the message in the
-- error chain for later output by Finalize. The messages are sorted
-- first by unit (main unit comes first), and within a unit by source
-- location (earlier flag location first in the chain).
else
-- First a quick check, does this belong at the very end of the chain
-- of error messages. This saves a lot of time in the normal case if
-- there are lots of messages.
if Last_Error_Msg /= No_Error_Msg
and then Errors.Table (Cur_Msg).Sfile =
Errors.Table (Last_Error_Msg).Sfile
and then (Sptr > Errors.Table (Last_Error_Msg).Sptr
or else
(Sptr = Errors.Table (Last_Error_Msg).Sptr
and then
Optr > Errors.Table (Last_Error_Msg).Optr))
then
Prev_Msg := Last_Error_Msg;
Next_Msg := No_Error_Msg;
-- Otherwise do a full sequential search for the insertion point
else
Prev_Msg := No_Error_Msg;
Next_Msg := First_Error_Msg;
while Next_Msg /= No_Error_Msg loop
exit when
Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile
then
exit when Sptr < Errors.Table (Next_Msg).Sptr
or else (Sptr = Errors.Table (Next_Msg).Sptr
and then Optr < Errors.Table (Next_Msg).Optr);
end if;
Prev_Msg := Next_Msg;
Next_Msg := Errors.Table (Next_Msg).Next;
end loop;
end if;
-- Now we insert the new message in the error chain. The insertion
-- point for the message is after Prev_Msg and before Next_Msg.
-- The possible insertion point for the new message is after Prev_Msg
-- and before Next_Msg. However, this is where we do a special check
-- for redundant parsing messages, defined as messages posted on the
-- same line. The idea here is that probably such messages are junk
-- from the parser recovering. In full errors mode, we don't do this
-- deletion, but otherwise such messages are discarded at this stage.
if Prev_Msg /= No_Error_Msg
and then Errors.Table (Prev_Msg).Line =
Errors.Table (Cur_Msg).Line
and then Errors.Table (Prev_Msg).Sfile =
Errors.Table (Cur_Msg).Sfile
and then Compiler_State = Parsing
and then not All_Errors_Mode
then
-- Don't delete unconditional messages and at this stage, don't
-- delete continuation lines (we attempted to delete those earlier
-- if the parent message was deleted.
if not Errors.Table (Cur_Msg).Uncond
and then not Continuation
then
-- Don't delete if prev msg is warning and new msg is an error.
-- This is because we don't want a real error masked by a
-- warning. In all other cases (that is parse errors for the
-- same line that are not unconditional) we do delete the
-- message. This helps to avoid junk extra messages from
-- cascaded parsing errors
if not (Errors.Table (Prev_Msg).Warn
or else
Errors.Table (Prev_Msg).Style)
or else
(Errors.Table (Cur_Msg).Warn
or else
Errors.Table (Cur_Msg).Style)
then
-- All tests passed, delete the message by simply returning
-- without any further processing.
if not Continuation then
Last_Killed := True;
end if;
return;
end if;
end if;
end if;
-- Come here if message is to be inserted in the error chain
if not Continuation then
Last_Killed := False;
end if;
if Prev_Msg = No_Error_Msg then
First_Error_Msg := Cur_Msg;
else
Errors.Table (Prev_Msg).Next := Cur_Msg;
end if;
Errors.Table (Cur_Msg).Next := Next_Msg;
if Next_Msg = No_Error_Msg then
Last_Error_Msg := Cur_Msg;
end if;
end if;
-- Bump appropriate statistics count
if Errors.Table (Cur_Msg).Warn or else Errors.Table (Cur_Msg).Style then
Warnings_Detected := Warnings_Detected + 1;
else
Total_Errors_Detected := Total_Errors_Detected + 1;
if Errors.Table (Cur_Msg).Serious then
Serious_Errors_Detected := Serious_Errors_Detected + 1;
Handle_Serious_Error;
end if;
end if;
-- Record warning message issued
if Errors.Table (Cur_Msg).Warn
and then not Errors.Table (Cur_Msg).Msg_Cont
then
Warning_Msg := Cur_Msg;
end if;
-- If too many warnings turn off warnings
if Maximum_Messages /= 0 then
if Warnings_Detected = Maximum_Messages then
Warning_Mode := Suppress;
end if;
-- If too many errors abandon compilation
if Total_Errors_Detected = Maximum_Messages then
raise Unrecoverable_Error;
end if;
end if;
end Error_Msg_Internal;
-----------------
-- Error_Msg_N --
-----------------
procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
begin
Error_Msg_NEL (Msg, N, N, Sloc (N));
end Error_Msg_N;
------------------
-- Error_Msg_NE --
------------------
procedure Error_Msg_NE
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id)
is
begin
Error_Msg_NEL (Msg, N, E, Sloc (N));
end Error_Msg_NE;
-------------------
-- Error_Msg_NEL --
-------------------
procedure Error_Msg_NEL
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id;
Flag_Location : Source_Ptr)
is
begin
if Special_Msg_Delete (Msg, N, E) then
return;
end if;
Prescan_Message (Msg);
-- Special handling for warning messages
if Is_Warning_Msg then
-- Suppress if no warnings set for either entity or node
if No_Warnings (N) or else No_Warnings (E) then
-- Disable any continuation messages as well
Last_Killed := True;
return;
end if;
-- Suppress if inside loop that is known to be null or is probably
-- null (case where loop executes only if invalid values present).
-- In either case warnings in the loop are likely to be junk.
declare
P : Node_Id;
begin
P := Parent (N);
while Present (P) loop
if Nkind (P) = N_Loop_Statement
and then Suppress_Loop_Warnings (P)
then
return;
end if;
P := Parent (P);
end loop;
end;
end if;
-- Test for message to be output
if All_Errors_Mode
or else Is_Unconditional_Msg
or else Is_Warning_Msg
or else OK_Node (N)
or else (Msg (Msg'First) = '\' and then not Last_Killed)
then
Debug_Output (N);
Error_Msg_Node_1 := E;
Error_Msg (Msg, Flag_Location);
else
Last_Killed := True;
end if;
if not (Is_Warning_Msg or Is_Style_Msg) then
Set_Posted (N);
end if;
end Error_Msg_NEL;
------------------
-- Error_Msg_NW --
------------------
procedure Error_Msg_NW
(Eflag : Boolean;
Msg : String;
N : Node_Or_Entity_Id)
is
begin
if Eflag
and then In_Extended_Main_Source_Unit (N)
and then Comes_From_Source (N)
then
Error_Msg_NEL (Msg, N, N, Sloc (N));
end if;
end Error_Msg_NW;
-----------------
-- Error_Msg_S --
-----------------
procedure Error_Msg_S (Msg : String) is
begin
Error_Msg (Msg, Scan_Ptr);
end Error_Msg_S;
------------------
-- Error_Msg_SC --
------------------
procedure Error_Msg_SC (Msg : String) is
begin
-- If we are at end of file, post the flag after the previous token
if Token = Tok_EOF then
Error_Msg_AP (Msg);
-- For all other cases the message is posted at the current token
-- pointer position
else
Error_Msg (Msg, Token_Ptr);
end if;
end Error_Msg_SC;
------------------
-- Error_Msg_SP --
------------------
procedure Error_Msg_SP (Msg : String) is
begin
-- Note: in the case where there is no previous token, Prev_Token_Ptr
-- is set to Source_First, which is a reasonable position for the
-- error flag in this situation
Error_Msg (Msg, Prev_Token_Ptr);
end Error_Msg_SP;
--------------
-- Finalize --
--------------
procedure Finalize (Last_Call : Boolean) is
Cur : Error_Msg_Id;
Nxt : Error_Msg_Id;
F : Error_Msg_Id;
procedure Delete_Warning (E : Error_Msg_Id);
-- Delete a warning msg if not already deleted and adjust warning count
--------------------
-- Delete_Warning --
--------------------
procedure Delete_Warning (E : Error_Msg_Id) is
begin
if not Errors.Table (E).Deleted then
Errors.Table (E).Deleted := True;
Warnings_Detected := Warnings_Detected - 1;
if Errors.Table (E).Warn_Err then
Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
end if;
end if;
end Delete_Warning;
-- Start of processing for Finalize
begin
-- Set Prev pointers
Cur := First_Error_Msg;
while Cur /= No_Error_Msg loop
Nxt := Errors.Table (Cur).Next;
exit when Nxt = No_Error_Msg;
Errors.Table (Nxt).Prev := Cur;
Cur := Nxt;
end loop;
-- Eliminate any duplicated error messages from the list. This is
-- done after the fact to avoid problems with Change_Error_Text.
Cur := First_Error_Msg;
while Cur /= No_Error_Msg loop
Nxt := Errors.Table (Cur).Next;
F := Nxt;
while F /= No_Error_Msg
and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
loop
Check_Duplicate_Message (Cur, F);
F := Errors.Table (F).Next;
end loop;
Cur := Nxt;
end loop;
-- Mark any messages suppressed by specific warnings as Deleted
Cur := First_Error_Msg;
while Cur /= No_Error_Msg loop
declare
CE : Error_Msg_Object renames Errors.Table (Cur);
Tag : constant String := Get_Warning_Tag (Cur);
begin
if (CE.Warn and not CE.Deleted)
and then
(Warning_Specifically_Suppressed (CE.Sptr, CE.Text, Tag) /=
No_String
or else
Warning_Specifically_Suppressed (CE.Optr, CE.Text, Tag) /=
No_String)
then
Delete_Warning (Cur);
-- If this is a continuation, delete previous parts of message
F := Cur;
while Errors.Table (F).Msg_Cont loop
F := Errors.Table (F).Prev;
exit when F = No_Error_Msg;
Delete_Warning (F);
end loop;
-- Delete any following continuations
F := Cur;
loop
F := Errors.Table (F).Next;
exit when F = No_Error_Msg;
exit when not Errors.Table (F).Msg_Cont;
Delete_Warning (F);
end loop;
end if;
end;
Cur := Errors.Table (Cur).Next;
end loop;
Finalize_Called := True;
-- Check consistency of specific warnings (may add warnings). We only
-- do this on the last call, after all possible warnings are posted.
if Last_Call then
Validate_Specific_Warnings (Error_Msg'Access);
end if;
end Finalize;
----------------
-- First_Node --
----------------
function First_Node (C : Node_Id) return Node_Id is
Orig : constant Node_Id := Original_Node (C);
Loc : constant Source_Ptr := Sloc (Orig);
Sfile : constant Source_File_Index := Get_Source_File_Index (Loc);
Earliest : Node_Id;
Eloc : Source_Ptr;
function Test_Earlier (N : Node_Id) return Traverse_Result;
-- Function applied to every node in the construct
procedure Search_Tree_First is new Traverse_Proc (Test_Earlier);
-- Create traversal procedure
------------------
-- Test_Earlier --
------------------
function Test_Earlier (N : Node_Id) return Traverse_Result is
Norig : constant Node_Id := Original_Node (N);
Loc : constant Source_Ptr := Sloc (Norig);
begin
-- Check for earlier
if Loc < Eloc
-- Ignore nodes with no useful location information
and then Loc /= Standard_Location
and then Loc /= No_Location
-- Ignore nodes from a different file. This ensures against cases
-- of strange foreign code somehow being present. We don't want
-- wild placement of messages if that happens.
and then Get_Source_File_Index (Loc) = Sfile
then
Earliest := Norig;
Eloc := Loc;
end if;
return OK_Orig;
end Test_Earlier;
-- Start of processing for First_Node
begin
if Nkind (Orig) in N_Subexpr then
Earliest := Orig;
Eloc := Loc;
Search_Tree_First (Orig);
return Earliest;
else
return Orig;
end if;
end First_Node;
----------------
-- First_Sloc --
----------------
function First_Sloc (N : Node_Id) return Source_Ptr is
SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N));
SF : constant Source_Ptr := Source_First (SI);
F : Node_Id;
S : Source_Ptr;
begin
F := First_Node (N);
S := Sloc (F);
-- The following circuit is a bit subtle. When we have parenthesized
-- expressions, then the Sloc will not record the location of the paren,
-- but we would like to post the flag on the paren. So what we do is to
-- crawl up the tree from the First_Node, adjusting the Sloc value for
-- any parentheses we know are present. Yes, we know this circuit is not
-- 100% reliable (e.g. because we don't record all possible paren level
-- values), but this is only for an error message so it is good enough.
Node_Loop : loop
Paren_Loop : for J in 1 .. Paren_Count (F) loop
-- We don't look more than 12 characters behind the current
-- location, and in any case not past the front of the source.
Search_Loop : for K in 1 .. 12 loop
exit Search_Loop when S = SF;
if Source_Text (SI) (S - 1) = '(' then
S := S - 1;
exit Search_Loop;
elsif Source_Text (SI) (S - 1) <= ' ' then
S := S - 1;
else
exit Search_Loop;
end if;
end loop Search_Loop;
end loop Paren_Loop;
exit Node_Loop when F = N;
F := Parent (F);
exit Node_Loop when Nkind (F) not in N_Subexpr;
end loop Node_Loop;
return S;
end First_Sloc;
-----------------------
-- Get_Ignore_Errors --
-----------------------
function Get_Ignore_Errors return Boolean is
begin
return Errors_Must_Be_Ignored;
end Get_Ignore_Errors;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
Errors.Init;
First_Error_Msg := No_Error_Msg;
Last_Error_Msg := No_Error_Msg;
Serious_Errors_Detected := 0;
Total_Errors_Detected := 0;
Warnings_Treated_As_Errors := 0;
Warnings_Detected := 0;
Warnings_As_Errors_Count := 0;
Cur_Msg := No_Error_Msg;
List_Pragmas.Init;
-- Initialize warnings tables
Warnings.Init;
Specific_Warnings.Init;
end Initialize;
-----------------
-- No_Warnings --
-----------------
function No_Warnings (N : Node_Or_Entity_Id) return Boolean is
begin
if Error_Posted (N) then
return True;
elsif Nkind (N) in N_Entity and then Has_Warnings_Off (N) then
return True;
elsif Is_Entity_Name (N)
and then Present (Entity (N))
and then Has_Warnings_Off (Entity (N))
then
return True;
else
return False;
end if;
end No_Warnings;
-------------
-- OK_Node --
-------------
function OK_Node (N : Node_Id) return Boolean is
K : constant Node_Kind := Nkind (N);
begin
if Error_Posted (N) then
return False;
elsif K in N_Has_Etype
and then Present (Etype (N))
and then Error_Posted (Etype (N))
then
return False;
elsif (K in N_Op
or else K = N_Attribute_Reference
or else K = N_Character_Literal
or else K = N_Expanded_Name
or else K = N_Identifier
or else K = N_Operator_Symbol)
and then Present (Entity (N))
and then Error_Posted (Entity (N))
then
return False;
else
return True;
end if;
end OK_Node;
---------------------
-- Output_Messages --
---------------------
procedure Output_Messages is
E : Error_Msg_Id;
Err_Flag : Boolean;
procedure Write_Error_Summary;
-- Write error summary
procedure Write_Header (Sfile : Source_File_Index);
-- Write header line (compiling or checking given file)
procedure Write_Max_Errors;
-- Write message if max errors reached
-------------------------
-- Write_Error_Summary --
-------------------------
procedure Write_Error_Summary is
begin
-- Extra blank line if error messages or source listing were output
if Total_Errors_Detected + Warnings_Detected > 0
or else Full_List
then
Write_Eol;
end if;
-- Message giving number of lines read and number of errors detected.
-- This normally goes to Standard_Output. The exception is when brief
-- mode is not set, verbose mode (or full list mode) is set, and
-- there are errors. In this case we send the message to standard
-- error to make sure that *something* appears on standard error in
-- an error situation.
-- Formerly, only the "# errors" suffix was sent to stderr, whereas
-- "# lines:" appeared on stdout. This caused problems on VMS when
-- the stdout buffer was flushed, giving an extra line feed after
-- the prefix.
if Total_Errors_Detected + Warnings_Detected /= 0
and then not Brief_Output
and then (Verbose_Mode or Full_List)
then
Set_Standard_Error;
end if;
-- Message giving total number of lines. Don't give this message if
-- the Main_Source line is unknown (this happens in error situations,
-- e.g. when integrated preprocessing fails).
if Main_Source_File /= No_Source_File then
Write_Str (" ");
Write_Int (Num_Source_Lines (Main_Source_File));
if Num_Source_Lines (Main_Source_File) = 1 then
Write_Str (" line: ");
else
Write_Str (" lines: ");
end if;
end if;
if Total_Errors_Detected = 0 then
Write_Str ("No errors");
elsif Total_Errors_Detected = 1 then
Write_Str ("1 error");
else
Write_Int (Total_Errors_Detected);
Write_Str (" errors");
end if;
if Warnings_Detected /= 0 then
Write_Str (", ");
Write_Int (Warnings_Detected);
Write_Str (" warning");
if Warnings_Detected /= 1 then
Write_Char ('s');
end if;
if Warning_Mode = Treat_As_Error then
Write_Str (" (treated as error");
if Warnings_Detected /= 1 then
Write_Char ('s');
end if;
Write_Char (')');
elsif Warnings_Treated_As_Errors /= 0 then
Write_Str (" (");
Write_Int (Warnings_Treated_As_Errors);
Write_Str (" treated as errors)");
end if;
end if;
Write_Eol;
Set_Standard_Output;
end Write_Error_Summary;
------------------
-- Write_Header --
------------------
procedure Write_Header (Sfile : Source_File_Index) is
begin
if Verbose_Mode or Full_List then
if Original_Operating_Mode = Generate_Code then
Write_Str ("Compiling: ");
else
Write_Str ("Checking: ");
end if;
Write_Name (Full_File_Name (Sfile));
if not Debug_Flag_7 then
Write_Str (" (source file time stamp: ");
Write_Time_Stamp (Sfile);
Write_Char (')');
end if;
Write_Eol;
end if;
end Write_Header;
----------------------
-- Write_Max_Errors --
----------------------
procedure Write_Max_Errors is
begin
if Maximum_Messages /= 0 then
if Warnings_Detected >= Maximum_Messages then
Set_Standard_Error;
Write_Line ("maximum number of warnings output");
Write_Line ("any further warnings suppressed");
Set_Standard_Output;
end if;
-- If too many errors print message
if Total_Errors_Detected >= Maximum_Messages then
Set_Standard_Error;
Write_Line ("fatal error: maximum number of errors detected");
Set_Standard_Output;
end if;
end if;
end Write_Max_Errors;
-- Start of processing for Output_Messages
begin
-- Error if Finalize has not been called
if not Finalize_Called then
raise Program_Error;
end if;
-- Reset current error source file if the main unit has a pragma
-- Source_Reference. This ensures outputting the proper name of
-- the source file in this situation.
if Main_Source_File = No_Source_File
or else Num_SRef_Pragmas (Main_Source_File) /= 0
then
Current_Error_Source_File := No_Source_File;
end if;
-- Brief Error mode
if Brief_Output or (not Full_List and not Verbose_Mode) then
Set_Standard_Error;
E := First_Error_Msg;
while E /= No_Error_Msg loop
if not Errors.Table (E).Deleted and then not Debug_Flag_KK then
if Full_Path_Name_For_Brief_Errors then
Write_Name (Full_Ref_Name (Errors.Table (E).Sfile));
else
Write_Name (Reference_Name (Errors.Table (E).Sfile));
end if;
Write_Char (':');
Write_Int (Int (Physical_To_Logical
(Errors.Table (E).Line,
Errors.Table (E).Sfile)));
Write_Char (':');
if Errors.Table (E).Col < 10 then
Write_Char ('0');
end if;
Write_Int (Int (Errors.Table (E).Col));
Write_Str (": ");
Output_Msg_Text (E);
Write_Eol;
end if;
E := Errors.Table (E).Next;
end loop;
Set_Standard_Output;
end if;
-- Full source listing case
if Full_List then
List_Pragmas_Index := 1;
List_Pragmas_Mode := True;
E := First_Error_Msg;
-- Normal case, to stdout (copyright notice already output)
if Full_List_File_Name = null then
if not Debug_Flag_7 then
Write_Eol;
end if;
-- Output to file
else
Create_List_File_Access.all (Full_List_File_Name.all);
Set_Special_Output (Write_List_Info_Access.all'Access);
-- Write copyright notice to file
if not Debug_Flag_7 then
Write_Str ("GNAT ");
Write_Str (Gnat_Version_String);
Write_Eol;
Write_Str ("Copyright 1992-" &
Current_Year &
", Free Software Foundation, Inc.");
Write_Eol;
end if;
end if;
-- First list extended main source file units with errors
for U in Main_Unit .. Last_Unit loop
if In_Extended_Main_Source_Unit (Cunit_Entity (U))
-- If debug flag d.m is set, only the main source is listed
and then (U = Main_Unit or else not Debug_Flag_Dot_M)
-- If the unit of the entity does not come from source, it is
-- an implicit subprogram declaration for a child subprogram.
-- Do not emit errors for it, they are listed with the body.
and then
(No (Cunit_Entity (U))
or else Comes_From_Source (Cunit_Entity (U))
or else not Is_Subprogram (Cunit_Entity (U)))
-- If the compilation unit associated with this unit does not
-- come from source, it means it is an instantiation that should
-- not be included in the source listing.
and then Comes_From_Source (Cunit (U))
then
declare
Sfile : constant Source_File_Index := Source_Index (U);
begin
Write_Eol;
-- Only write the header if Sfile is known
if Sfile /= No_Source_File then
Write_Header (Sfile);
Write_Eol;
end if;
-- Normally, we don't want an "error messages from file"
-- message when listing the entire file, so we set the
-- current source file as the current error source file.
-- However, the old style of doing things was to list this
-- message if pragma Source_Reference is present, even for
-- the main unit. Since the purpose of the -gnatd.m switch
-- is to duplicate the old behavior, we skip the reset if
-- this debug flag is set.
if not Debug_Flag_Dot_M then
Current_Error_Source_File := Sfile;
end if;
-- Only output the listing if Sfile is known, to avoid
-- crashing the compiler.
if Sfile /= No_Source_File then
for N in 1 .. Last_Source_Line (Sfile) loop
while E /= No_Error_Msg
and then Errors.Table (E).Deleted
loop
E := Errors.Table (E).Next;
end loop;
Err_Flag :=
E /= No_Error_Msg
and then Errors.Table (E).Line = N
and then Errors.Table (E).Sfile = Sfile;
Output_Source_Line (N, Sfile, Err_Flag);
if Err_Flag then
Output_Error_Msgs (E);
if not Debug_Flag_2 then
Write_Eol;
end if;
end if;
end loop;
end if;
end;
end if;
end loop;
-- Then output errors, if any, for subsidiary units not in the
-- main extended unit.
-- Note: if debug flag d.m set, include errors for any units other
-- than the main unit in the extended source unit (e.g. spec and
-- subunits for a body).
while E /= No_Error_Msg
and then (not In_Extended_Main_Source_Unit (Errors.Table (E).Sptr)
or else
(Debug_Flag_Dot_M
and then Get_Source_Unit
(Errors.Table (E).Sptr) /= Main_Unit))
loop
if Errors.Table (E).Deleted then
E := Errors.Table (E).Next;
else
Write_Eol;
Output_Source_Line
(Errors.Table (E).Line, Errors.Table (E).Sfile, True);
Output_Error_Msgs (E);
end if;
end loop;
-- If output to file, write extra copy of error summary to the
-- output file, and then close it.
if Full_List_File_Name /= null then
Write_Error_Summary;
Write_Max_Errors;
Close_List_File_Access.all;
Cancel_Special_Output;
end if;
end if;
-- Verbose mode (error lines only with error flags). Normally this is
-- ignored in full list mode, unless we are listing to a file, in which
-- case we still generate -gnatv output to standard output.
if Verbose_Mode
and then (not Full_List or else Full_List_File_Name /= null)
then
Write_Eol;
-- Output the header only when Main_Source_File is known
if Main_Source_File /= No_Source_File then
Write_Header (Main_Source_File);
end if;
E := First_Error_Msg;
-- Loop through error lines
while E /= No_Error_Msg loop
if Errors.Table (E).Deleted then
E := Errors.Table (E).Next;
else
Write_Eol;
Output_Source_Line
(Errors.Table (E).Line, Errors.Table (E).Sfile, True);
Output_Error_Msgs (E);
end if;
end loop;
end if;
-- Output error summary if verbose or full list mode
if Verbose_Mode or else Full_List then
Write_Error_Summary;
end if;
Write_Max_Errors;
if Warning_Mode = Treat_As_Error then
Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
Warnings_Detected := 0;
end if;
end Output_Messages;
------------------------
-- Output_Source_Line --
------------------------
procedure Output_Source_Line
(L : Physical_Line_Number;
Sfile : Source_File_Index;
Errs : Boolean)
is
S : Source_Ptr;
C : Character;
Line_Number_Output : Boolean := False;
-- Set True once line number is output
Empty_Line : Boolean := True;
-- Set False if line includes at least one character
begin
if Sfile /= Current_Error_Source_File then
Write_Str ("==============Error messages for ");
case Sinput.File_Type (Sfile) is
when Sinput.Src =>
Write_Str ("source");
when Sinput.Config =>
Write_Str ("configuration pragmas");
when Sinput.Def =>
Write_Str ("symbol definition");
when Sinput.Preproc =>
Write_Str ("preprocessing data");
end case;
Write_Str (" file: ");
Write_Name (Full_File_Name (Sfile));
Write_Eol;
if Num_SRef_Pragmas (Sfile) > 0 then
Write_Str ("--------------Line numbers from file: ");
Write_Name (Full_Ref_Name (Sfile));
Write_Str (" (starting at line ");
Write_Int (Int (First_Mapped_Line (Sfile)));
Write_Char (')');
Write_Eol;
end if;
Current_Error_Source_File := Sfile;
end if;
if Errs or List_Pragmas_Mode then
Output_Line_Number (Physical_To_Logical (L, Sfile));
Line_Number_Output := True;
end if;
S := Line_Start (L, Sfile);
loop
C := Source_Text (Sfile) (S);
exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF;
-- Deal with matching entry in List_Pragmas table
if Full_List
and then List_Pragmas_Index <= List_Pragmas.Last
and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc
then
case List_Pragmas.Table (List_Pragmas_Index).Ptyp is
when Page =>
Write_Char (C);
-- Ignore if on line with errors so that error flags
-- get properly listed with the error line .
if not Errs then
Write_Char (ASCII.FF);
end if;
when List_On =>
List_Pragmas_Mode := True;
if not Line_Number_Output then
Output_Line_Number (Physical_To_Logical (L, Sfile));
Line_Number_Output := True;
end if;
Write_Char (C);
when List_Off =>
Write_Char (C);
List_Pragmas_Mode := False;
end case;
List_Pragmas_Index := List_Pragmas_Index + 1;
-- Normal case (no matching entry in List_Pragmas table)
else
if Errs or List_Pragmas_Mode then
Write_Char (C);
end if;
end if;
Empty_Line := False;
S := S + 1;
end loop;
-- If we have output a source line, then add the line terminator, with
-- training spaces preserved (so we output the line exactly as input).
if Line_Number_Output then
if Empty_Line then
Write_Eol;
else
Write_Eol_Keep_Blanks;
end if;
end if;
end Output_Source_Line;
-----------------------------
-- Remove_Warning_Messages --
-----------------------------
procedure Remove_Warning_Messages (N : Node_Id) is
function Check_For_Warning (N : Node_Id) return Traverse_Result;
-- This function checks one node for a possible warning message
function Check_All_Warnings is new Traverse_Func (Check_For_Warning);
-- This defines the traversal operation
-----------------------
-- Check_For_Warning --
-----------------------
function Check_For_Warning (N : Node_Id) return Traverse_Result is
Loc : constant Source_Ptr := Sloc (N);
E : Error_Msg_Id;
function To_Be_Removed (E : Error_Msg_Id) return Boolean;
-- Returns True for a message that is to be removed. Also adjusts
-- warning count appropriately.
-------------------
-- To_Be_Removed --
-------------------
function To_Be_Removed (E : Error_Msg_Id) return Boolean is
begin
if E /= No_Error_Msg
-- Don't remove if location does not match
and then Errors.Table (E).Optr = Loc
-- Don't remove if not warning/info message. Note that we do
-- not remove style messages here. They are warning messages
-- but not ones we want removed in this context.
and then Errors.Table (E).Warn
-- Don't remove unconditional messages
and then not Errors.Table (E).Uncond
then
Warnings_Detected := Warnings_Detected - 1;
return True;
-- No removal required
else
return False;
end if;
end To_Be_Removed;
-- Start of processing for Check_For_Warnings
begin
while To_Be_Removed (First_Error_Msg) loop
First_Error_Msg := Errors.Table (First_Error_Msg).Next;
end loop;
if First_Error_Msg = No_Error_Msg then
Last_Error_Msg := No_Error_Msg;
end if;
E := First_Error_Msg;
while E /= No_Error_Msg loop
while To_Be_Removed (Errors.Table (E).Next) loop
Errors.Table (E).Next :=
Errors.Table (Errors.Table (E).Next).Next;
if Errors.Table (E).Next = No_Error_Msg then
Last_Error_Msg := E;
end if;
end loop;
E := Errors.Table (E).Next;
end loop;
if Nkind (N) = N_Raise_Constraint_Error
and then Original_Node (N) /= N
and then No (Condition (N))
then
-- Warnings may have been posted on subexpressions of the original
-- tree. We place the original node back on the tree to remove
-- those warnings, whose sloc do not match those of any node in
-- the current tree. Given that we are in unreachable code, this
-- modification to the tree is harmless.
declare
Status : Traverse_Final_Result;
begin
if Is_List_Member (N) then
Set_Condition (N, Original_Node (N));
Status := Check_All_Warnings (Condition (N));
else
Rewrite (N, Original_Node (N));
Status := Check_All_Warnings (N);
end if;
return Status;
end;
else
return OK;
end if;
end Check_For_Warning;
-- Start of processing for Remove_Warning_Messages
begin
if Warnings_Detected /= 0 then
declare
Discard : Traverse_Final_Result;
pragma Warnings (Off, Discard);
begin
Discard := Check_All_Warnings (N);
end;
end if;
end Remove_Warning_Messages;
procedure Remove_Warning_Messages (L : List_Id) is
Stat : Node_Id;
begin
if Is_Non_Empty_List (L) then
Stat := First (L);
while Present (Stat) loop
Remove_Warning_Messages (Stat);
Next (Stat);
end loop;
end if;
end Remove_Warning_Messages;
---------------------------
-- Set_Identifier_Casing --
---------------------------
procedure Set_Identifier_Casing
(Identifier_Name : System.Address;
File_Name : System.Address)
is
Ident : constant Big_String_Ptr := To_Big_String_Ptr (Identifier_Name);
File : constant Big_String_Ptr := To_Big_String_Ptr (File_Name);
Flen : Natural;
Desired_Case : Casing_Type := Mixed_Case;
-- Casing required for result. Default value of Mixed_Case is used if
-- for some reason we cannot find the right file name in the table.
begin
-- Get length of file name
Flen := 0;
while File (Flen + 1) /= ASCII.NUL loop
Flen := Flen + 1;
end loop;
-- Loop through file names to find matching one. This is a bit slow, but
-- we only do it in error situations so it is not so terrible. Note that
-- if the loop does not exit, then the desired case will be left set to
-- Mixed_Case, this can happen if the name was not in canonical form,
-- and gets canonicalized on VMS. Possibly we could fix this by
-- unconditionally canonicalizing these names ???
for J in 1 .. Last_Source_File loop
Get_Name_String (Full_Debug_Name (J));
if Name_Len = Flen
and then Name_Buffer (1 .. Name_Len) = String (File (1 .. Flen))
then
Desired_Case := Identifier_Casing (J);
exit;
end if;
end loop;
-- Copy identifier as given to Name_Buffer
for J in Name_Buffer'Range loop
Name_Buffer (J) := Ident (J);
if Name_Buffer (J) = ASCII.NUL then
Name_Len := J - 1;
exit;
end if;
end loop;
Set_Casing (Desired_Case);
end Set_Identifier_Casing;
-----------------------
-- Set_Ignore_Errors --
-----------------------
procedure Set_Ignore_Errors (To : Boolean) is
begin
Errors_Must_Be_Ignored := To;
end Set_Ignore_Errors;
------------------------------
-- Set_Msg_Insertion_Column --
------------------------------
procedure Set_Msg_Insertion_Column is
begin
if RM_Column_Check then
Set_Msg_Str (" in column ");
Set_Msg_Int (Int (Error_Msg_Col) + 1);
end if;
end Set_Msg_Insertion_Column;
----------------------------
-- Set_Msg_Insertion_Node --
----------------------------
procedure Set_Msg_Insertion_Node is
K : Node_Kind;
begin
Suppress_Message :=
Error_Msg_Node_1 = Error
or else Error_Msg_Node_1 = Any_Type;
if Error_Msg_Node_1 = Empty then
Set_Msg_Blank_Conditional;
Set_Msg_Str ("");
elsif Error_Msg_Node_1 = Error then
Set_Msg_Blank;
Set_Msg_Str ("");
elsif Error_Msg_Node_1 = Standard_Void_Type then
Set_Msg_Blank;
Set_Msg_Str ("procedure name");
elsif Nkind (Error_Msg_Node_1) in N_Entity
and then Ekind (Error_Msg_Node_1) = E_Anonymous_Access_Subprogram_Type
then
Set_Msg_Blank;
Set_Msg_Str ("access to subprogram");
else
Set_Msg_Blank_Conditional;
-- Output name
K := Nkind (Error_Msg_Node_1);
-- If we have operator case, skip quotes since name of operator
-- itself will supply the required quotations. An operator can be an
-- applied use in an expression or an explicit operator symbol, or an
-- identifier whose name indicates it is an operator.
if K in N_Op
or else K = N_Operator_Symbol
or else K = N_Defining_Operator_Symbol
or else ((K = N_Identifier or else K = N_Defining_Identifier)
and then Is_Operator_Name (Chars (Error_Msg_Node_1)))
then
Set_Msg_Node (Error_Msg_Node_1);
-- Normal case, not an operator, surround with quotes
else
Set_Msg_Quote;
Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1);
Set_Msg_Node (Error_Msg_Node_1);
Set_Msg_Quote;
end if;
end if;
-- The following assignment ensures that a second ampersand insertion
-- character will correspond to the Error_Msg_Node_2 parameter. We
-- suppress possible validity checks in case operating in -gnatVa mode,
-- and Error_Msg_Node_2 is not needed and has not been set.
declare
pragma Suppress (Range_Check);
begin
Error_Msg_Node_1 := Error_Msg_Node_2;
end;
end Set_Msg_Insertion_Node;
--------------------------------------
-- Set_Msg_Insertion_Type_Reference --
--------------------------------------
procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr) is
Ent : Entity_Id;
begin
Set_Msg_Blank;
if Error_Msg_Node_1 = Standard_Void_Type then
Set_Msg_Str ("package or procedure name");
return;
elsif Error_Msg_Node_1 = Standard_Exception_Type then
Set_Msg_Str ("exception name");
return;
elsif Error_Msg_Node_1 = Any_Access
or else Error_Msg_Node_1 = Any_Array
or else Error_Msg_Node_1 = Any_Boolean
or else Error_Msg_Node_1 = Any_Character
or else Error_Msg_Node_1 = Any_Composite
or else Error_Msg_Node_1 = Any_Discrete
or else Error_Msg_Node_1 = Any_Fixed
or else Error_Msg_Node_1 = Any_Integer
or else Error_Msg_Node_1 = Any_Modular
or else Error_Msg_Node_1 = Any_Numeric
or else Error_Msg_Node_1 = Any_Real
or else Error_Msg_Node_1 = Any_Scalar
or else Error_Msg_Node_1 = Any_String
then
Get_Unqualified_Decoded_Name_String (Chars (Error_Msg_Node_1));
Set_Msg_Name_Buffer;
return;
elsif Error_Msg_Node_1 = Universal_Real then
Set_Msg_Str ("type universal real");
return;
elsif Error_Msg_Node_1 = Universal_Integer then
Set_Msg_Str ("type universal integer");
return;
elsif Error_Msg_Node_1 = Universal_Fixed then
Set_Msg_Str ("type universal fixed");
return;
end if;
-- Special case of anonymous array
if Nkind (Error_Msg_Node_1) in N_Entity
and then Is_Array_Type (Error_Msg_Node_1)
and then Present (Related_Array_Object (Error_Msg_Node_1))
then
Set_Msg_Str ("type of ");
Set_Msg_Node (Related_Array_Object (Error_Msg_Node_1));
Set_Msg_Str (" declared");
Set_Msg_Insertion_Line_Number
(Sloc (Related_Array_Object (Error_Msg_Node_1)), Flag);
return;
end if;
-- If we fall through, it is not a special case, so first output
-- the name of the type, preceded by private for a private type
if Is_Private_Type (Error_Msg_Node_1) then
Set_Msg_Str ("private type ");
else
Set_Msg_Str ("type ");
end if;
Ent := Error_Msg_Node_1;
if Is_Internal_Name (Chars (Ent)) then
Unwind_Internal_Type (Ent);
end if;
-- Types in Standard are displayed as "Standard.name"
if Sloc (Ent) <= Standard_Location then
Set_Msg_Quote;
Set_Msg_Str ("Standard.");
Set_Msg_Node (Ent);
Add_Class;
Set_Msg_Quote;
-- Types in other language defined units are displayed as
-- "package-name.type-name"
elsif
Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Ent)))
then
Get_Unqualified_Decoded_Name_String
(Unit_Name (Get_Source_Unit (Ent)));
Name_Len := Name_Len - 2;
Set_Msg_Blank_Conditional;
Set_Msg_Quote;
Set_Casing (Mixed_Case);
Set_Msg_Name_Buffer;
Set_Msg_Char ('.');
Set_Casing (Mixed_Case);
Set_Msg_Node (Ent);
Add_Class;
Set_Msg_Quote;
-- All other types display as "type name" defined at line xxx
-- possibly qualified if qualification is requested.
else
Set_Msg_Quote;
Set_Qualification (Error_Msg_Qual_Level, Ent);
Set_Msg_Node (Ent);
Add_Class;
-- If we did not print a name (e.g. in the case of an anonymous
-- subprogram type), there is no name to print, so remove quotes.
if Buffer_Ends_With ('"') then
Buffer_Remove ('"');
else
Set_Msg_Quote;
end if;
end if;
-- If the original type did not come from a predefined file, add the
-- location where the type was defined.
if Sloc (Error_Msg_Node_1) > Standard_Location
and then
not Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1)))
then
Set_Msg_Str (" defined");
Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag);
-- If it did come from a predefined file, deal with the case where
-- this was a file with a generic instantiation from elsewhere.
else
if Sloc (Error_Msg_Node_1) > Standard_Location then
declare
Iloc : constant Source_Ptr :=
Instantiation_Location (Sloc (Error_Msg_Node_1));
begin
if Iloc /= No_Location
and then not Suppress_Instance_Location
then
Set_Msg_Str (" from instance");
Set_Msg_Insertion_Line_Number (Iloc, Flag);
end if;
end;
end if;
end if;
end Set_Msg_Insertion_Type_Reference;
---------------------------------
-- Set_Msg_Insertion_Unit_Name --
---------------------------------
procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True) is
begin
if Error_Msg_Unit_1 = No_Unit_Name then
null;
elsif Error_Msg_Unit_1 = Error_Unit_Name then
Set_Msg_Blank;
Set_Msg_Str ("");
else
Get_Unit_Name_String (Error_Msg_Unit_1, Suffix);
Set_Msg_Blank;
Set_Msg_Quote;
Set_Msg_Name_Buffer;
Set_Msg_Quote;
end if;
-- The following assignment ensures that a second percent insertion
-- character will correspond to the Error_Msg_Unit_2 parameter. We
-- suppress possible validity checks in case operating in -gnatVa mode,
-- and Error_Msg_Unit_2 is not needed and has not been set.
declare
pragma Suppress (Range_Check);
begin
Error_Msg_Unit_1 := Error_Msg_Unit_2;
end;
end Set_Msg_Insertion_Unit_Name;
------------------
-- Set_Msg_Node --
------------------
procedure Set_Msg_Node (Node : Node_Id) is
Ent : Entity_Id;
Nam : Name_Id;
begin
case Nkind (Node) is
when N_Designator =>
Set_Msg_Node (Name (Node));
Set_Msg_Char ('.');
Set_Msg_Node (Identifier (Node));
return;
when N_Defining_Program_Unit_Name =>
Set_Msg_Node (Name (Node));
Set_Msg_Char ('.');
Set_Msg_Node (Defining_Identifier (Node));
return;
when N_Selected_Component | N_Expanded_Name =>
Set_Msg_Node (Prefix (Node));
Set_Msg_Char ('.');
Set_Msg_Node (Selector_Name (Node));
return;
when others =>
null;
end case;
-- The only remaining possibilities are identifiers, defining
-- identifiers, pragmas, and pragma argument associations.
if Nkind (Node) = N_Pragma then
Nam := Pragma_Name (Node);
-- The other cases have Chars fields, and we want to test for possible
-- internal names, which generally represent something gone wrong. An
-- exception is the case of internal type names, where we try to find a
-- reasonable external representation for the external name
elsif Is_Internal_Name (Chars (Node))
and then
((Is_Entity_Name (Node)
and then Present (Entity (Node))
and then Is_Type (Entity (Node)))
or else
(Nkind (Node) = N_Defining_Identifier and then Is_Type (Node)))
then
if Nkind (Node) = N_Identifier then
Ent := Entity (Node);
else
Ent := Node;
end if;
-- If the type is the designated type of an access_to_subprogram,
-- then there is no name to provide in the call.
if Ekind (Ent) = E_Subprogram_Type then
return;
-- Otherwise, we will be able to find some kind of name to output
else
Unwind_Internal_Type (Ent);
Nam := Chars (Ent);
end if;
-- If not internal name, just use name in Chars field
else
Nam := Chars (Node);
end if;
-- At this stage, the name to output is in Nam
Get_Unqualified_Decoded_Name_String (Nam);
-- Remove trailing upper case letters from the name (useful for
-- dealing with some cases of internal names.
while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop
Name_Len := Name_Len - 1;
end loop;
-- If we have any of the names from standard that start with the
-- characters "any " (e.g. Any_Type), then kill the message since
-- almost certainly it is a junk cascaded message.
if Name_Len > 4
and then Name_Buffer (1 .. 4) = "any "
then
Kill_Message := True;
end if;
-- Now we have to set the proper case. If we have a source location
-- then do a check to see if the name in the source is the same name
-- as the name in the Names table, except for possible differences
-- in case, which is the case when we can copy from the source.
declare
Src_Loc : constant Source_Ptr := Sloc (Node);
Sbuffer : Source_Buffer_Ptr;
Ref_Ptr : Integer;
Src_Ptr : Source_Ptr;
begin
Ref_Ptr := 1;
Src_Ptr := Src_Loc;
-- For standard locations, always use mixed case
if Src_Loc <= No_Location
or else Sloc (Node) <= No_Location
then
Set_Casing (Mixed_Case);
else
-- Determine if the reference we are dealing with corresponds to
-- text at the point of the error reference. This will often be
-- the case for simple identifier references, and is the case
-- where we can copy the spelling from the source.
Sbuffer := Source_Text (Get_Source_File_Index (Src_Loc));
while Ref_Ptr <= Name_Len loop
exit when
Fold_Lower (Sbuffer (Src_Ptr)) /=
Fold_Lower (Name_Buffer (Ref_Ptr));
Ref_Ptr := Ref_Ptr + 1;
Src_Ptr := Src_Ptr + 1;
end loop;
-- If we get through the loop without a mismatch, then output the
-- name the way it is spelled in the source program
if Ref_Ptr > Name_Len then
Src_Ptr := Src_Loc;
for J in 1 .. Name_Len loop
Name_Buffer (J) := Sbuffer (Src_Ptr);
Src_Ptr := Src_Ptr + 1;
end loop;
-- Otherwise set the casing using the default identifier casing
else
Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
end if;
end if;
end;
Set_Msg_Name_Buffer;
Add_Class;
end Set_Msg_Node;
------------------
-- Set_Msg_Text --
------------------
procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
C : Character; -- Current character
P : Natural; -- Current index;
procedure Skip_Msg_Insertion_Warning (C : Character);
-- Deal with ? ?? ?x? ?X? ?*? ?$? insertion sequences (and the same
-- sequences using < instead of ?). The caller has already bumped
-- the pointer past the initial ? or < and C is set to this initial
-- character (? or <). This procedure skips past the rest of the
-- sequence. We do not need to set Msg_Insertion_Char, since this
-- was already done during the message prescan.
--------------------------------
-- Skip_Msg_Insertion_Warning --
--------------------------------
procedure Skip_Msg_Insertion_Warning (C : Character) is
begin
if P <= Text'Last and then Text (P) = C then
P := P + 1;
elsif P + 1 <= Text'Last
and then (Text (P) in 'a' .. 'z'
or else
Text (P) in 'A' .. 'Z'
or else
Text (P) = '*'
or else
Text (P) = '$')
and then Text (P + 1) = C
then
P := P + 2;
end if;
end Skip_Msg_Insertion_Warning;
-- Start of processing for Set_Msg_Text
begin
Manual_Quote_Mode := False;
Msglen := 0;
Flag_Source := Get_Source_File_Index (Flag);
-- Skip info: at start, we have recorded this in Is_Info_Msg, and this
-- will be used (Info field in error message object) to put back the
-- string when it is printed. We need to do this, or we get confused
-- with instantiation continuations.
if Text'Length > 6
and then Text (Text'First .. Text'First + 5) = "info: "
then
P := Text'First + 6;
else
P := Text'First;
end if;
-- Loop through characters of message
while P <= Text'Last loop
C := Text (P);
P := P + 1;
-- Check for insertion character or sequence
case C is
when '%' =>
if P <= Text'Last and then Text (P) = '%' then
P := P + 1;
Set_Msg_Insertion_Name_Literal;
else
Set_Msg_Insertion_Name;
end if;
when '$' =>
if P <= Text'Last and then Text (P) = '$' then
P := P + 1;
Set_Msg_Insertion_Unit_Name (Suffix => False);
else
Set_Msg_Insertion_Unit_Name;
end if;
when '{' =>
Set_Msg_Insertion_File_Name;
when '}' =>
Set_Msg_Insertion_Type_Reference (Flag);
when '*' =>
Set_Msg_Insertion_Reserved_Name;
when '&' =>
Set_Msg_Insertion_Node;
when '#' =>
Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
when '\' =>
Continuation := True;
if Text (P) = '\' then
Continuation_New_Line := True;
P := P + 1;
end if;
when '@' =>
Set_Msg_Insertion_Column;
when '>' =>
Set_Msg_Insertion_Run_Time_Name;
when '^' =>
Set_Msg_Insertion_Uint;
when '`' =>
Manual_Quote_Mode := not Manual_Quote_Mode;
Set_Msg_Char ('"');
when '!' =>
null; -- already dealt with
when '?' =>
Skip_Msg_Insertion_Warning ('?');
when '<' =>
Skip_Msg_Insertion_Warning ('<');
when '|' =>
null; -- already dealt with
when ''' =>
Set_Msg_Char (Text (P));
P := P + 1;
when '~' =>
Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen));
-- Upper case letter
when 'A' .. 'Z' =>
-- Start of reserved word if two or more
if P <= Text'Last and then Text (P) in 'A' .. 'Z' then
P := P - 1;
Set_Msg_Insertion_Reserved_Word (Text, P);
-- Single upper case letter is just inserted
else
Set_Msg_Char (C);
end if;
-- '[' (will be/would have been raised at run time)
when '[' =>
if Is_Warning_Msg then
Set_Msg_Str ("will be raised at run time");
else
Set_Msg_Str ("would have been raised at run time");
end if;
-- ']' (may be/might have been raised at run time)
when ']' =>
if Is_Warning_Msg then
Set_Msg_Str ("may be raised at run time");
else
Set_Msg_Str ("might have been raised at run time");
end if;
-- Normal character with no special treatment
when others =>
Set_Msg_Char (C);
end case;
end loop;
VMS_Convert;
end Set_Msg_Text;
----------------
-- Set_Posted --
----------------
procedure Set_Posted (N : Node_Id) is
P : Node_Id;
begin
if Is_Serious_Error then
-- We always set Error_Posted on the node itself
Set_Error_Posted (N);
-- If it is a subexpression, then set Error_Posted on parents up to
-- and including the first non-subexpression construct. This helps
-- avoid cascaded error messages within a single expression.
P := N;
loop
P := Parent (P);
exit when No (P);
Set_Error_Posted (P);
exit when Nkind (P) not in N_Subexpr;
end loop;
if Nkind_In (P, N_Pragma_Argument_Association,
N_Component_Association,
N_Discriminant_Association,
N_Generic_Association,
N_Parameter_Association)
then
Set_Error_Posted (Parent (P));
end if;
-- A special check, if we just posted an error on an attribute
-- definition clause, then also set the entity involved as posted.
-- For example, this stops complaining about the alignment after
-- complaining about the size, which is likely to be useless.
if Nkind (P) = N_Attribute_Definition_Clause then
if Is_Entity_Name (Name (P)) then
Set_Error_Posted (Entity (Name (P)));
end if;
end if;
end if;
end Set_Posted;
-----------------------
-- Set_Qualification --
-----------------------
procedure Set_Qualification (N : Nat; E : Entity_Id) is
begin
if N /= 0 and then Scope (E) /= Standard_Standard then
Set_Qualification (N - 1, Scope (E));
Set_Msg_Node (Scope (E));
Set_Msg_Char ('.');
end if;
end Set_Qualification;
------------------------
-- Special_Msg_Delete --
------------------------
-- Is it really right to have all this specialized knowledge in errout?
function Special_Msg_Delete
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id) return Boolean
is
begin
-- Never delete messages in -gnatdO mode
if Debug_Flag_OO then
return False;
-- Processing for "atomic access cannot be guaranteed"
elsif Msg = "atomic access to & cannot be guaranteed" then
-- When an atomic object refers to a non-atomic type in the same
-- scope, we implicitly make the type atomic. In the non-error case
-- this is surely safe (and in fact prevents an error from occurring
-- if the type is not atomic by default). But if the object cannot be
-- made atomic, then we introduce an extra junk message by this
-- manipulation, which we get rid of here.
-- We identify this case by the fact that it references a type for
-- which Is_Atomic is set, but there is no Atomic pragma setting it.
if Is_Type (E)
and then Is_Atomic (E)
and then No (Get_Rep_Pragma (E, Name_Atomic))
then
return True;
end if;
-- Processing for "Size too small" messages
elsif Msg = "size for& too small, minimum allowed is ^" then
-- Suppress "size too small" errors in CodePeer mode, since code may
-- be analyzed in a different configuration than the one used for
-- compilation. Even when the configurations match, this message
-- may be issued on correct code, because pragma Pack is ignored
-- in CodePeer mode.
if CodePeer_Mode then
return True;
-- When a size is wrong for a frozen type there is no explicit size
-- clause, and other errors have occurred, suppress the message,
-- since it is likely that this size error is a cascaded result of
-- other errors. The reason we eliminate unfrozen types is that
-- messages issued before the freeze type are for sure OK.
elsif Is_Frozen (E)
and then Serious_Errors_Detected > 0
and then Nkind (N) /= N_Component_Clause
and then Nkind (Parent (N)) /= N_Component_Clause
and then
No (Get_Attribute_Definition_Clause (E, Attribute_Size))
and then
No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size))
and then
No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size))
then
return True;
end if;
end if;
-- All special tests complete, so go ahead with message
return False;
end Special_Msg_Delete;
-----------------
-- SPARK_Msg_N --
-----------------
procedure SPARK_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
begin
if SPARK_Mode = On then
Error_Msg_N (Msg, N);
end if;
end SPARK_Msg_N;
------------------
-- SPARK_Msg_NE --
------------------
procedure SPARK_Msg_NE
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id)
is
begin
if SPARK_Mode = On then
Error_Msg_NE (Msg, N, E);
end if;
end SPARK_Msg_NE;
--------------------------
-- Unwind_Internal_Type --
--------------------------
procedure Unwind_Internal_Type (Ent : in out Entity_Id) is
Derived : Boolean := False;
Mchar : Character;
Old_Ent : Entity_Id;
begin
-- Undo placement of a quote, since we will put it back later
Mchar := Msg_Buffer (Msglen);
if Mchar = '"' then
Msglen := Msglen - 1;
end if;
-- The loop here deals with recursive types, we are trying to find a
-- related entity that is not an implicit type. Note that the check with
-- Old_Ent stops us from getting "stuck". Also, we don't output the
-- "type derived from" message more than once in the case where we climb
-- up multiple levels.
Find : loop
Old_Ent := Ent;
-- Implicit access type, use directly designated type In Ada 2005,
-- the designated type may be an anonymous access to subprogram, in
-- which case we can only point to its definition.
if Is_Access_Type (Ent) then
if Ekind (Ent) = E_Access_Subprogram_Type
or else Ekind (Ent) = E_Anonymous_Access_Subprogram_Type
or else Is_Access_Protected_Subprogram_Type (Ent)
then
Ent := Directly_Designated_Type (Ent);
if not Comes_From_Source (Ent) then
if Buffer_Ends_With ("type ") then
Buffer_Remove ("type ");
end if;
end if;
if Ekind (Ent) = E_Function then
Set_Msg_Str ("access to function ");
elsif Ekind (Ent) = E_Procedure then
Set_Msg_Str ("access to procedure ");
else
Set_Msg_Str ("access to subprogram");
end if;
exit Find;
-- Type is access to object, named or anonymous
else
Set_Msg_Str ("access to ");
Ent := Directly_Designated_Type (Ent);
end if;
-- Classwide type
elsif Is_Class_Wide_Type (Ent) then
Class_Flag := True;
Ent := Root_Type (Ent);
-- Use base type if this is a subtype
elsif Ent /= Base_Type (Ent) then
Buffer_Remove ("type ");
-- Avoid duplication "subtype of subtype of", and also replace
-- "derived from subtype of" simply by "derived from"
if not Buffer_Ends_With ("subtype of ")
and then not Buffer_Ends_With ("derived from ")
then
Set_Msg_Str ("subtype of ");
end if;
Ent := Base_Type (Ent);
-- If this is a base type with a first named subtype, use the first
-- named subtype instead. This is not quite accurate in all cases,
-- but it makes too much noise to be accurate and add 'Base in all
-- cases. Note that we only do this is the first named subtype is not
-- itself an internal name. This avoids the obvious loop (subtype ->
-- basetype -> subtype) which would otherwise occur).
else
declare
FST : constant Entity_Id := First_Subtype (Ent);
begin
if not Is_Internal_Name (Chars (FST)) then
Ent := FST;
exit Find;
-- Otherwise use root type
else
if not Derived then
Buffer_Remove ("type ");
-- Test for "subtype of type derived from" which seems
-- excessive and is replaced by "type derived from".
Buffer_Remove ("subtype of");
-- Avoid duplicated "type derived from type derived from"
if not Buffer_Ends_With ("type derived from ") then
Set_Msg_Str ("type derived from ");
end if;
Derived := True;
end if;
end if;
end;
Ent := Etype (Ent);
end if;
-- If we are stuck in a loop, get out and settle for the internal
-- name after all. In this case we set to kill the message if it is
-- not the first error message (we really try hard not to show the
-- dirty laundry of the implementation to the poor user).
if Ent = Old_Ent then
Kill_Message := True;
exit Find;
end if;
-- Get out if we finally found a non-internal name to use
exit Find when not Is_Internal_Name (Chars (Ent));
end loop Find;
if Mchar = '"' then
Set_Msg_Char ('"');
end if;
end Unwind_Internal_Type;
-----------------
-- VMS_Convert --
-----------------
procedure VMS_Convert is
P : Natural;
L : Natural;
N : Natural;
begin
if not OpenVMS then
return;
end if;
P := Msg_Buffer'First;
loop
if P >= Msglen then
return;
end if;
if Msg_Buffer (P) = '-' then
for G in Gnames'Range loop
L := Gnames (G)'Length;
-- See if we have "-ggg switch", where ggg is Gnames entry
if P + L + 7 <= Msglen
and then Msg_Buffer (P + 1 .. P + L) = Gnames (G).all
and then Msg_Buffer (P + L + 1 .. P + L + 7) = " switch"
then
-- Replace by "/vvv qualifier", where vvv is Vnames entry
N := Vnames (G)'Length;
Msg_Buffer (P + N + 11 .. Msglen + N - L + 3) :=
Msg_Buffer (P + L + 8 .. Msglen);
Msg_Buffer (P) := '/';
Msg_Buffer (P + 1 .. P + N) := Vnames (G).all;
Msg_Buffer (P + N + 1 .. P + N + 10) := " qualifier";
P := P + N + 10;
Msglen := Msglen + N - L + 3;
exit;
end if;
end loop;
end if;
P := P + 1;
end loop;
end VMS_Convert;
--------------------
-- Warn_Insertion --
--------------------
function Warn_Insertion return String is
begin
case Warning_Msg_Char is
when '?' =>
return "??";
when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' =>
return '?' & Warning_Msg_Char & '?';
when ' ' =>
return "?";
when others =>
raise Program_Error;
end case;
end Warn_Insertion;
end Errout;
gprbuild-gpl-2014-src/gnat/lib.adb 0000644 0000767 0000145 00000105461 12323721731 016311 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- L I B --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, 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 3, 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. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- >
null;
end loop;
end Check_Same_Extended_Unit;
-------------------------------
-- Compilation_Switches_Last --
-------------------------------
function Compilation_Switches_Last return Nat is
begin
return Compilation_Switches.Last;
end Compilation_Switches_Last;
---------------------------
-- Enable_Switch_Storing --
---------------------------
procedure Enable_Switch_Storing is
begin
Switch_Storing_Enabled := True;
end Enable_Switch_Storing;
----------------------------
-- Disable_Switch_Storing --
----------------------------
procedure Disable_Switch_Storing is
begin
Switch_Storing_Enabled := False;
end Disable_Switch_Storing;
------------------------------
-- Earlier_In_Extended_Unit --
------------------------------
function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is
begin
return Check_Same_Extended_Unit (S1, S2) = Yes_Before;
end Earlier_In_Extended_Unit;
-----------------------
-- Exact_Source_Name --
-----------------------
function Exact_Source_Name (Loc : Source_Ptr) return String is
U : constant Unit_Number_Type := Get_Source_Unit (Loc);
Buf : constant Source_Buffer_Ptr := Source_Text (Source_Index (U));
Orig : constant Source_Ptr := Original_Location (Loc);
P : Source_Ptr;
WC : Char_Code;
Err : Boolean;
pragma Warnings (Off, WC);
pragma Warnings (Off, Err);
begin
-- Entity is character literal
if Buf (Orig) = ''' then
return String (Buf (Orig .. Orig + 2));
-- Entity is operator symbol
elsif Buf (Orig) = '"' or else Buf (Orig) = '%' then
P := Orig;
loop
P := P + 1;
exit when Buf (P) = Buf (Orig);
end loop;
return String (Buf (Orig .. P));
-- Entity is identifier
else
P := Orig;
loop
if Is_Start_Of_Wide_Char (Buf, P) then
Scan_Wide (Buf, P, WC, Err);
elsif not Identifier_Char (Buf (P)) then
exit;
else
P := P + 1;
end if;
end loop;
-- Write out the identifier by copying the exact source characters
-- used in its declaration. Note that this means wide characters will
-- be in their original encoded form.
return String (Buf (Orig .. P - 1));
end if;
end Exact_Source_Name;
----------------------------
-- Entity_Is_In_Main_Unit --
----------------------------
function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean is
S : Entity_Id;
begin
S := Scope (E);
while S /= Standard_Standard loop
if S = Main_Unit_Entity then
return True;
elsif Ekind (S) = E_Package and then Is_Child_Unit (S) then
return False;
else
S := Scope (S);
end if;
end loop;
return False;
end Entity_Is_In_Main_Unit;
--------------------------
-- Generic_May_Lack_ALI --
--------------------------
function Generic_May_Lack_ALI (Sfile : File_Name_Type) return Boolean is
begin
-- We allow internal generic units to be used without having a
-- corresponding ALI files to help bootstrapping with older compilers
-- that did not support generating ALIs for such generics. It is safe
-- to do so because the only thing the generated code would contain
-- is the elaboration boolean, and we are careful to elaborate all
-- predefined units first anyway.
return Is_Internal_File_Name
(Fname => Sfile,
Renamings_Included => True);
end Generic_May_Lack_ALI;
-----------------------------
-- Get_Code_Or_Source_Unit --
-----------------------------
function Get_Code_Or_Source_Unit
(S : Source_Ptr;
Unwind_Instances : Boolean) return Unit_Number_Type
is
begin
-- Search table unless we have No_Location, which can happen if the
-- relevant location has not been set yet. Happens for example when
-- we obtain Sloc (Cunit (Main_Unit)) before it is set.
if S /= No_Location then
declare
Source_File : Source_File_Index;
Source_Unit : Unit_Number_Type;
begin
Source_File := Get_Source_File_Index (S);
if Unwind_Instances then
while Template (Source_File) /= No_Source_File loop
Source_File := Template (Source_File);
end loop;
end if;
Source_Unit := Unit (Source_File);
if Source_Unit /= No_Unit then
return Source_Unit;
end if;
end;
end if;
-- If S was No_Location, or was not in the table, we must be in the main
-- source unit (and the value has not been placed in the table yet),
-- or in one of the configuration pragma files.
return Main_Unit;
end Get_Code_Or_Source_Unit;
-------------------
-- Get_Code_Unit --
-------------------
function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type is
begin
return Get_Code_Or_Source_Unit (Top_Level_Location (S),
Unwind_Instances => False);
end Get_Code_Unit;
function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is
begin
return Get_Code_Unit (Sloc (N));
end Get_Code_Unit;
----------------------------
-- Get_Compilation_Switch --
----------------------------
function Get_Compilation_Switch (N : Pos) return String_Ptr is
begin
if N <= Compilation_Switches.Last then
return Compilation_Switches.Table (N);
else
return null;
end if;
end Get_Compilation_Switch;
----------------------------------
-- Get_Cunit_Entity_Unit_Number --
----------------------------------
function Get_Cunit_Entity_Unit_Number
(E : Entity_Id) return Unit_Number_Type
is
begin
for U in Units.First .. Units.Last loop
if Cunit_Entity (U) = E then
return U;
end if;
end loop;
-- If not in the table, must be the main source unit, and we just
-- have not got it put into the table yet.
return Main_Unit;
end Get_Cunit_Entity_Unit_Number;
---------------------------
-- Get_Cunit_Unit_Number --
---------------------------
function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type is
begin
for U in Units.First .. Units.Last loop
if Cunit (U) = N then
return U;
end if;
end loop;
-- If not in the table, must be a spec created for a main unit that is a
-- child subprogram body which we have not inserted into the table yet.
if N = Library_Unit (Cunit (Main_Unit)) then
return Main_Unit;
-- If it is anything else, something is seriously wrong, and we really
-- don't want to proceed, even if assertions are off, so we explicitly
-- raise an exception in this case to terminate compilation.
else
raise Program_Error;
end if;
end Get_Cunit_Unit_Number;
---------------------
-- Get_Source_Unit --
---------------------
function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type is
begin
return Get_Code_Or_Source_Unit (S, Unwind_Instances => True);
end Get_Source_Unit;
function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is
begin
return Get_Source_Unit (Sloc (N));
end Get_Source_Unit;
--------------------------------
-- In_Extended_Main_Code_Unit --
--------------------------------
function In_Extended_Main_Code_Unit
(N : Node_Or_Entity_Id) return Boolean
is
begin
if Sloc (N) = Standard_Location then
return False;
elsif Sloc (N) = No_Location then
return False;
-- Special case Itypes to test the Sloc of the associated node. The
-- reason we do this is for possible calls from gigi after -gnatD
-- processing is complete in sprint. This processing updates the
-- sloc fields of all nodes in the tree, but itypes are not in the
-- tree so their slocs do not get updated.
elsif Nkind (N) = N_Defining_Identifier
and then Is_Itype (N)
then
return In_Extended_Main_Code_Unit (Associated_Node_For_Itype (N));
-- Otherwise see if we are in the main unit
elsif Get_Code_Unit (Sloc (N)) = Get_Code_Unit (Cunit (Main_Unit)) then
return True;
-- Node may be in spec (or subunit etc) of main unit
else
return
In_Same_Extended_Unit (N, Cunit (Main_Unit));
end if;
end In_Extended_Main_Code_Unit;
function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean is
begin
if Loc = Standard_Location then
return False;
elsif Loc = No_Location then
return False;
-- Otherwise see if we are in the main unit
elsif Get_Code_Unit (Loc) = Get_Code_Unit (Cunit (Main_Unit)) then
return True;
-- Location may be in spec (or subunit etc) of main unit
else
return
In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit)));
end if;
end In_Extended_Main_Code_Unit;
----------------------------------
-- In_Extended_Main_Source_Unit --
----------------------------------
function In_Extended_Main_Source_Unit
(N : Node_Or_Entity_Id) return Boolean
is
Nloc : constant Source_Ptr := Sloc (N);
Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
begin
-- If parsing, then use the global flag to indicate result
if Compiler_State = Parsing then
return Parsing_Main_Extended_Source;
-- Special value cases
elsif Nloc = Standard_Location then
return False;
elsif Nloc = No_Location then
return False;
-- Special case Itypes to test the Sloc of the associated node. The
-- reason we do this is for possible calls from gigi after -gnatD
-- processing is complete in sprint. This processing updates the
-- sloc fields of all nodes in the tree, but itypes are not in the
-- tree so their slocs do not get updated.
elsif Nkind (N) = N_Defining_Identifier
and then Is_Itype (N)
then
return In_Extended_Main_Source_Unit (Associated_Node_For_Itype (N));
-- Otherwise compare original locations to see if in same unit
else
return
In_Same_Extended_Unit
(Original_Location (Nloc), Original_Location (Mloc));
end if;
end In_Extended_Main_Source_Unit;
function In_Extended_Main_Source_Unit
(Loc : Source_Ptr) return Boolean
is
Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
begin
-- If parsing, then use the global flag to indicate result
if Compiler_State = Parsing then
return Parsing_Main_Extended_Source;
-- Special value cases
elsif Loc = Standard_Location then
return False;
elsif Loc = No_Location then
return False;
-- Otherwise compare original locations to see if in same unit
else
return
In_Same_Extended_Unit
(Original_Location (Loc), Original_Location (Mloc));
end if;
end In_Extended_Main_Source_Unit;
------------------------
-- In_Predefined_Unit --
------------------------
function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean is
begin
return In_Predefined_Unit (Sloc (N));
end In_Predefined_Unit;
function In_Predefined_Unit (S : Source_Ptr) return Boolean is
Unit : constant Unit_Number_Type := Get_Source_Unit (S);
File : constant File_Name_Type := Unit_File_Name (Unit);
begin
return Is_Predefined_File_Name (File);
end In_Predefined_Unit;
-----------------------
-- In_Same_Code_Unit --
-----------------------
function In_Same_Code_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is
S1 : constant Source_Ptr := Sloc (N1);
S2 : constant Source_Ptr := Sloc (N2);
begin
if S1 = No_Location or else S2 = No_Location then
return False;
elsif S1 = Standard_Location then
return S2 = Standard_Location;
elsif S2 = Standard_Location then
return False;
end if;
return Get_Code_Unit (N1) = Get_Code_Unit (N2);
end In_Same_Code_Unit;
---------------------------
-- In_Same_Extended_Unit --
---------------------------
function In_Same_Extended_Unit
(N1, N2 : Node_Or_Entity_Id) return Boolean
is
begin
return Check_Same_Extended_Unit (Sloc (N1), Sloc (N2)) /= No;
end In_Same_Extended_Unit;
function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is
begin
return Check_Same_Extended_Unit (S1, S2) /= No;
end In_Same_Extended_Unit;
-------------------------
-- In_Same_Source_Unit --
-------------------------
function In_Same_Source_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is
S1 : constant Source_Ptr := Sloc (N1);
S2 : constant Source_Ptr := Sloc (N2);
begin
if S1 = No_Location or else S2 = No_Location then
return False;
elsif S1 = Standard_Location then
return S2 = Standard_Location;
elsif S2 = Standard_Location then
return False;
end if;
return Get_Source_Unit (N1) = Get_Source_Unit (N2);
end In_Same_Source_Unit;
-----------------------------
-- Increment_Serial_Number --
-----------------------------
function Increment_Serial_Number return Nat is
TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
begin
TSN := TSN + 1;
return TSN;
end Increment_Serial_Number;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
Linker_Option_Lines.Init;
Notes.Init;
Load_Stack.Init;
Units.Init;
Compilation_Switches.Init;
end Initialize;
---------------
-- Is_Loaded --
---------------
function Is_Loaded (Uname : Unit_Name_Type) return Boolean is
begin
for Unum in Units.First .. Units.Last loop
if Uname = Unit_Name (Unum) then
return True;
end if;
end loop;
return False;
end Is_Loaded;
---------------
-- Last_Unit --
---------------
function Last_Unit return Unit_Number_Type is
begin
return Units.Last;
end Last_Unit;
----------
-- List --
----------
procedure List (File_Names_Only : Boolean := False) is separate;
----------
-- Lock --
----------
procedure Lock is
begin
Linker_Option_Lines.Locked := True;
Load_Stack.Locked := True;
Units.Locked := True;
Linker_Option_Lines.Release;
Load_Stack.Release;
Units.Release;
end Lock;
---------------
-- Num_Units --
---------------
function Num_Units return Nat is
begin
return Int (Units.Last) - Int (Main_Unit) + 1;
end Num_Units;
-----------------
-- Remove_Unit --
-----------------
procedure Remove_Unit (U : Unit_Number_Type) is
begin
if U = Units.Last then
Units.Decrement_Last;
end if;
end Remove_Unit;
----------------------------------
-- Replace_Linker_Option_String --
----------------------------------
procedure Replace_Linker_Option_String
(S : String_Id; Match_String : String)
is
begin
if Match_String'Length > 0 then
for J in 1 .. Linker_Option_Lines.Last loop
String_To_Name_Buffer (Linker_Option_Lines.Table (J).Option);
if Match_String = Name_Buffer (1 .. Match_String'Length) then
Linker_Option_Lines.Table (J).Option := S;
return;
end if;
end loop;
end if;
Store_Linker_Option_String (S);
end Replace_Linker_Option_String;
----------
-- Sort --
----------
procedure Sort (Tbl : in out Unit_Ref_Table) is separate;
------------------------------
-- Store_Compilation_Switch --
------------------------------
procedure Store_Compilation_Switch (Switch : String) is
begin
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
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;
--------------------------------
-- Store_Linker_Option_String --
--------------------------------
procedure Store_Linker_Option_String (S : String_Id) is
begin
Linker_Option_Lines.Append ((Option => S, Unit => Current_Sem_Unit));
end Store_Linker_Option_String;
----------------
-- Store_Note --
----------------
procedure Store_Note (N : Node_Id) is
begin
Notes.Append ((Pragma_Node => N, Unit => Current_Sem_Unit));
end Store_Note;
-------------------------------
-- Synchronize_Serial_Number --
-------------------------------
procedure Synchronize_Serial_Number is
TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
begin
TSN := TSN + 1;
end Synchronize_Serial_Number;
---------------
-- Tree_Read --
---------------
procedure Tree_Read is
N : Nat;
S : String_Ptr;
begin
Units.Tree_Read;
-- Read Compilation_Switches table. First release the memory occupied
-- by the previously loaded switches.
for J in Compilation_Switches.First .. Compilation_Switches.Last loop
Free (Compilation_Switches.Table (J));
end loop;
Tree_Read_Int (N);
Compilation_Switches.Set_Last (N);
for J in 1 .. N loop
Tree_Read_Str (S);
Compilation_Switches.Table (J) := S;
end loop;
end Tree_Read;
----------------
-- Tree_Write --
----------------
procedure Tree_Write is
begin
Units.Tree_Write;
-- Write Compilation_Switches table
Tree_Write_Int (Compilation_Switches.Last);
for J in 1 .. Compilation_Switches.Last loop
Tree_Write_Str (Compilation_Switches.Table (J));
end loop;
end Tree_Write;
------------
-- Unlock --
------------
procedure Unlock is
begin
Linker_Option_Lines.Locked := False;
Load_Stack.Locked := False;
Units.Locked := False;
end Unlock;
-----------------
-- Version_Get --
-----------------
function Version_Get (U : Unit_Number_Type) return Word_Hex_String is
begin
return Get_Hex_String (Units.Table (U).Version);
end Version_Get;
------------------------
-- Version_Referenced --
------------------------
procedure Version_Referenced (S : String_Id) is
begin
Version_Ref.Append (S);
end Version_Referenced;
---------------------
-- Write_Unit_Info --
---------------------
procedure Write_Unit_Info
(Unit_Num : Unit_Number_Type;
Item : Node_Id;
Prefix : String := "";
Withs : Boolean := False)
is
begin
Write_Str (Prefix);
Write_Unit_Name (Unit_Name (Unit_Num));
Write_Str (", unit ");
Write_Int (Int (Unit_Num));
Write_Str (", ");
Write_Int (Int (Item));
Write_Str ("=");
Write_Str (Node_Kind'Image (Nkind (Item)));
if Item /= Original_Node (Item) then
Write_Str (", orig = ");
Write_Int (Int (Original_Node (Item)));
Write_Str ("=");
Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
end if;
Write_Eol;
-- Skip the rest if we're not supposed to print the withs
if not Withs then
return;
end if;
declare
Context_Item : Node_Id;
begin
Context_Item := First (Context_Items (Cunit (Unit_Num)));
while Present (Context_Item)
and then (Nkind (Context_Item) /= N_With_Clause
or else Limited_Present (Context_Item))
loop
Context_Item := Next (Context_Item);
end loop;
if Present (Context_Item) then
Indent;
Write_Line ("withs:");
Indent;
while Present (Context_Item) loop
if Nkind (Context_Item) = N_With_Clause
and then not Limited_Present (Context_Item)
then
pragma Assert (Present (Library_Unit (Context_Item)));
Write_Unit_Name
(Unit_Name
(Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
if Implicit_With (Context_Item) then
Write_Str (" -- implicit");
end if;
Write_Eol;
end if;
Context_Item := Next (Context_Item);
end loop;
Outdent;
Write_Line ("end withs");
Outdent;
end if;
end;
end Write_Unit_Info;
end Lib;
gprbuild-gpl-2014-src/gnat/uintp.ads 0000644 0000767 0000145 00000060554 12323721731 016726 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- U I N T P --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2012, 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 3, 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. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- >
case R is
-- Boolean restriction case
when All_Boolean_Restrictions =>
case Typ is
when 'V' =>
ALIs.Table (Id).Restrictions.Violated (R) :=
True;
Cumulative_Restrictions.Violated (R) := True;
when 'R' =>
ALIs.Table (Id).Restrictions.Set (R) := True;
Cumulative_Restrictions.Set (R) := True;
when others =>
raise Bad_R_Line;
end case;
-- Parameter restriction case
when All_Parameter_Restrictions =>
if At_Eol or else Nextc /= '=' then
raise Bad_R_Line;
else
Skipc;
end if;
N := Natural (Get_Nat);
case Typ is
-- Restriction set
when 'R' =>
ALIs.Table (Id).Restrictions.Set (R) := True;
ALIs.Table (Id).Restrictions.Value (R) := N;
if Cumulative_Restrictions.Set (R) then
Cumulative_Restrictions.Value (R) :=
Integer'Min
(Cumulative_Restrictions.Value (R), N);
else
Cumulative_Restrictions.Set (R) := True;
Cumulative_Restrictions.Value (R) := N;
end if;
-- Restriction violated
when 'V' =>
ALIs.Table (Id).Restrictions.Violated (R) :=
True;
Cumulative_Restrictions.Violated (R) := True;
ALIs.Table (Id).Restrictions.Count (R) := N;
-- Checked Max_Parameter case
if R in Checked_Max_Parameter_Restrictions then
Cumulative_Restrictions.Count (R) :=
Integer'Max
(Cumulative_Restrictions.Count (R), N);
-- Other checked parameter cases
else
declare
pragma Unsuppress (Overflow_Check);
begin
Cumulative_Restrictions.Count (R) :=
Cumulative_Restrictions.Count (R) + N;
exception
when Constraint_Error =>
-- A constraint error comes from the
-- addition. We reset to the maximum
-- and indicate that the real value
-- is now unknown.
Cumulative_Restrictions.Value (R) :=
Integer'Last;
Cumulative_Restrictions.Unknown (R) :=
True;
end;
end if;
-- Deal with + case
if Nextc = '+' then
Skipc;
ALIs.Table (Id).Restrictions.Unknown (R) :=
True;
Cumulative_Restrictions.Unknown (R) := True;
end if;
-- Other than 'R' or 'V'
when others =>
raise Bad_R_Line;
end case;
if not At_Eol then
raise Bad_R_Line;
end if;
-- Bizarre error case NOT_A_RESTRICTION
when Not_A_Restriction_Id =>
raise Bad_R_Line;
end case;
if not At_Eol then
raise Bad_R_Line;
end if;
<>
Skip_Line;
C := Getc;
end loop;
-- Positional restriction case
else
Checkc (' ');
Skip_Space;
-- Acquire information for boolean restrictions
for R in All_Boolean_Restrictions loop
C := Getc;
case C is
when 'v' =>
ALIs.Table (Id).Restrictions.Violated (R) := True;
Cumulative_Restrictions.Violated (R) := True;
when 'r' =>
ALIs.Table (Id).Restrictions.Set (R) := True;
Cumulative_Restrictions.Set (R) := True;
when 'n' =>
null;
when others =>
raise Bad_R_Line;
end case;
end loop;
-- Acquire information for parameter restrictions
for RP in All_Parameter_Restrictions loop
case Getc is
when 'n' =>
null;
when 'r' =>
ALIs.Table (Id).Restrictions.Set (RP) := True;
declare
N : constant Integer := Integer (Get_Nat);
begin
ALIs.Table (Id).Restrictions.Value (RP) := N;
if Cumulative_Restrictions.Set (RP) then
Cumulative_Restrictions.Value (RP) :=
Integer'Min
(Cumulative_Restrictions.Value (RP), N);
else
Cumulative_Restrictions.Set (RP) := True;
Cumulative_Restrictions.Value (RP) := N;
end if;
end;
when others =>
raise Bad_R_Line;
end case;
-- Acquire restrictions violations information
case Getc is
when 'n' =>
null;
when 'v' =>
ALIs.Table (Id).Restrictions.Violated (RP) := True;
Cumulative_Restrictions.Violated (RP) := True;
declare
N : constant Integer := Integer (Get_Nat);
begin
ALIs.Table (Id).Restrictions.Count (RP) := N;
if RP in Checked_Max_Parameter_Restrictions then
Cumulative_Restrictions.Count (RP) :=
Integer'Max
(Cumulative_Restrictions.Count (RP), N);
else
declare
pragma Unsuppress (Overflow_Check);
begin
Cumulative_Restrictions.Count (RP) :=
Cumulative_Restrictions.Count (RP) + N;
exception
when Constraint_Error =>
-- A constraint error comes from the add. We
-- reset to the maximum and indicate that the
-- real value is now unknown.
Cumulative_Restrictions.Value (RP) :=
Integer'Last;
Cumulative_Restrictions.Unknown (RP) := True;
end;
end if;
if Nextc = '+' then
Skipc;
ALIs.Table (Id).Restrictions.Unknown (RP) := True;
Cumulative_Restrictions.Unknown (RP) := True;
end if;
end;
when others =>
raise Bad_R_Line;
end case;
end loop;
if not At_Eol then
raise Bad_R_Line;
else
Skip_Line;
C := Getc;
end if;
end if;
-- Here if error during scanning of restrictions line
exception
when Bad_R_Line =>
-- In Ignore_Errors mode, undo any changes to restrictions
-- from this unit, and continue on, skipping remaining R
-- lines for this unit.
if Ignore_Errors then
Cumulative_Restrictions := Save_R;
ALIs.Table (Id).Restrictions := No_Restrictions;
loop
Skip_Eol;
C := Getc;
exit when C /= 'R';
end loop;
-- In normal mode, this is a fatal error
else
Fatal_Error;
end if;
end Scan_Restrictions;
end if;
-- Acquire additional restrictions (No_Dependence) lines if present
while C = 'R' loop
if Ignore ('R') then
Skip_Line;
else
Skip_Space;
No_Deps.Append ((Id, Get_Name));
Skip_Eol;
end if;
C := Getc;
end loop;
-- Acquire 'I' lines if present
Check_Unknown_Line;
while C = 'I' loop
if Ignore ('I') then
Skip_Line;
else
declare
Int_Num : Nat;
I_State : Character;
Line_No : Nat;
begin
Int_Num := Get_Nat;
Skip_Space;
I_State := Getc;
Line_No := Get_Nat;
Interrupt_States.Append (
(Interrupt_Id => Int_Num,
Interrupt_State => I_State,
IS_Pragma_Line => Line_No));
ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
Skip_Eol;
end;
end if;
C := Getc;
end loop;
-- Acquire 'S' lines if present
Check_Unknown_Line;
while C = 'S' loop
if Ignore ('S') then
Skip_Line;
else
declare
Policy : Character;
First_Prio : Nat;
Last_Prio : Nat;
Line_No : Nat;
begin
Checkc (' ');
Skip_Space;
Policy := Getc;
Skip_Space;
First_Prio := Get_Nat;
Last_Prio := Get_Nat;
Line_No := Get_Nat;
Specific_Dispatching.Append (
(Dispatching_Policy => Policy,
First_Priority => First_Prio,
Last_Priority => Last_Prio,
PSD_Pragma_Line => Line_No));
ALIs.Table (Id).Last_Specific_Dispatching :=
Specific_Dispatching.Last;
Skip_Eol;
end;
end if;
C := Getc;
end loop;
-- Loop to acquire unit entries
U_Loop : loop
Check_Unknown_Line;
exit U_Loop when C /= 'U';
-- Note: as per spec, we never ignore U lines
Checkc (' ');
Skip_Space;
Units.Increment_Last;
if ALIs.Table (Id).First_Unit = No_Unit_Id then
ALIs.Table (Id).First_Unit := Units.Last;
end if;
declare
UL : Unit_Record renames Units.Table (Units.Last);
begin
UL.Uname := Get_Unit_Name;
UL.Predefined := Is_Predefined_Unit;
UL.Internal := Is_Internal_Unit;
UL.My_ALI := Id;
UL.Sfile := Get_File_Name (Lower => True);
UL.Pure := False;
UL.Preelab := False;
UL.No_Elab := False;
UL.Shared_Passive := False;
UL.RCI := False;
UL.Remote_Types := False;
UL.Has_RACW := False;
UL.Init_Scalars := False;
UL.Is_Generic := False;
UL.Icasing := Mixed_Case;
UL.Kcasing := All_Lower_Case;
UL.Dynamic_Elab := False;
UL.Elaborate_Body := False;
UL.Set_Elab_Entity := False;
UL.Version := "00000000";
UL.First_With := Withs.Last + 1;
UL.First_Arg := First_Arg;
UL.Elab_Position := 0;
UL.SAL_Interface := ALIs.Table (Id).SAL_Interface;
UL.Directly_Scanned := Directly_Scanned;
UL.Body_Needed_For_SAL := False;
UL.Elaborate_Body_Desirable := False;
UL.Optimize_Alignment := 'O';
UL.Has_Finalizer := False;
if Debug_Flag_U then
Write_Str (" ----> reading unit ");
Write_Int (Int (Units.Last));
Write_Str (" ");
Write_Unit_Name (UL.Uname);
Write_Str (" from file ");
Write_Name (UL.Sfile);
Write_Eol;
end if;
end;
-- Check for duplicated unit in different files
declare
Info : constant Int := Get_Name_Table_Info
(Units.Table (Units.Last).Uname);
begin
if Info /= 0
and then Units.Table (Units.Last).Sfile /=
Units.Table (Unit_Id (Info)).Sfile
then
-- If Err is set then ignore duplicate unit name. This is the
-- case of a call from gnatmake, where the situation can arise
-- from substitution of source files. In such situations, the
-- processing in gnatmake will always result in any required
-- recompilations in any case, and if we consider this to be
-- an error we get strange cases (for example when a generic
-- instantiation is replaced by a normal package) where we
-- read the old ali file, decide to recompile, and then decide
-- that the old and new ali files are incompatible.
if Err then
null;
-- If Err is not set, then this is a fatal error. This is
-- the case of being called from the binder, where we must
-- definitely diagnose this as an error.
else
Set_Standard_Error;
Write_Str ("error: duplicate unit name: ");
Write_Eol;
Write_Str ("error: unit """);
Write_Unit_Name (Units.Table (Units.Last).Uname);
Write_Str (""" found in file """);
Write_Name_Decoded (Units.Table (Units.Last).Sfile);
Write_Char ('"');
Write_Eol;
Write_Str ("error: unit """);
Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname);
Write_Str (""" found in file """);
Write_Name_Decoded (Units.Table (Unit_Id (Info)).Sfile);
Write_Char ('"');
Write_Eol;
Exit_Program (E_Fatal);
end if;
end if;
end;
Set_Name_Table_Info
(Units.Table (Units.Last).Uname, Int (Units.Last));
-- Scan out possible version and other parameters
loop
Skip_Space;
exit when At_Eol;
C := Getc;
-- Version field
if C in '0' .. '9' or else C in 'a' .. 'f' then
Units.Table (Units.Last).Version (1) := C;
for J in 2 .. 8 loop
C := Getc;
Units.Table (Units.Last).Version (J) := C;
end loop;
-- BD/BN parameters
elsif C = 'B' then
C := Getc;
if C = 'D' then
Check_At_End_Of_Field;
Units.Table (Units.Last).Elaborate_Body_Desirable := True;
elsif C = 'N' then
Check_At_End_Of_Field;
Units.Table (Units.Last).Body_Needed_For_SAL := True;
else
Fatal_Error_Ignore;
end if;
-- DE parameter (Dynamic elaboration checks)
elsif C = 'D' then
C := Getc;
if C = 'E' then
Check_At_End_Of_Field;
Units.Table (Units.Last).Dynamic_Elab := True;
Dynamic_Elaboration_Checks_Specified := True;
else
Fatal_Error_Ignore;
end if;
-- EB/EE parameters
elsif C = 'E' then
C := Getc;
if C = 'B' then
Units.Table (Units.Last).Elaborate_Body := True;
elsif C = 'E' then
Units.Table (Units.Last).Set_Elab_Entity := True;
else
Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
-- GE parameter (generic)
elsif C = 'G' then
C := Getc;
if C = 'E' then
Check_At_End_Of_Field;
Units.Table (Units.Last).Is_Generic := True;
else
Fatal_Error_Ignore;
end if;
-- IL/IS/IU parameters
elsif C = 'I' then
C := Getc;
if C = 'L' then
Units.Table (Units.Last).Icasing := All_Lower_Case;
elsif C = 'S' then
Units.Table (Units.Last).Init_Scalars := True;
Initialize_Scalars_Used := True;
elsif C = 'U' then
Units.Table (Units.Last).Icasing := All_Upper_Case;
else
Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
-- KM/KU parameters
elsif C = 'K' then
C := Getc;
if C = 'M' then
Units.Table (Units.Last).Kcasing := Mixed_Case;
elsif C = 'U' then
Units.Table (Units.Last).Kcasing := All_Upper_Case;
else
Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
-- NE parameter
elsif C = 'N' then
C := Getc;
if C = 'E' then
Units.Table (Units.Last).No_Elab := True;
Check_At_End_Of_Field;
else
Fatal_Error_Ignore;
end if;
-- PF/PR/PU/PK parameters
elsif C = 'P' then
C := Getc;
if C = 'F' then
Units.Table (Units.Last).Has_Finalizer := True;
elsif C = 'R' then
Units.Table (Units.Last).Preelab := True;
elsif C = 'U' then
Units.Table (Units.Last).Pure := True;
elsif C = 'K' then
Units.Table (Units.Last).Unit_Kind := 'p';
else
Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
-- OL/OO/OS/OT parameters
elsif C = 'O' then
C := Getc;
if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then
Units.Table (Units.Last).Optimize_Alignment := C;
else
Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
-- RC/RT parameters
elsif C = 'R' then
C := Getc;
if C = 'C' then
Units.Table (Units.Last).RCI := True;
elsif C = 'T' then
Units.Table (Units.Last).Remote_Types := True;
elsif C = 'A' then
Units.Table (Units.Last).Has_RACW := True;
else
Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
elsif C = 'S' then
C := Getc;
if C = 'P' then
Units.Table (Units.Last).Shared_Passive := True;
elsif C = 'U' then
Units.Table (Units.Last).Unit_Kind := 's';
else
Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
else
C := Getc;
Fatal_Error_Ignore;
end if;
end loop;
Skip_Eol;
-- Check if static elaboration model used
if not Units.Table (Units.Last).Dynamic_Elab
and then not Units.Table (Units.Last).Internal
then
Static_Elaboration_Model_Used := True;
end if;
C := Getc;
-- Scan out With lines for this unit
With_Loop : loop
Check_Unknown_Line;
exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z';
if Ignore ('W') then
Skip_Line;
else
Checkc (' ');
Skip_Space;
Withs.Increment_Last;
Withs.Table (Withs.Last).Uname := Get_Unit_Name;
Withs.Table (Withs.Last).Elaborate := False;
Withs.Table (Withs.Last).Elaborate_All := False;
Withs.Table (Withs.Last).Elab_Desirable := False;
Withs.Table (Withs.Last).Elab_All_Desirable := False;
Withs.Table (Withs.Last).SAL_Interface := False;
Withs.Table (Withs.Last).Limited_With := (C = 'Y');
Withs.Table (Withs.Last).Implicit_With_From_Instantiation
:= (C = 'Z');
-- Generic case with no object file available
if At_Eol then
Withs.Table (Withs.Last).Sfile := No_File;
Withs.Table (Withs.Last).Afile := No_File;
-- Normal case
else
Withs.Table (Withs.Last).Sfile := Get_File_Name
(Lower => True);
Withs.Table (Withs.Last).Afile := Get_File_Name
(Lower => True);
-- Scan out possible E, EA, ED, and AD parameters
while not At_Eol loop
Skip_Space;
if Nextc = 'A' then
P := P + 1;
Checkc ('D');
Check_At_End_Of_Field;
-- Store AD indication unless ignore required
if not Ignore_ED then
Withs.Table (Withs.Last).Elab_All_Desirable :=
True;
end if;
elsif Nextc = 'E' then
P := P + 1;
if At_End_Of_Field then
Withs.Table (Withs.Last).Elaborate := True;
elsif Nextc = 'A' then
P := P + 1;
Check_At_End_Of_Field;
Withs.Table (Withs.Last).Elaborate_All := True;
else
Checkc ('D');
Check_At_End_Of_Field;
-- Store ED indication unless ignore required
if not Ignore_ED then
Withs.Table (Withs.Last).Elab_Desirable :=
True;
end if;
end if;
else
Fatal_Error;
end if;
end loop;
end if;
Skip_Eol;
end if;
C := Getc;
end loop With_Loop;
Units.Table (Units.Last).Last_With := Withs.Last;
Units.Table (Units.Last).Last_Arg := Args.Last;
-- If there are linker options lines present, scan them
Name_Len := 0;
Linker_Options_Loop : loop
Check_Unknown_Line;
exit Linker_Options_Loop when C /= 'L';
if Ignore ('L') then
Skip_Line;
else
Checkc (' ');
Skip_Space;
Checkc ('"');
loop
C := Getc;
if C < Character'Val (16#20#)
or else C > Character'Val (16#7E#)
then
Fatal_Error_Ignore;
elsif C = '{' then
C := Character'Val (0);
declare
V : Natural;
begin
V := 0;
for J in 1 .. 2 loop
C := Getc;
if C in '0' .. '9' then
V := V * 16 +
Character'Pos (C) -
Character'Pos ('0');
elsif C in 'A' .. 'F' then
V := V * 16 +
Character'Pos (C) -
Character'Pos ('A') +
10;
else
Fatal_Error_Ignore;
end if;
end loop;
Checkc ('}');
Add_Char_To_Name_Buffer (Character'Val (V));
end;
else
if C = '"' then
exit when Nextc /= '"';
C := Getc;
end if;
Add_Char_To_Name_Buffer (C);
end if;
end loop;
Add_Char_To_Name_Buffer (NUL);
Skip_Eol;
end if;
C := Getc;
end loop Linker_Options_Loop;
-- Store the linker options entry if one was found
if Name_Len /= 0 then
Linker_Options.Increment_Last;
Linker_Options.Table (Linker_Options.Last).Name :=
Name_Enter;
Linker_Options.Table (Linker_Options.Last).Unit :=
Units.Last;
Linker_Options.Table (Linker_Options.Last).Internal_File :=
Is_Internal_File_Name (F);
Linker_Options.Table (Linker_Options.Last).Original_Pos :=
Linker_Options.Last;
end if;
-- If there are notes present, scan them
Notes_Loop : loop
Check_Unknown_Line;
exit Notes_Loop when C /= 'N';
if Ignore ('N') then
Skip_Line;
else
Checkc (' ');
Notes.Increment_Last;
Notes.Table (Notes.Last).Pragma_Type := Getc;
Notes.Table (Notes.Last).Pragma_Line := Get_Nat;
Checkc (':');
Notes.Table (Notes.Last).Pragma_Col := Get_Nat;
Notes.Table (Notes.Last).Unit := Units.Last;
if At_Eol then
Notes.Table (Notes.Last).Pragma_Args := No_Name;
else
Checkc (' ');
Name_Len := 0;
while not At_Eol loop
Add_Char_To_Name_Buffer (Getc);
end loop;
Notes.Table (Notes.Last).Pragma_Args := Name_Enter;
end if;
Skip_Eol;
end if;
C := Getc;
end loop Notes_Loop;
end loop U_Loop;
-- End loop through units for one ALI file
ALIs.Table (Id).Last_Unit := Units.Last;
ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile;
-- Set types of the units (there can be at most 2 of them)
if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then
Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body;
Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec;
else
-- Deal with body only and spec only cases, note that the reason we
-- do our own checking of the name (rather than using Is_Body_Name)
-- is that Uname drags in far too much compiler junk.
Get_Name_String (Units.Table (Units.Last).Uname);
if Name_Buffer (Name_Len) = 'b' then
Units.Table (Units.Last).Utype := Is_Body_Only;
else
Units.Table (Units.Last).Utype := Is_Spec_Only;
end if;
end if;
-- Scan out external version references and put in hash table
E_Loop : loop
Check_Unknown_Line;
exit E_Loop when C /= 'E';
if Ignore ('E') then
Skip_Line;
else
Checkc (' ');
Skip_Space;
Name_Len := 0;
Name_Len := 0;
loop
C := Getc;
if C < ' ' then
Fatal_Error;
end if;
exit when At_End_Of_Field;
Add_Char_To_Name_Buffer (C);
end loop;
Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
Skip_Eol;
end if;
C := Getc;
end loop E_Loop;
-- Scan out source dependency lines for this ALI file
ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
D_Loop : loop
Check_Unknown_Line;
exit D_Loop when C /= 'D';
if Ignore ('D') then
Skip_Line;
else
Checkc (' ');
Skip_Space;
Sdep.Increment_Last;
-- In the following call, Lower is not set to True, this is either
-- a bug, or it deserves a special comment as to why this is so???
-- The file/path name may be quoted
Sdep.Table (Sdep.Last).Sfile :=
Get_File_Name (May_Be_Quoted => True);
Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
Sdep.Table (Sdep.Last).Dummy_Entry :=
(Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
-- Acquire checksum value
Skip_Space;
declare
Ctr : Natural;
Chk : Word;
begin
Ctr := 0;
Chk := 0;
loop
exit when At_Eol or else Ctr = 8;
if Nextc in '0' .. '9' then
Chk := Chk * 16 +
Character'Pos (Nextc) - Character'Pos ('0');
elsif Nextc in 'a' .. 'f' then
Chk := Chk * 16 +
Character'Pos (Nextc) - Character'Pos ('a') + 10;
else
exit;
end if;
Ctr := Ctr + 1;
P := P + 1;
end loop;
if Ctr = 8 and then At_End_Of_Field then
Sdep.Table (Sdep.Last).Checksum := Chk;
else
Fatal_Error;
end if;
end;
-- Acquire (sub)unit and reference file name entries
Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
Sdep.Table (Sdep.Last).Unit_Name := No_Name;
Sdep.Table (Sdep.Last).Rfile :=
Sdep.Table (Sdep.Last).Sfile;
Sdep.Table (Sdep.Last).Start_Line := 1;
if not At_Eol then
Skip_Space;
-- Here for (sub)unit name
if Nextc not in '0' .. '9' then
Name_Len := 0;
while not At_End_Of_Field loop
Add_Char_To_Name_Buffer (Getc);
end loop;
-- Set the (sub)unit name. Note that we use Name_Find rather
-- than Name_Enter here as the subunit name may already
-- have been put in the name table by the Project Manager.
if Name_Len <= 2
or else Name_Buffer (Name_Len - 1) /= '%'
then
Sdep.Table (Sdep.Last).Subunit_Name := Name_Find;
else
Name_Len := Name_Len - 2;
Sdep.Table (Sdep.Last).Unit_Name := Name_Find;
end if;
Skip_Space;
end if;
-- Here for reference file name entry
if Nextc in '0' .. '9' then
Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
Checkc (':');
Name_Len := 0;
while not At_End_Of_Field loop
Add_Char_To_Name_Buffer (Getc);
end loop;
Sdep.Table (Sdep.Last).Rfile := Name_Enter;
end if;
end if;
Skip_Eol;
end if;
C := Getc;
end loop D_Loop;
ALIs.Table (Id).Last_Sdep := Sdep.Last;
-- We must at this stage be at an Xref line or the end of file
if C = EOF then
return Id;
end if;
Check_Unknown_Line;
if C /= 'X' then
Fatal_Error;
end if;
-- If we are ignoring Xref sections we are done (we ignore all
-- remaining lines since only xref related lines follow X).
if Ignore ('X') and then not Debug_Flag_X then
return Id;
end if;
-- Loop through Xref sections
X_Loop : loop
Check_Unknown_Line;
exit X_Loop when C /= 'X';
-- Make new entry in section table
Xref_Section.Increment_Last;
Read_Refs_For_One_File : declare
XS : Xref_Section_Record renames
Xref_Section.Table (Xref_Section.Last);
Current_File_Num : Sdep_Id;
-- Keeps track of the current file number (changed by nn|)
begin
XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
XS.File_Name := Get_File_Name;
XS.First_Entity := Xref_Entity.Last + 1;
Current_File_Num := XS.File_Num;
Skip_Space;
Skip_Eol;
C := Nextc;
-- Loop through Xref entities
while C /= 'X' and then C /= EOF loop
Xref_Entity.Increment_Last;
Read_Refs_For_One_Entity : declare
XE : Xref_Entity_Record renames
Xref_Entity.Table (Xref_Entity.Last);
N : Nat;
procedure Read_Instantiation_Reference;
-- Acquire instantiation reference. Caller has checked
-- that current character is '[' and on return the cursor
-- is skipped past the corresponding closing ']'.
----------------------------------
-- Read_Instantiation_Reference --
----------------------------------
procedure Read_Instantiation_Reference is
Local_File_Num : Sdep_Id := Current_File_Num;
begin
Xref.Increment_Last;
declare
XR : Xref_Record renames Xref.Table (Xref.Last);
begin
P := P + 1; -- skip [
N := Get_Nat;
if Nextc = '|' then
XR.File_Num :=
Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
Local_File_Num := XR.File_Num;
P := P + 1;
N := Get_Nat;
else
XR.File_Num := Local_File_Num;
end if;
XR.Line := N;
XR.Rtype := ' ';
XR.Col := 0;
-- Recursive call for next reference
if Nextc = '[' then
pragma Warnings (Off); -- kill recursion warning
Read_Instantiation_Reference;
pragma Warnings (On);
end if;
-- Skip closing bracket after recursive call
P := P + 1;
end;
end Read_Instantiation_Reference;
-- Start of processing for Read_Refs_For_One_Entity
begin
XE.Line := Get_Nat;
XE.Etype := Getc;
XE.Col := Get_Nat;
case Getc is
when '*' =>
XE.Visibility := Global;
when '+' =>
XE.Visibility := Static;
when others =>
XE.Visibility := Other;
end case;
XE.Entity := Get_Name;
-- Handle the information about generic instantiations
if Nextc = '[' then
Skipc; -- Opening '['
N := Get_Nat;
if Nextc /= '|' then
XE.Iref_File_Num := Current_File_Num;
XE.Iref_Line := N;
else
XE.Iref_File_Num :=
Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
Skipc;
XE.Iref_Line := Get_Nat;
end if;
if Getc /= ']' then
Fatal_Error;
end if;
else
XE.Iref_File_Num := No_Sdep_Id;
XE.Iref_Line := 0;
end if;
Current_File_Num := XS.File_Num;
-- Renaming reference is present
if Nextc = '=' then
P := P + 1;
XE.Rref_Line := Get_Nat;
if Getc /= ':' then
Fatal_Error;
end if;
XE.Rref_Col := Get_Nat;
-- No renaming reference present
else
XE.Rref_Line := 0;
XE.Rref_Col := 0;
end if;
Skip_Space;
XE.Oref_File_Num := No_Sdep_Id;
XE.Tref_File_Num := No_Sdep_Id;
XE.Tref := Tref_None;
XE.First_Xref := Xref.Last + 1;
-- Loop to check for additional info present
loop
declare
Ref : Tref_Kind;
File : Sdep_Id;
Line : Nat;
Typ : Character;
Col : Nat;
Std : Name_Id;
begin
Get_Typeref
(Current_File_Num, Ref, File, Line, Typ, Col, Std);
exit when Ref = Tref_None;
-- Do we have an overriding procedure?
if Ref = Tref_Derived and then Typ = 'p' then
XE.Oref_File_Num := File;
XE.Oref_Line := Line;
XE.Oref_Col := Col;
-- Arrays never override anything, and <> points to
-- the index types instead
elsif Ref = Tref_Derived and then XE.Etype = 'A' then
-- Index types are stored in the list of references
Xref.Increment_Last;
declare
XR : Xref_Record renames Xref.Table (Xref.Last);
begin
XR.File_Num := File;
XR.Line := Line;
XR.Rtype := Array_Index_Reference;
XR.Col := Col;
XR.Name := Std;
end;
-- Interfaces are stored in the list of references,
-- although the parent type itself is stored in XE.
-- The first interface (when there are only
-- interfaces) is stored in XE.Tref*)
elsif Ref = Tref_Derived
and then Typ = 'R'
and then XE.Tref_File_Num /= No_Sdep_Id
then
Xref.Increment_Last;
declare
XR : Xref_Record renames Xref.Table (Xref.Last);
begin
XR.File_Num := File;
XR.Line := Line;
XR.Rtype := Interface_Reference;
XR.Col := Col;
XR.Name := Std;
end;
else
XE.Tref := Ref;
XE.Tref_File_Num := File;
XE.Tref_Line := Line;
XE.Tref_Type := Typ;
XE.Tref_Col := Col;
XE.Tref_Standard_Entity := Std;
end if;
end;
end loop;
-- Loop through cross-references for this entity
loop
Skip_Space;
if At_Eol then
Skip_Eol;
exit when Nextc /= '.';
P := P + 1;
end if;
Xref.Increment_Last;
declare
XR : Xref_Record renames Xref.Table (Xref.Last);
begin
N := Get_Nat;
if Nextc = '|' then
XR.File_Num :=
Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
Current_File_Num := XR.File_Num;
P := P + 1;
N := Get_Nat;
else
XR.File_Num := Current_File_Num;
end if;
XR.Line := N;
XR.Rtype := Getc;
-- Imported entities reference as in:
-- 494b25
if Nextc = '<' then
Skipc;
XR.Imported_Lang := Get_Name;
pragma Assert (Nextc = ',');
Skipc;
XR.Imported_Name := Get_Name;
pragma Assert (Nextc = '>');
Skipc;
else
XR.Imported_Lang := No_Name;
XR.Imported_Name := No_Name;
end if;
XR.Col := Get_Nat;
if Nextc = '[' then
Read_Instantiation_Reference;
end if;
end;
end loop;
-- Record last cross-reference
XE.Last_Xref := Xref.Last;
C := Nextc;
exception
when Bad_ALI_Format =>
-- If ignoring errors, then we skip a line with an
-- unexpected error, and try to continue subsequent
-- xref lines.
if Ignore_Errors then
Xref_Entity.Decrement_Last;
Skip_Line;
C := Nextc;
-- Otherwise, we reraise the fatal exception
else
raise;
end if;
end Read_Refs_For_One_Entity;
end loop;
-- Record last entity
XS.Last_Entity := Xref_Entity.Last;
end Read_Refs_For_One_File;
C := Getc;
end loop X_Loop;
-- Here after dealing with xref sections
-- Ignore remaining lines, which belong to an additional section of the
-- ALI file not considered here (like SCO or SPARK information).
Check_Unknown_Line;
return Id;
exception
when Bad_ALI_Format =>
return No_ALI_Id;
end Scan_ALI;
---------
-- SEq --
---------
function SEq (F1, F2 : String_Ptr) return Boolean is
begin
return F1.all = F2.all;
end SEq;
-----------
-- SHash --
-----------
function SHash (S : String_Ptr) return Vindex is
H : Word;
begin
H := 0;
for J in S.all'Range loop
H := H * 2 + Character'Pos (S (J));
end loop;
return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length));
end SHash;
end ALI;
gprbuild-gpl-2014-src/gnat/sinput-c.ads 0000644 0000767 0000145 00000004301 12323721731 017315 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S I N P U T . C --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2007, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This child package contains a procedure to load files
-- It is used by Sinput.P to load project files, and by GPrep to load
-- preprocessor definition files and input files.
package Sinput.C is
function Load_File (Path : String) return Source_File_Index;
-- Load a file into memory and Initialize the Scans state
end Sinput.C;
gprbuild-gpl-2014-src/gnat/prj-dect.adb 0000644 0000767 0000145 00000177152 12323721731 017261 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . D E C T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2014, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Err_Vars; use Err_Vars;
with Opt; use Opt;
with Prj.Attr; use Prj.Attr;
with Prj.Attr.PM; use Prj.Attr.PM;
with Prj.Err; use Prj.Err;
with Prj.Strt; use Prj.Strt;
with Prj.Tree; use Prj.Tree;
with Snames;
with Uintp; use Uintp;
with GNAT; use GNAT;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
with GNAT.Strings;
package body Prj.Dect is
type Zone is (In_Project, In_Package, In_Case_Construction);
-- Used to indicate if we are parsing a package (In_Package), a case
-- construction (In_Case_Construction) or none of those two (In_Project).
procedure Rename_Obsolescent_Attributes
(In_Tree : Project_Node_Tree_Ref;
Attribute : Project_Node_Id;
Current_Package : Project_Node_Id);
-- Rename obsolescent attributes in the tree. When the attribute has been
-- renamed since its initial introduction in the design of projects, we
-- replace the old name in the tree with the new name, so that the code
-- does not have to check both names forever.
procedure Check_Attribute_Allowed
(In_Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id;
Attribute : Project_Node_Id;
Flags : Processing_Flags);
-- Check whether the attribute is valid in this project. In particular,
-- depending on the type of project (qualifier), some attributes might
-- be disabled.
procedure Check_Package_Allowed
(In_Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Flags : Processing_Flags);
-- Check whether the package is valid in this project
procedure Parse_Attribute_Declaration
(In_Tree : Project_Node_Tree_Ref;
Attribute : out Project_Node_Id;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Packages_To_Check : String_List_Access;
Flags : Processing_Flags);
-- Parse an attribute declaration
procedure Parse_Case_Construction
(In_Tree : Project_Node_Tree_Ref;
Case_Construction : out Project_Node_Id;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean;
Flags : Processing_Flags);
-- Parse a case construction
procedure Parse_Declarative_Items
(In_Tree : Project_Node_Tree_Ref;
Declarations : out Project_Node_Id;
In_Zone : Zone;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean;
Flags : Processing_Flags);
-- Parse declarative items. Depending on In_Zone, some declarative items
-- may be forbidden. Is_Config_File should be set to True if the project
-- represents a config file (.cgpr) since some specific checks apply.
procedure Parse_Package_Declaration
(In_Tree : Project_Node_Tree_Ref;
Package_Declaration : out Project_Node_Id;
Current_Project : Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean;
Flags : Processing_Flags);
-- Parse a package declaration.
-- Is_Config_File should be set to True if the project represents a config
-- file (.cgpr) since some specific checks apply.
procedure Parse_String_Type_Declaration
(In_Tree : Project_Node_Tree_Ref;
String_Type : out Project_Node_Id;
Current_Project : Project_Node_Id;
Flags : Processing_Flags);
-- type is ( { , } ) ;
procedure Parse_Variable_Declaration
(In_Tree : Project_Node_Tree_Ref;
Variable : out Project_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Flags : Processing_Flags);
-- Parse a variable assignment
-- := ; OR
-- : := ;
-----------
-- Parse --
-----------
procedure Parse
(In_Tree : Project_Node_Tree_Ref;
Declarations : out Project_Node_Id;
Current_Project : Project_Node_Id;
Extends : Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean;
Flags : Processing_Flags)
is
First_Declarative_Item : Project_Node_Id := Empty_Node;
begin
Declarations :=
Default_Project_Node
(Of_Kind => N_Project_Declaration, In_Tree => In_Tree);
Set_Location_Of (Declarations, In_Tree, To => Token_Ptr);
Set_Extended_Project_Of (Declarations, In_Tree, To => Extends);
Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations);
Parse_Declarative_Items
(Declarations => First_Declarative_Item,
In_Tree => In_Tree,
In_Zone => In_Project,
First_Attribute => Prj.Attr.Attribute_First,
Current_Project => Current_Project,
Current_Package => Empty_Node,
Packages_To_Check => Packages_To_Check,
Is_Config_File => Is_Config_File,
Flags => Flags);
Set_First_Declarative_Item_Of
(Declarations, In_Tree, To => First_Declarative_Item);
end Parse;
-----------------------------------
-- Rename_Obsolescent_Attributes --
-----------------------------------
procedure Rename_Obsolescent_Attributes
(In_Tree : Project_Node_Tree_Ref;
Attribute : Project_Node_Id;
Current_Package : Project_Node_Id)
is
begin
if Present (Current_Package)
and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
then
case Name_Of (Attribute, In_Tree) is
when Snames.Name_Specification =>
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
when Snames.Name_Specification_Suffix =>
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
when Snames.Name_Implementation =>
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
when Snames.Name_Implementation_Suffix =>
Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
when others =>
null;
end case;
end if;
end Rename_Obsolescent_Attributes;
---------------------------
-- Check_Package_Allowed --
---------------------------
procedure Check_Package_Allowed
(In_Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Flags : Processing_Flags)
is
Qualif : constant Project_Qualifier :=
Project_Qualifier_Of (Project, In_Tree);
Name : constant Name_Id := Name_Of (Current_Package, In_Tree);
begin
if (Qualif = Aggregate and then Name /= Snames.Name_Builder)
or else (Qualif = Aggregate_Library
and then Name /= Snames.Name_Builder
and then Name /= Snames.Name_Install)
then
Error_Msg_Name_1 := Name;
Error_Msg
(Flags,
"package %% is forbidden in aggregate projects",
Location_Of (Current_Package, In_Tree));
end if;
end Check_Package_Allowed;
-----------------------------
-- Check_Attribute_Allowed --
-----------------------------
procedure Check_Attribute_Allowed
(In_Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id;
Attribute : Project_Node_Id;
Flags : Processing_Flags)
is
Qualif : constant Project_Qualifier :=
Project_Qualifier_Of (Project, In_Tree);
Name : constant Name_Id := Name_Of (Attribute, In_Tree);
begin
case Qualif is
when Aggregate | Aggregate_Library =>
if Name = Snames.Name_Languages
or else Name = Snames.Name_Source_Files
or else Name = Snames.Name_Source_List_File
or else Name = Snames.Name_Locally_Removed_Files
or else Name = Snames.Name_Excluded_Source_Files
or else Name = Snames.Name_Excluded_Source_List_File
or else Name = Snames.Name_Interfaces
or else Name = Snames.Name_Object_Dir
or else Name = Snames.Name_Exec_Dir
or else Name = Snames.Name_Source_Dirs
or else Name = Snames.Name_Inherit_Source_Path
or else
(Qualif = Aggregate and then Name = Snames.Name_Library_Dir)
or else
(Qualif = Aggregate and then Name = Snames.Name_Library_Name)
or else Name = Snames.Name_Main
or else Name = Snames.Name_Roots
or else Name = Snames.Name_Externally_Built
or else Name = Snames.Name_Executable
or else Name = Snames.Name_Executable_Suffix
or else Name = Snames.Name_Default_Switches
then
Error_Msg_Name_1 := Name;
Error_Msg
(Flags,
"%% is not valid in aggregate projects",
Location_Of (Attribute, In_Tree));
end if;
when others =>
if Name = Snames.Name_Project_Files
or else Name = Snames.Name_Project_Path
or else Name = Snames.Name_External
then
Error_Msg_Name_1 := Name;
Error_Msg
(Flags,
"%% is only valid in aggregate projects",
Location_Of (Attribute, In_Tree));
end if;
end case;
end Check_Attribute_Allowed;
---------------------------------
-- Parse_Attribute_Declaration --
---------------------------------
procedure Parse_Attribute_Declaration
(In_Tree : Project_Node_Tree_Ref;
Attribute : out Project_Node_Id;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Packages_To_Check : String_List_Access;
Flags : Processing_Flags)
is
Current_Attribute : Attribute_Node_Id := First_Attribute;
Full_Associative_Array : Boolean := False;
Attribute_Name : Name_Id := No_Name;
Optional_Index : Boolean := False;
Pkg_Id : Package_Node_Id := Empty_Package;
procedure Process_Attribute_Name;
-- Read the name of the attribute, and check its type
procedure Process_Associative_Array_Index;
-- Read the index of the associative array and check its validity
----------------------------
-- Process_Attribute_Name --
----------------------------
procedure Process_Attribute_Name is
Ignore : Boolean;
begin
Attribute_Name := Token_Name;
Set_Name_Of (Attribute, In_Tree, To => Attribute_Name);
Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
-- Find the attribute
Current_Attribute :=
Attribute_Node_Id_Of (Attribute_Name, First_Attribute);
-- If the attribute cannot be found, create the attribute if inside
-- an unknown package.
if Current_Attribute = Empty_Attribute then
if Present (Current_Package)
and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored
then
Pkg_Id := Package_Id_Of (Current_Package, In_Tree);
Add_Attribute (Pkg_Id, Token_Name, Current_Attribute);
else
-- If not a valid attribute name, issue an error if inside
-- a package that need to be checked.
Ignore := Present (Current_Package) and then
Packages_To_Check /= All_Packages;
if Ignore then
-- Check that we are not in a package to check
Get_Name_String (Name_Of (Current_Package, In_Tree));
for Index in Packages_To_Check'Range loop
if Name_Buffer (1 .. Name_Len) =
Packages_To_Check (Index).all
then
Ignore := False;
exit;
end if;
end loop;
end if;
if not Ignore then
Error_Msg_Name_1 := Token_Name;
Error_Msg (Flags, "undefined attribute %%", Token_Ptr);
end if;
end if;
-- Set, if appropriate the index case insensitivity flag
else
if Is_Read_Only (Current_Attribute) then
Error_Msg_Name_1 := Token_Name;
Error_Msg
(Flags, "read-only attribute %% cannot be given a value",
Token_Ptr);
end if;
if Attribute_Kind_Of (Current_Attribute) in
All_Case_Insensitive_Associative_Array
then
Set_Case_Insensitive (Attribute, In_Tree, To => True);
end if;
end if;
Scan (In_Tree); -- past the attribute name
-- Set the expression kind of the attribute
if Current_Attribute /= Empty_Attribute then
Set_Expression_Kind_Of
(Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
Optional_Index := Optional_Index_Of (Current_Attribute);
end if;
end Process_Attribute_Name;
-------------------------------------
-- Process_Associative_Array_Index --
-------------------------------------
procedure Process_Associative_Array_Index is
begin
-- If the attribute is not an associative array attribute, report
-- an error. If this information is still unknown, set the kind
-- to Associative_Array.
if Current_Attribute /= Empty_Attribute
and then Attribute_Kind_Of (Current_Attribute) = Single
then
Error_Msg (Flags,
"the attribute """ &
Get_Name_String (Attribute_Name_Of (Current_Attribute))
& """ cannot be an associative array",
Location_Of (Attribute, In_Tree));
elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array);
end if;
Scan (In_Tree); -- past the left parenthesis
if Others_Allowed_For (Current_Attribute)
and then Token = Tok_Others
then
Set_Associative_Array_Index_Of
(Attribute, In_Tree, All_Other_Names);
Scan (In_Tree); -- past others
else
if Others_Allowed_For (Current_Attribute) then
Expect (Tok_String_Literal, "literal string or others");
else
Expect (Tok_String_Literal, "literal string");
end if;
if Token = Tok_String_Literal then
Get_Name_String (Token_Name);
if Case_Insensitive (Attribute, In_Tree) then
To_Lower (Name_Buffer (1 .. Name_Len));
end if;
Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find);
Scan (In_Tree); -- past the literal string index
if Token = Tok_At then
case Attribute_Kind_Of (Current_Attribute) is
when Optional_Index_Associative_Array |
Optional_Index_Case_Insensitive_Associative_Array =>
Scan (In_Tree);
Expect (Tok_Integer_Literal, "integer literal");
if Token = Tok_Integer_Literal then
-- Set the source index value from given literal
declare
Index : constant Int :=
UI_To_Int (Int_Literal_Value);
begin
if Index = 0 then
Error_Msg
(Flags, "index cannot be zero", Token_Ptr);
else
Set_Source_Index_Of
(Attribute, In_Tree, To => Index);
end if;
end;
Scan (In_Tree);
end if;
when others =>
Error_Msg (Flags, "index not allowed here", Token_Ptr);
Scan (In_Tree);
if Token = Tok_Integer_Literal then
Scan (In_Tree);
end if;
end case;
end if;
end if;
end if;
Expect (Tok_Right_Paren, "`)`");
if Token = Tok_Right_Paren then
Scan (In_Tree); -- past the right parenthesis
end if;
end Process_Associative_Array_Index;
begin
Attribute :=
Default_Project_Node
(Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
Set_Previous_Line_Node (Attribute);
-- Scan past "for"
Scan (In_Tree);
-- Body or External may be an attribute name
if Token = Tok_Body then
Token := Tok_Identifier;
Token_Name := Snames.Name_Body;
end if;
if Token = Tok_External then
Token := Tok_Identifier;
Token_Name := Snames.Name_External;
end if;
Expect (Tok_Identifier, "identifier");
Process_Attribute_Name;
Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package);
Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags);
-- Associative array attributes
if Token = Tok_Left_Paren then
Process_Associative_Array_Index;
else
-- If it is an associative array attribute and there are no left
-- parenthesis, then this is a full associative array declaration.
-- Flag it as such for later processing of its value.
if Current_Attribute /= Empty_Attribute
and then
Attribute_Kind_Of (Current_Attribute) /= Single
then
if Attribute_Kind_Of (Current_Attribute) = Unknown then
Set_Attribute_Kind_Of (Current_Attribute, To => Single);
else
Full_Associative_Array := True;
end if;
end if;
end if;
Expect (Tok_Use, "USE");
if Token = Tok_Use then
Scan (In_Tree);
if Full_Associative_Array then
-- Expect ', or
-- .'
declare
The_Project : Project_Node_Id := Empty_Node;
-- The node of the project where the associative array is
-- declared.
The_Package : Project_Node_Id := Empty_Node;
-- The node of the package where the associative array is
-- declared, if any.
Project_Name : Name_Id := No_Name;
-- The name of the project where the associative array is
-- declared.
Location : Source_Ptr := No_Location;
-- The location of the project name
begin
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
Location := Token_Ptr;
-- Find the project node in the imported project or
-- in the project being extended.
The_Project := Imported_Or_Extended_Project_Of
(Current_Project, In_Tree, Token_Name);
if No (The_Project) then
Error_Msg (Flags, "unknown project", Location);
Scan (In_Tree); -- past the project name
else
Project_Name := Token_Name;
Scan (In_Tree); -- past the project name
-- If this is inside a package, a dot followed by the
-- name of the package must followed the project name.
if Present (Current_Package) then
Expect (Tok_Dot, "`.`");
if Token /= Tok_Dot then
The_Project := Empty_Node;
else
Scan (In_Tree); -- past the dot
Expect (Tok_Identifier, "identifier");
if Token /= Tok_Identifier then
The_Project := Empty_Node;
-- If it is not the same package name, issue error
elsif
Token_Name /= Name_Of (Current_Package, In_Tree)
then
The_Project := Empty_Node;
Error_Msg
(Flags, "not the same package as " &
Get_Name_String
(Name_Of (Current_Package, In_Tree)),
Token_Ptr);
else
The_Package :=
First_Package_Of (The_Project, In_Tree);
-- Look for the package node
while Present (The_Package)
and then
Name_Of (The_Package, In_Tree) /= Token_Name
loop
The_Package :=
Next_Package_In_Project
(The_Package, In_Tree);
end loop;
-- If the package cannot be found in the
-- project, issue an error.
if No (The_Package) then
The_Project := Empty_Node;
Error_Msg_Name_2 := Project_Name;
Error_Msg_Name_1 := Token_Name;
Error_Msg
(Flags,
"package % not declared in project %",
Token_Ptr);
end if;
Scan (In_Tree); -- past the package name
end if;
end if;
end if;
end if;
end if;
if Present (The_Project) then
-- Looking for '
Expect (Tok_Apostrophe, "`''`");
if Token /= Tok_Apostrophe then
The_Project := Empty_Node;
else
Scan (In_Tree); -- past the apostrophe
Expect (Tok_Identifier, "identifier");
if Token /= Tok_Identifier then
The_Project := Empty_Node;
else
-- If it is not the same attribute name, issue error
if Token_Name /= Attribute_Name then
The_Project := Empty_Node;
Error_Msg_Name_1 := Attribute_Name;
Error_Msg
(Flags, "invalid name, should be %", Token_Ptr);
end if;
Scan (In_Tree); -- past the attribute name
end if;
end if;
end if;
if No (The_Project) then
-- If there were any problem, set the attribute id to null,
-- so that the node will not be recorded.
Current_Attribute := Empty_Attribute;
else
-- Set the appropriate field in the node.
-- Note that the index and the expression are nil. This
-- characterizes full associative array attribute
-- declarations.
Set_Associative_Project_Of (Attribute, In_Tree, The_Project);
Set_Associative_Package_Of (Attribute, In_Tree, The_Package);
end if;
end;
-- Other attribute declarations (not full associative array)
else
declare
Expression_Location : constant Source_Ptr := Token_Ptr;
-- The location of the first token of the expression
Expression : Project_Node_Id := Empty_Node;
-- The expression, value for the attribute declaration
begin
-- Get the expression value and set it in the attribute node
Parse_Expression
(In_Tree => In_Tree,
Expression => Expression,
Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package,
Optional_Index => Optional_Index);
Set_Expression_Of (Attribute, In_Tree, To => Expression);
-- If the expression is legal, but not of the right kind
-- for the attribute, issue an error.
if Current_Attribute /= Empty_Attribute
and then Present (Expression)
and then Variable_Kind_Of (Current_Attribute) /=
Expression_Kind_Of (Expression, In_Tree)
then
if Variable_Kind_Of (Current_Attribute) = Undefined then
Set_Variable_Kind_Of
(Current_Attribute,
To => Expression_Kind_Of (Expression, In_Tree));
else
Error_Msg
(Flags, "wrong expression kind for attribute """ &
Get_Name_String
(Attribute_Name_Of (Current_Attribute)) &
"""",
Expression_Location);
end if;
end if;
end;
end if;
end if;
-- If the attribute was not recognized, return an empty node.
-- It may be that it is not in a package to check, and the node will
-- not be added to the tree.
if Current_Attribute = Empty_Attribute then
Attribute := Empty_Node;
end if;
Set_End_Of_Line (Attribute);
Set_Previous_Line_Node (Attribute);
end Parse_Attribute_Declaration;
-----------------------------
-- Parse_Case_Construction --
-----------------------------
procedure Parse_Case_Construction
(In_Tree : Project_Node_Tree_Ref;
Case_Construction : out Project_Node_Id;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean;
Flags : Processing_Flags)
is
Current_Item : Project_Node_Id := Empty_Node;
Next_Item : Project_Node_Id := Empty_Node;
First_Case_Item : Boolean := True;
Variable_Location : Source_Ptr := No_Location;
String_Type : Project_Node_Id := Empty_Node;
Case_Variable : Project_Node_Id := Empty_Node;
First_Declarative_Item : Project_Node_Id := Empty_Node;
First_Choice : Project_Node_Id := Empty_Node;
When_Others : Boolean := False;
-- Set to True when there is a "when others =>" clause
begin
Case_Construction :=
Default_Project_Node
(Of_Kind => N_Case_Construction, In_Tree => In_Tree);
Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr);
-- Scan past "case"
Scan (In_Tree);
-- Get the switch variable
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
Variable_Location := Token_Ptr;
Parse_Variable_Reference
(In_Tree => In_Tree,
Variable => Case_Variable,
Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package);
Set_Case_Variable_Reference_Of
(Case_Construction, In_Tree, To => Case_Variable);
else
if Token /= Tok_Is then
Scan (In_Tree);
end if;
end if;
if Present (Case_Variable) then
String_Type := String_Type_Of (Case_Variable, In_Tree);
if No (String_Type) then
Error_Msg (Flags,
"variable """ &
Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
""" is not typed",
Variable_Location);
end if;
end if;
Expect (Tok_Is, "IS");
if Token = Tok_Is then
Set_End_Of_Line (Case_Construction);
Set_Previous_Line_Node (Case_Construction);
Set_Next_End_Node (Case_Construction);
-- Scan past "is"
Scan (In_Tree);
end if;
Start_New_Case_Construction (In_Tree, String_Type);
When_Loop :
while Token = Tok_When loop
if First_Case_Item then
Current_Item :=
Default_Project_Node
(Of_Kind => N_Case_Item, In_Tree => In_Tree);
Set_First_Case_Item_Of
(Case_Construction, In_Tree, To => Current_Item);
First_Case_Item := False;
else
Next_Item :=
Default_Project_Node
(Of_Kind => N_Case_Item, In_Tree => In_Tree);
Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item);
Current_Item := Next_Item;
end if;
Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr);
-- Scan past "when"
Scan (In_Tree);
if Token = Tok_Others then
When_Others := True;
-- Scan past "others"
Scan (In_Tree);
Expect (Tok_Arrow, "`=>`");
Set_End_Of_Line (Current_Item);
Set_Previous_Line_Node (Current_Item);
-- Empty_Node in Field1 of a Case_Item indicates
-- the "when others =>" branch.
Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node);
Parse_Declarative_Items
(In_Tree => In_Tree,
Declarations => First_Declarative_Item,
In_Zone => In_Case_Construction,
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Current_Package,
Packages_To_Check => Packages_To_Check,
Is_Config_File => Is_Config_File,
Flags => Flags);
-- "when others =>" must be the last branch, so save the
-- Case_Item and exit
Set_First_Declarative_Item_Of
(Current_Item, In_Tree, To => First_Declarative_Item);
exit When_Loop;
else
Parse_Choice_List
(In_Tree => In_Tree,
First_Choice => First_Choice,
Flags => Flags);
Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
Expect (Tok_Arrow, "`=>`");
Set_End_Of_Line (Current_Item);
Set_Previous_Line_Node (Current_Item);
Parse_Declarative_Items
(In_Tree => In_Tree,
Declarations => First_Declarative_Item,
In_Zone => In_Case_Construction,
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Current_Package,
Packages_To_Check => Packages_To_Check,
Is_Config_File => Is_Config_File,
Flags => Flags);
Set_First_Declarative_Item_Of
(Current_Item, In_Tree, To => First_Declarative_Item);
end if;
end loop When_Loop;
End_Case_Construction
(Check_All_Labels => not When_Others and not Quiet_Output,
Case_Location => Location_Of (Case_Construction, In_Tree),
Flags => Flags);
Expect (Tok_End, "`END CASE`");
Remove_Next_End_Node;
if Token = Tok_End then
-- Scan past "end"
Scan (In_Tree);
Expect (Tok_Case, "CASE");
end if;
-- Scan past "case"
Scan (In_Tree);
Expect (Tok_Semicolon, "`;`");
Set_Previous_End_Node (Case_Construction);
end Parse_Case_Construction;
-----------------------------
-- Parse_Declarative_Items --
-----------------------------
procedure Parse_Declarative_Items
(In_Tree : Project_Node_Tree_Ref;
Declarations : out Project_Node_Id;
In_Zone : Zone;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean;
Flags : Processing_Flags)
is
Current_Declarative_Item : Project_Node_Id := Empty_Node;
Next_Declarative_Item : Project_Node_Id := Empty_Node;
Current_Declaration : Project_Node_Id := Empty_Node;
Item_Location : Source_Ptr := No_Location;
begin
Declarations := Empty_Node;
loop
-- We are always positioned at the token that precedes the first
-- token of the declarative element. Scan past it.
Scan (In_Tree);
Item_Location := Token_Ptr;
case Token is
when Tok_Identifier =>
if In_Zone = In_Case_Construction then
-- Check if the variable has already been declared
declare
The_Variable : Project_Node_Id := Empty_Node;
begin
if Present (Current_Package) then
The_Variable :=
First_Variable_Of (Current_Package, In_Tree);
elsif Present (Current_Project) then
The_Variable :=
First_Variable_Of (Current_Project, In_Tree);
end if;
while Present (The_Variable)
and then Name_Of (The_Variable, In_Tree) /=
Token_Name
loop
The_Variable := Next_Variable (The_Variable, In_Tree);
end loop;
-- It is an error to declare a variable in a case
-- construction for the first time.
if No (The_Variable) then
Error_Msg
(Flags,
"a variable cannot be declared " &
"for the first time here",
Token_Ptr);
end if;
end;
end if;
Parse_Variable_Declaration
(In_Tree,
Current_Declaration,
Current_Project => Current_Project,
Current_Package => Current_Package,
Flags => Flags);
Set_End_Of_Line (Current_Declaration);
Set_Previous_Line_Node (Current_Declaration);
when Tok_For =>
Parse_Attribute_Declaration
(In_Tree => In_Tree,
Attribute => Current_Declaration,
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Current_Package,
Packages_To_Check => Packages_To_Check,
Flags => Flags);
Set_End_Of_Line (Current_Declaration);
Set_Previous_Line_Node (Current_Declaration);
when Tok_Null =>
Scan (In_Tree); -- past "null"
when Tok_Package =>
-- Package declaration
if In_Zone /= In_Project then
Error_Msg
(Flags, "a package cannot be declared here", Token_Ptr);
end if;
Parse_Package_Declaration
(In_Tree => In_Tree,
Package_Declaration => Current_Declaration,
Current_Project => Current_Project,
Packages_To_Check => Packages_To_Check,
Is_Config_File => Is_Config_File,
Flags => Flags);
Set_Previous_End_Node (Current_Declaration);
when Tok_Type =>
-- Type String Declaration
if In_Zone /= In_Project then
Error_Msg (Flags,
"a string type cannot be declared here",
Token_Ptr);
end if;
Parse_String_Type_Declaration
(In_Tree => In_Tree,
String_Type => Current_Declaration,
Current_Project => Current_Project,
Flags => Flags);
Set_End_Of_Line (Current_Declaration);
Set_Previous_Line_Node (Current_Declaration);
when Tok_Case =>
-- Case construction
Parse_Case_Construction
(In_Tree => In_Tree,
Case_Construction => Current_Declaration,
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Current_Package,
Packages_To_Check => Packages_To_Check,
Is_Config_File => Is_Config_File,
Flags => Flags);
Set_Previous_End_Node (Current_Declaration);
when others =>
exit;
-- We are leaving Parse_Declarative_Items positioned
-- at the first token after the list of declarative items.
-- It could be "end" (for a project, a package declaration or
-- a case construction) or "when" (for a case construction)
end case;
Expect (Tok_Semicolon, "`;` after declarative items");
-- Insert an N_Declarative_Item in the tree, but only if
-- Current_Declaration is not an empty node.
if Present (Current_Declaration) then
if No (Current_Declarative_Item) then
Current_Declarative_Item :=
Default_Project_Node
(Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
Declarations := Current_Declarative_Item;
else
Next_Declarative_Item :=
Default_Project_Node
(Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
Set_Next_Declarative_Item
(Current_Declarative_Item, In_Tree,
To => Next_Declarative_Item);
Current_Declarative_Item := Next_Declarative_Item;
end if;
Set_Current_Item_Node
(Current_Declarative_Item, In_Tree,
To => Current_Declaration);
Set_Location_Of
(Current_Declarative_Item, In_Tree, To => Item_Location);
end if;
end loop;
end Parse_Declarative_Items;
-------------------------------
-- Parse_Package_Declaration --
-------------------------------
procedure Parse_Package_Declaration
(In_Tree : Project_Node_Tree_Ref;
Package_Declaration : out Project_Node_Id;
Current_Project : Project_Node_Id;
Packages_To_Check : String_List_Access;
Is_Config_File : Boolean;
Flags : Processing_Flags)
is
First_Attribute : Attribute_Node_Id := Empty_Attribute;
Current_Package : Package_Node_Id := Empty_Package;
First_Declarative_Item : Project_Node_Id := Empty_Node;
Package_Location : constant Source_Ptr := Token_Ptr;
Renaming : Boolean := False;
Extending : Boolean := False;
begin
Package_Declaration :=
Default_Project_Node
(Of_Kind => N_Package_Declaration, In_Tree => In_Tree);
Set_Location_Of (Package_Declaration, In_Tree, To => Package_Location);
-- Scan past "package"
Scan (In_Tree);
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name);
Current_Package := Package_Node_Id_Of (Token_Name);
if Current_Package = Empty_Package then
if not Quiet_Output then
declare
List : constant Strings.String_List := Package_Name_List;
Index : Natural;
Name : constant String := Get_Name_String (Token_Name);
begin
-- Check for possible misspelling of a known package name
Index := 0;
loop
if Index >= List'Last then
Index := 0;
exit;
end if;
Index := Index + 1;
exit when
GNAT.Spelling_Checker.Is_Bad_Spelling_Of
(Name, List (Index).all);
end loop;
-- Issue warning(s) in verbose mode or when a possible
-- misspelling has been found.
if Verbose_Mode or else Index /= 0 then
Error_Msg (Flags,
"?""" &
Get_Name_String
(Name_Of (Package_Declaration, In_Tree)) &
""" is not a known package name",
Token_Ptr);
end if;
if Index /= 0 then
Error_Msg -- CODEFIX
(Flags,
"\?possible misspelling of """ &
List (Index).all & """", Token_Ptr);
end if;
end;
end if;
-- Set the package declaration to "ignored" so that it is not
-- processed by Prj.Proc.Process.
Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
-- Add the unknown package in the list of packages
Add_Unknown_Package (Token_Name, Current_Package);
elsif Current_Package = Unknown_Package then
-- Set the package declaration to "ignored" so that it is not
-- processed by Prj.Proc.Process.
Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
else
First_Attribute := First_Attribute_Of (Current_Package);
end if;
Set_Package_Id_Of
(Package_Declaration, In_Tree, To => Current_Package);
declare
Current : Project_Node_Id :=
First_Package_Of (Current_Project, In_Tree);
begin
while Present (Current)
and then Name_Of (Current, In_Tree) /= Token_Name
loop
Current := Next_Package_In_Project (Current, In_Tree);
end loop;
if Present (Current) then
Error_Msg
(Flags,
"package """ &
Get_Name_String (Name_Of (Package_Declaration, In_Tree)) &
""" is declared twice in the same project",
Token_Ptr);
else
-- Add the package to the project list
Set_Next_Package_In_Project
(Package_Declaration, In_Tree,
To => First_Package_Of (Current_Project, In_Tree));
Set_First_Package_Of
(Current_Project, In_Tree, To => Package_Declaration);
end if;
end;
-- Scan past the package name
Scan (In_Tree);
end if;
Check_Package_Allowed
(In_Tree, Current_Project, Package_Declaration, Flags);
if Token = Tok_Renames then
Renaming := True;
elsif Token = Tok_Extends then
Extending := True;
end if;
if Renaming or else Extending then
if Is_Config_File then
Error_Msg
(Flags,
"no package rename or extension in configuration projects",
Token_Ptr);
end if;
-- Scan past "renames" or "extends"
Scan (In_Tree);
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
declare
Project_Name : constant Name_Id := Token_Name;
Clause : Project_Node_Id :=
First_With_Clause_Of (Current_Project, In_Tree);
The_Project : Project_Node_Id := Empty_Node;
Extended : constant Project_Node_Id :=
Extended_Project_Of
(Project_Declaration_Of
(Current_Project, In_Tree),
In_Tree);
begin
while Present (Clause) loop
-- Only non limited imported projects may be used in a
-- renames declaration.
The_Project :=
Non_Limited_Project_Node_Of (Clause, In_Tree);
exit when Present (The_Project)
and then Name_Of (The_Project, In_Tree) = Project_Name;
Clause := Next_With_Clause_Of (Clause, In_Tree);
end loop;
if No (Clause) then
-- As we have not found the project in the imports, we check
-- if it's the name of an eventual extended project.
if Present (Extended)
and then Name_Of (Extended, In_Tree) = Project_Name
then
Set_Project_Of_Renamed_Package_Of
(Package_Declaration, In_Tree, To => Extended);
else
Error_Msg_Name_1 := Project_Name;
Error_Msg
(Flags,
"% is not an imported or extended project", Token_Ptr);
end if;
else
Set_Project_Of_Renamed_Package_Of
(Package_Declaration, In_Tree, To => The_Project);
end if;
end;
Scan (In_Tree);
Expect (Tok_Dot, "`.`");
if Token = Tok_Dot then
Scan (In_Tree);
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
Error_Msg (Flags, "not the same package name", Token_Ptr);
elsif
Present (Project_Of_Renamed_Package_Of
(Package_Declaration, In_Tree))
then
declare
Current : Project_Node_Id :=
First_Package_Of
(Project_Of_Renamed_Package_Of
(Package_Declaration, In_Tree),
In_Tree);
begin
while Present (Current)
and then Name_Of (Current, In_Tree) /= Token_Name
loop
Current :=
Next_Package_In_Project (Current, In_Tree);
end loop;
if No (Current) then
Error_Msg
(Flags, """" &
Get_Name_String (Token_Name) &
""" is not a package declared by the project",
Token_Ptr);
end if;
end;
end if;
Scan (In_Tree);
end if;
end if;
end if;
end if;
if Renaming then
Expect (Tok_Semicolon, "`;`");
Set_End_Of_Line (Package_Declaration);
Set_Previous_Line_Node (Package_Declaration);
elsif Token = Tok_Is then
Set_End_Of_Line (Package_Declaration);
Set_Previous_Line_Node (Package_Declaration);
Set_Next_End_Node (Package_Declaration);
Parse_Declarative_Items
(In_Tree => In_Tree,
Declarations => First_Declarative_Item,
In_Zone => In_Package,
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Package_Declaration,
Packages_To_Check => Packages_To_Check,
Is_Config_File => Is_Config_File,
Flags => Flags);
Set_First_Declarative_Item_Of
(Package_Declaration, In_Tree, To => First_Declarative_Item);
Expect (Tok_End, "END");
if Token = Tok_End then
-- Scan past "end"
Scan (In_Tree);
end if;
-- We should have the name of the package after "end"
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier
and then Name_Of (Package_Declaration, In_Tree) /= No_Name
and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
then
Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
Error_Msg (Flags, "expected %%", Token_Ptr);
end if;
if Token /= Tok_Semicolon then
-- Scan past the package name
Scan (In_Tree);
end if;
Expect (Tok_Semicolon, "`;`");
Remove_Next_End_Node;
else
Error_Msg (Flags, "expected IS", Token_Ptr);
end if;
end Parse_Package_Declaration;
-----------------------------------
-- Parse_String_Type_Declaration --
-----------------------------------
procedure Parse_String_Type_Declaration
(In_Tree : Project_Node_Tree_Ref;
String_Type : out Project_Node_Id;
Current_Project : Project_Node_Id;
Flags : Processing_Flags)
is
Current : Project_Node_Id := Empty_Node;
First_String : Project_Node_Id := Empty_Node;
begin
String_Type :=
Default_Project_Node
(Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree);
Set_Location_Of (String_Type, In_Tree, To => Token_Ptr);
-- Scan past "type"
Scan (In_Tree);
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
Set_Name_Of (String_Type, In_Tree, To => Token_Name);
Current := First_String_Type_Of (Current_Project, In_Tree);
while Present (Current)
and then
Name_Of (Current, In_Tree) /= Token_Name
loop
Current := Next_String_Type (Current, In_Tree);
end loop;
if Present (Current) then
Error_Msg (Flags,
"duplicate string type name """ &
Get_Name_String (Token_Name) &
"""",
Token_Ptr);
else
Current := First_Variable_Of (Current_Project, In_Tree);
while Present (Current)
and then Name_Of (Current, In_Tree) /= Token_Name
loop
Current := Next_Variable (Current, In_Tree);
end loop;
if Present (Current) then
Error_Msg (Flags,
"""" &
Get_Name_String (Token_Name) &
""" is already a variable name", Token_Ptr);
else
Set_Next_String_Type
(String_Type, In_Tree,
To => First_String_Type_Of (Current_Project, In_Tree));
Set_First_String_Type_Of
(Current_Project, In_Tree, To => String_Type);
end if;
end if;
-- Scan past the name
Scan (In_Tree);
end if;
Expect (Tok_Is, "IS");
if Token = Tok_Is then
Scan (In_Tree);
end if;
Expect (Tok_Left_Paren, "`(`");
if Token = Tok_Left_Paren then
Scan (In_Tree);
end if;
Parse_String_Type_List
(In_Tree => In_Tree, First_String => First_String, Flags => Flags);
Set_First_Literal_String (String_Type, In_Tree, To => First_String);
Expect (Tok_Right_Paren, "`)`");
if Token = Tok_Right_Paren then
Scan (In_Tree);
end if;
end Parse_String_Type_Declaration;
--------------------------------
-- Parse_Variable_Declaration --
--------------------------------
procedure Parse_Variable_Declaration
(In_Tree : Project_Node_Tree_Ref;
Variable : out Project_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id;
Flags : Processing_Flags)
is
Expression_Location : Source_Ptr;
String_Type_Name : Name_Id := No_Name;
Project_String_Type_Name : Name_Id := No_Name;
Type_Location : Source_Ptr := No_Location;
Project_Location : Source_Ptr := No_Location;
Expression : Project_Node_Id := Empty_Node;
Variable_Name : constant Name_Id := Token_Name;
OK : Boolean := True;
begin
Variable :=
Default_Project_Node
(Of_Kind => N_Variable_Declaration, In_Tree => In_Tree);
Set_Name_Of (Variable, In_Tree, To => Variable_Name);
Set_Location_Of (Variable, In_Tree, To => Token_Ptr);
-- Scan past the variable name
Scan (In_Tree);
if Token = Tok_Colon then
-- Typed string variable declaration
Scan (In_Tree);
Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration);
Expect (Tok_Identifier, "identifier");
OK := Token = Tok_Identifier;
if OK then
String_Type_Name := Token_Name;
Type_Location := Token_Ptr;
Scan (In_Tree);
if Token = Tok_Dot then
Project_String_Type_Name := String_Type_Name;
Project_Location := Type_Location;
-- Scan past the dot
Scan (In_Tree);
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
String_Type_Name := Token_Name;
Type_Location := Token_Ptr;
Scan (In_Tree);
else
OK := False;
end if;
end if;
if OK then
declare
Proj : Project_Node_Id := Current_Project;
Current : Project_Node_Id := Empty_Node;
begin
if Project_String_Type_Name /= No_Name then
declare
The_Project_Name_And_Node : constant
Tree_Private_Part.Project_Name_And_Node :=
Tree_Private_Part.Projects_Htable.Get
(In_Tree.Projects_HT, Project_String_Type_Name);
use Tree_Private_Part;
begin
if The_Project_Name_And_Node =
Tree_Private_Part.No_Project_Name_And_Node
then
Error_Msg (Flags,
"unknown project """ &
Get_Name_String
(Project_String_Type_Name) &
"""",
Project_Location);
Current := Empty_Node;
else
Current :=
First_String_Type_Of
(The_Project_Name_And_Node.Node, In_Tree);
while
Present (Current)
and then
Name_Of (Current, In_Tree) /= String_Type_Name
loop
Current := Next_String_Type (Current, In_Tree);
end loop;
end if;
end;
else
-- Look for a string type with the correct name in this
-- project or in any of its ancestors.
loop
Current :=
First_String_Type_Of (Proj, In_Tree);
while
Present (Current)
and then
Name_Of (Current, In_Tree) /= String_Type_Name
loop
Current := Next_String_Type (Current, In_Tree);
end loop;
exit when Present (Current);
Proj := Parent_Project_Of (Proj, In_Tree);
exit when No (Proj);
end loop;
end if;
if No (Current) then
Error_Msg (Flags,
"unknown string type """ &
Get_Name_String (String_Type_Name) &
"""",
Type_Location);
OK := False;
else
Set_String_Type_Of
(Variable, In_Tree, To => Current);
end if;
end;
end if;
end if;
end if;
Expect (Tok_Colon_Equal, "`:=`");
OK := OK and then Token = Tok_Colon_Equal;
if Token = Tok_Colon_Equal then
Scan (In_Tree);
end if;
-- Get the single string or string list value
Expression_Location := Token_Ptr;
Parse_Expression
(In_Tree => In_Tree,
Expression => Expression,
Flags => Flags,
Current_Project => Current_Project,
Current_Package => Current_Package,
Optional_Index => False);
Set_Expression_Of (Variable, In_Tree, To => Expression);
if Present (Expression) then
-- A typed string must have a single string value, not a list
if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration
and then Expression_Kind_Of (Expression, In_Tree) = List
then
Error_Msg
(Flags,
"expression must be a single string", Expression_Location);
end if;
Set_Expression_Kind_Of
(Variable, In_Tree,
To => Expression_Kind_Of (Expression, In_Tree));
end if;
if OK then
declare
The_Variable : Project_Node_Id := Empty_Node;
begin
if Present (Current_Package) then
The_Variable := First_Variable_Of (Current_Package, In_Tree);
elsif Present (Current_Project) then
The_Variable := First_Variable_Of (Current_Project, In_Tree);
end if;
while Present (The_Variable)
and then Name_Of (The_Variable, In_Tree) /= Variable_Name
loop
The_Variable := Next_Variable (The_Variable, In_Tree);
end loop;
if No (The_Variable) then
if Present (Current_Package) then
Set_Next_Variable
(Variable, In_Tree,
To => First_Variable_Of (Current_Package, In_Tree));
Set_First_Variable_Of
(Current_Package, In_Tree, To => Variable);
elsif Present (Current_Project) then
Set_Next_Variable
(Variable, In_Tree,
To => First_Variable_Of (Current_Project, In_Tree));
Set_First_Variable_Of
(Current_Project, In_Tree, To => Variable);
end if;
else
if Expression_Kind_Of (Variable, In_Tree) /= Undefined then
if Expression_Kind_Of (The_Variable, In_Tree) =
Undefined
then
Set_Expression_Kind_Of
(The_Variable, In_Tree,
To => Expression_Kind_Of (Variable, In_Tree));
else
if Expression_Kind_Of (The_Variable, In_Tree) /=
Expression_Kind_Of (Variable, In_Tree)
then
Error_Msg (Flags,
"wrong expression kind for variable """ &
Get_Name_String
(Name_Of (The_Variable, In_Tree)) &
"""",
Expression_Location);
end if;
end if;
end if;
end if;
end;
end if;
end Parse_Variable_Declaration;
end Prj.Dect;
gprbuild-gpl-2014-src/gnat/mlib-tgt.ads 0000644 0000767 0000145 00000027714 12323721731 017307 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M L I B . T G T --
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2009, AdaCore --
-- --
-- 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides a set of target dependent routines to build static,
-- dynamic and shared libraries. There are several packages providing
-- the actual routines. This package calls them indirectly by means of
-- access-to-subprogram values. Each target-dependent package initializes
-- these values in its elaboration block.
with Prj; use Prj;
package MLib.Tgt is
function Support_For_Libraries return Library_Support;
-- Indicates how building libraries by gnatmake is supported by the GNAT
-- implementation for the platform.
function Standalone_Library_Auto_Init_Is_Supported return Boolean;
-- Indicates if when building a dynamic Standalone Library,
-- automatic initialization is supported. If it is, then it is the default,
-- unless attribute Library_Auto_Init has the value "false".
function Archive_Builder return String;
-- Returns the name of the archive builder program, usually "ar"
function Archive_Builder_Options return String_List_Access;
-- A list of options to invoke the Archive_Builder, usually "cr" for "ar"
function Archive_Builder_Append_Options return String_List_Access;
-- A list of options to use with the archive builder to append object
-- files ("q", for example).
function Archive_Indexer return String;
-- Returns the name of the program, if any, that generates an index to the
-- contents of an archive, usually "ranlib". If there is no archive indexer
-- to be used, returns an empty string.
function Archive_Indexer_Options return String_List_Access;
-- A list of options to invoke the Archive_Indexer, usually empty
function Dynamic_Option return String;
-- gcc option to create a dynamic library.
-- For Unix, returns "-shared", for Windows returns "-mdll".
function Libgnat return String;
-- System dependent static GNAT library
function Archive_Ext return String;
-- System dependent static library extension, without leading dot.
-- For Unix and Windows, return "a".
function Object_Ext return String;
-- System dependent object extension, without leading dot.
-- On Unix, returns "o".
function DLL_Prefix return String;
-- System dependent dynamic library prefix.
-- On Windows, returns "". On other platforms, returns "lib".
function DLL_Ext return String;
-- System dependent dynamic library extension, without leading dot.
-- On Windows, returns "dll". On Unix, usually returns "so", but not
-- always, e.g. on HP-UX the extension for shared libraries is "sl".
function PIC_Option return String;
-- Position independent code option
function Is_Object_Ext (Ext : String) return Boolean;
-- 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
function Is_Archive_Ext (Ext : String) return Boolean;
-- Returns True iff Ext is an extension for a library
function Default_Symbol_File_Name return String;
-- Returns the name of the symbol file when Library_Symbol_File is not
-- specified. Return the empty string when symbol files are not supported.
procedure Build_Dynamic_Library
(Ofiles : Argument_List;
Options : Argument_List;
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Version : String := "";
Auto_Init : Boolean := False);
-- Build a dynamic/relocatable library
--
-- Ofiles is the list of all object files in the library
--
-- Options is a list of options to be passed to the tool
-- (gcc or other) that effectively builds the dynamic library.
--
-- Interfaces is the list of ALI files for the interfaces of a SAL.
-- It is empty if the library is not a SAL.
--
-- Lib_Filename is the name of the library, without any prefix or
-- extension. For example, on Unix, if Lib_Filename is "toto", the
-- name of the library file will be "libtoto.so".
--
-- Lib_Dir is the directory path where the library will be located
--
-- 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.
--
-- Symbol_Data is used for some platforms, including VMS, to generate
-- the symbols to be exported by the library.
--
-- Note: Depending on the OS, some of the parameters may not be taken into
-- account. For example, on Linux, Interfaces, Symbol_Data and Auto_Init
-- are ignored.
function Library_Exists_For
(Project : Project_Id;
In_Tree : Project_Tree_Ref) return Boolean;
-- Return True if the library file for a library project already exists.
-- This function can only be called for library projects.
function Library_File_Name_For
(Project : Project_Id;
In_Tree : Project_Tree_Ref) return File_Name_Type;
-- Returns the file name of the library file of a library project.
-- This function can only be called for library projects.
function Library_Major_Minor_Id_Supported return Boolean;
-- Indicates if major and minor ids are supported for libraries.
-- If they are supported, then a Library_Version such as libtoto.so.1.2
-- will have a major id of 1 and a minor id of 2. Then libtoto.so,
-- libtoto.so.1 and libtoto.so.1.2 will be created, all three designating
-- the same file.
private
No_Argument_List : constant Argument_List := (1 .. 0 => null);
-- Access to subprogram types for indirection
type String_Function is access function return String;
type Is_Ext_Function is access function (Ext : String) return Boolean;
type String_List_Access_Function is access function
return String_List_Access;
type Build_Dynamic_Library_Function is access procedure
(Ofiles : Argument_List;
Options : Argument_List;
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Version : String := "";
Auto_Init : Boolean := False);
type Library_Exists_For_Function is access function
(Project : Project_Id;
In_Tree : Project_Tree_Ref) return Boolean;
type Library_File_Name_For_Function is access function
(Project : Project_Id;
In_Tree : Project_Tree_Ref) return File_Name_Type;
type Boolean_Function is access function return Boolean;
type Library_Support_Function is access function return Library_Support;
function Archive_Builder_Default return String;
Archive_Builder_Ptr : String_Function := Archive_Builder_Default'Access;
function Archive_Builder_Options_Default return String_List_Access;
Archive_Builder_Options_Ptr : String_List_Access_Function :=
Archive_Builder_Options_Default'Access;
function Archive_Builder_Append_Options_Default return String_List_Access;
Archive_Builder_Append_Options_Ptr : String_List_Access_Function :=
Archive_Builder_Append_Options_Default'Access;
function Archive_Ext_Default return String;
Archive_Ext_Ptr : String_Function := Archive_Ext_Default'Access;
function Archive_Indexer_Default return String;
Archive_Indexer_Ptr : String_Function := Archive_Indexer_Default'Access;
function Archive_Indexer_Options_Default return String_List_Access;
Archive_Indexer_Options_Ptr : String_List_Access_Function :=
Archive_Indexer_Options_Default'Access;
function Default_Symbol_File_Name_Default return String;
Default_Symbol_File_Name_Ptr : String_Function :=
Default_Symbol_File_Name_Default'Access;
Build_Dynamic_Library_Ptr : Build_Dynamic_Library_Function;
function DLL_Ext_Default return String;
DLL_Ext_Ptr : String_Function := DLL_Ext_Default'Access;
function DLL_Prefix_Default return String;
DLL_Prefix_Ptr : String_Function := DLL_Prefix_Default'Access;
function Dynamic_Option_Default return String;
Dynamic_Option_Ptr : String_Function := Dynamic_Option_Default'Access;
function Is_Object_Ext_Default (Ext : String) return Boolean;
Is_Object_Ext_Ptr : Is_Ext_Function := Is_Object_Ext_Default'Access;
function Is_C_Ext_Default (Ext : String) return Boolean;
Is_C_Ext_Ptr : Is_Ext_Function := Is_C_Ext_Default'Access;
function Is_Archive_Ext_Default (Ext : String) return Boolean;
Is_Archive_Ext_Ptr : Is_Ext_Function := Is_Archive_Ext_Default'Access;
function Libgnat_Default return String;
Libgnat_Ptr : String_Function := Libgnat_Default'Access;
function Library_Exists_For_Default
(Project : Project_Id;
In_Tree : Project_Tree_Ref) return Boolean;
Library_Exists_For_Ptr : Library_Exists_For_Function :=
Library_Exists_For_Default'Access;
function Library_File_Name_For_Default
(Project : Project_Id;
In_Tree : Project_Tree_Ref) return File_Name_Type;
Library_File_Name_For_Ptr : Library_File_Name_For_Function :=
Library_File_Name_For_Default'Access;
function Object_Ext_Default return String;
Object_Ext_Ptr : String_Function := Object_Ext_Default'Access;
function PIC_Option_Default return String;
PIC_Option_Ptr : String_Function := PIC_Option_Default'Access;
function Standalone_Library_Auto_Init_Is_Supported_Default return Boolean;
Standalone_Library_Auto_Init_Is_Supported_Ptr : Boolean_Function :=
Standalone_Library_Auto_Init_Is_Supported_Default'Access;
function Support_For_Libraries_Default return Library_Support;
Support_For_Libraries_Ptr : Library_Support_Function :=
Support_For_Libraries_Default'Access;
function Library_Major_Minor_Id_Supported_Default return Boolean;
Library_Major_Minor_Id_Supported_Ptr : Boolean_Function :=
Library_Major_Minor_Id_Supported_Default'Access;
end MLib.Tgt;
gprbuild-gpl-2014-src/gnat/prj-ext.adb 0000644 0000767 0000145 00000021622 12323721731 017130 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . E X T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2013, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Osint; use Osint;
with Ada.Unchecked_Deallocation;
package body Prj.Ext is
----------------
-- Initialize --
----------------
procedure Initialize
(Self : out External_References;
Copy_From : External_References := No_External_Refs)
is
N : Name_To_Name_Ptr;
N2 : Name_To_Name_Ptr;
begin
if Self.Refs = null then
Self.Refs := new Name_To_Name_HTable.Instance;
if Copy_From.Refs /= null then
N := Name_To_Name_HTable.Get_First (Copy_From.Refs.all);
while N /= null loop
N2 := new Name_To_Name'
(Key => N.Key,
Value => N.Value,
Source => N.Source,
Next => null);
Name_To_Name_HTable.Set (Self.Refs.all, N2);
N := Name_To_Name_HTable.Get_Next (Copy_From.Refs.all);
end loop;
end if;
end if;
end Initialize;
---------
-- Add --
---------
procedure Add
(Self : External_References;
External_Name : String;
Value : String;
Source : External_Source := External_Source'First;
Silent : Boolean := False)
is
Key : Name_Id;
N : Name_To_Name_Ptr;
begin
-- For external attribute, set the environment variable
if Source = From_External_Attribute and then External_Name /= "" then
declare
Env_Var : String_Access := Getenv (External_Name);
begin
if Env_Var = null or else Env_Var.all = "" then
Setenv (Name => External_Name, Value => Value);
if not Silent then
Debug_Output
("Environment variable """ & External_Name
& """ = """ & Value & '"');
end if;
elsif not Silent then
Debug_Output
("Not overriding existing environment variable """
& External_Name & """, value is """ & Env_Var.all & '"');
end if;
Free (Env_Var);
end;
end if;
Name_Len := External_Name'Length;
Name_Buffer (1 .. Name_Len) := External_Name;
Canonical_Case_Env_Var_Name (Name_Buffer (1 .. Name_Len));
Key := Name_Find;
-- Check whether the value is already defined, to properly respect the
-- overriding order.
if Source /= External_Source'First then
N := Name_To_Name_HTable.Get (Self.Refs.all, Key);
if N /= null then
if External_Source'Pos (N.Source) <
External_Source'Pos (Source)
then
if not Silent then
Debug_Output
("Not overridding existing external reference '"
& External_Name & "', value was defined in "
& N.Source'Img);
end if;
return;
end if;
end if;
end if;
Name_Len := Value'Length;
Name_Buffer (1 .. Name_Len) := Value;
N := new Name_To_Name'
(Key => Key,
Source => Source,
Value => Name_Find,
Next => null);
if not Silent then
Debug_Output ("Add external (" & External_Name & ") is", N.Value);
end if;
Name_To_Name_HTable.Set (Self.Refs.all, N);
end Add;
-----------
-- Check --
-----------
function Check
(Self : External_References;
Declaration : String) return Boolean
is
begin
for Equal_Pos in Declaration'Range loop
if Declaration (Equal_Pos) = '=' then
exit when Equal_Pos = Declaration'First;
Add
(Self => Self,
External_Name =>
Declaration (Declaration'First .. Equal_Pos - 1),
Value =>
Declaration (Equal_Pos + 1 .. Declaration'Last),
Source => From_Command_Line);
return True;
end if;
end loop;
return False;
end Check;
-----------
-- Reset --
-----------
procedure Reset (Self : External_References) is
begin
if Self.Refs /= null then
Debug_Output ("Reset external references");
Name_To_Name_HTable.Reset (Self.Refs.all);
end if;
end Reset;
--------------
-- Value_Of --
--------------
function Value_Of
(Self : External_References;
External_Name : Name_Id;
With_Default : Name_Id := No_Name)
return Name_Id
is
Value : Name_To_Name_Ptr;
Val : Name_Id;
Name : String := Get_Name_String (External_Name);
begin
Canonical_Case_Env_Var_Name (Name);
if Self.Refs /= null then
Name_Len := Name'Length;
Name_Buffer (1 .. Name_Len) := Name;
Value := Name_To_Name_HTable.Get (Self.Refs.all, Name_Find);
if Value /= null then
Debug_Output ("Value_Of (" & Name & ") is in cache", Value.Value);
return Value.Value;
end if;
end if;
-- Find if it is an environment, if it is, put value in the hash table
declare
Env_Value : String_Access := Getenv (Name);
begin
if Env_Value /= null and then Env_Value'Length > 0 then
Name_Len := Env_Value'Length;
Name_Buffer (1 .. Name_Len) := Env_Value.all;
Val := Name_Find;
if Current_Verbosity = High then
Debug_Output ("Value_Of (" & Name & ") is", Val);
end if;
if Self.Refs /= null then
Value := new Name_To_Name'
(Key => External_Name,
Value => Val,
Source => From_Environment,
Next => null);
Name_To_Name_HTable.Set (Self.Refs.all, Value);
end if;
Free (Env_Value);
return Val;
else
if Current_Verbosity = High then
Debug_Output
("Value_Of (" & Name & ") is default", With_Default);
end if;
Free (Env_Value);
return With_Default;
end if;
end;
end Value_Of;
----------
-- Free --
----------
procedure Free (Self : in out External_References) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Name_To_Name_HTable.Instance, Instance_Access);
begin
if Self.Refs /= null then
Reset (Self);
Unchecked_Free (Self.Refs);
end if;
end Free;
--------------
-- Set_Next --
--------------
procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr) is
begin
E.Next := Next;
end Set_Next;
----------
-- Next --
----------
function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr is
begin
return E.Next;
end Next;
-------------
-- Get_Key --
-------------
function Get_Key (E : Name_To_Name_Ptr) return Name_Id is
begin
return E.Key;
end Get_Key;
end Prj.Ext;
gprbuild-gpl-2014-src/gnat/mlib-fil.adb 0000644 0000767 0000145 00000010654 12323721731 017235 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M L I B . F I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2007, AdaCore --
-- --
-- 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides a set of routines to deal with file extensions
with Ada.Strings.Fixed;
with MLib.Tgt;
package body MLib.Fil is
use Ada;
package Target renames MLib.Tgt;
---------------
-- Append_To --
---------------
function Append_To
(Filename : String;
Ext : String) return String
is
begin
if Ext'Length = 0 then
return Filename;
elsif Filename (Filename'Last) = '.' then
if Ext (Ext'First) = '.' then
return Filename & Ext (Ext'First + 1 .. Ext'Last);
else
return Filename & Ext;
end if;
else
if Ext (Ext'First) = '.' then
return Filename & Ext;
else
return Filename & '.' & Ext;
end if;
end if;
end Append_To;
------------
-- Ext_To --
------------
function Ext_To
(Filename : String;
New_Ext : String := "") return String
is
use Strings.Fixed;
J : constant Natural :=
Index (Source => Filename,
Pattern => ".",
Going => Strings.Backward);
begin
if J = 0 then
if New_Ext = "" then
return Filename;
else
return Filename & "." & New_Ext;
end if;
else
if New_Ext = "" then
return Head (Filename, J - 1);
else
return Head (Filename, J - 1) & '.' & New_Ext;
end if;
end if;
end Ext_To;
-------------
-- Get_Ext --
-------------
function Get_Ext (Filename : String) return String is
use Strings.Fixed;
J : constant Natural :=
Index (Source => Filename,
Pattern => ".",
Going => Strings.Backward);
begin
if J = 0 then
return "";
else
return Filename (J .. Filename'Last);
end if;
end Get_Ext;
----------------
-- Is_Archive --
----------------
function Is_Archive (Filename : String) return Boolean is
Ext : constant String := Get_Ext (Filename);
begin
return Target.Is_Archive_Ext (Ext);
end Is_Archive;
----------
-- Is_C --
----------
function Is_C (Filename : String) return Boolean is
Ext : constant String := Get_Ext (Filename);
begin
return Target.Is_C_Ext (Ext);
end Is_C;
------------
-- Is_Obj --
------------
function Is_Obj (Filename : String) return Boolean is
Ext : constant String := Get_Ext (Filename);
begin
return Target.Is_Object_Ext (Ext);
end Is_Obj;
end MLib.Fil;
gprbuild-gpl-2014-src/gnat/binderr.adb 0000644 0000767 0000145 00000015755 12323721731 017176 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- B I N D E R R --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2008, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Butil; use Butil;
with Opt; use Opt;
with Output; use Output;
package body Binderr is
---------------
-- Error_Msg --
---------------
procedure Error_Msg (Msg : String) is
begin
if Msg (Msg'First) = '?' then
if Warning_Mode = Suppress then
return;
end if;
if Warning_Mode = Treat_As_Error then
Errors_Detected := Errors_Detected + 1;
else
Warnings_Detected := Warnings_Detected + 1;
end if;
else
Errors_Detected := Errors_Detected + 1;
end if;
if Brief_Output or else (not Verbose_Mode) then
Set_Standard_Error;
Error_Msg_Output (Msg, Info => False);
Set_Standard_Output;
end if;
if Verbose_Mode then
if Errors_Detected + Warnings_Detected = 0 then
Write_Eol;
end if;
Error_Msg_Output (Msg, Info => False);
end if;
-- If too many warnings print message and then turn off warnings
if Warnings_Detected = Maximum_Messages then
Set_Standard_Error;
Write_Line ("maximum number of warnings reached");
Write_Line ("further warnings will be suppressed");
Set_Standard_Output;
Warning_Mode := Suppress;
end if;
-- If too many errors print message and give fatal error
if Errors_Detected = Maximum_Messages then
Set_Standard_Error;
Write_Line ("fatal error: maximum number of errors exceeded");
Set_Standard_Output;
raise Unrecoverable_Error;
end if;
end Error_Msg;
--------------------
-- Error_Msg_Info --
--------------------
procedure Error_Msg_Info (Msg : String) is
begin
if Brief_Output or else (not Verbose_Mode) then
Set_Standard_Error;
Error_Msg_Output (Msg, Info => True);
Set_Standard_Output;
end if;
if Verbose_Mode then
Error_Msg_Output (Msg, Info => True);
end if;
end Error_Msg_Info;
----------------------
-- Error_Msg_Output --
----------------------
procedure Error_Msg_Output (Msg : String; Info : Boolean) is
Use_Second_File : Boolean := False;
Use_Second_Unit : Boolean := False;
Use_Second_Nat : Boolean := False;
Warning : Boolean := False;
begin
if Warnings_Detected + Errors_Detected > Maximum_Messages then
Write_Str ("error: maximum errors exceeded");
Write_Eol;
return;
end if;
-- First, check for warnings
for J in Msg'Range loop
if Msg (J) = '?' then
Warning := True;
exit;
end if;
end loop;
if Warning then
Write_Str ("warning: ");
elsif Info then
if not Info_Prefix_Suppress then
Write_Str ("info: ");
end if;
else
Write_Str ("error: ");
end if;
for J in Msg'Range loop
if Msg (J) = '%' then
Get_Name_String (Error_Msg_Name_1);
Write_Char ('"');
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Char ('"');
elsif Msg (J) = '{' then
if Use_Second_File then
Get_Name_String (Error_Msg_File_2);
else
Use_Second_File := True;
Get_Name_String (Error_Msg_File_1);
end if;
Write_Char ('"');
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Char ('"');
elsif Msg (J) = '$' then
Write_Char ('"');
if Use_Second_Unit then
Write_Unit_Name (Error_Msg_Unit_2);
else
Use_Second_Unit := True;
Write_Unit_Name (Error_Msg_Unit_1);
end if;
Write_Char ('"');
elsif Msg (J) = '#' then
if Use_Second_Nat then
Write_Int (Error_Msg_Nat_2);
else
Use_Second_Nat := True;
Write_Int (Error_Msg_Nat_1);
end if;
elsif Msg (J) /= '?' then
Write_Char (Msg (J));
end if;
end loop;
Write_Eol;
end Error_Msg_Output;
----------------------
-- Finalize_Binderr --
----------------------
procedure Finalize_Binderr is
begin
-- Message giving number of errors detected (verbose mode only)
if Verbose_Mode then
Write_Eol;
if Errors_Detected = 0 then
Write_Str ("No errors");
elsif Errors_Detected = 1 then
Write_Str ("1 error");
else
Write_Int (Errors_Detected);
Write_Str (" errors");
end if;
if Warnings_Detected = 1 then
Write_Str (", 1 warning");
elsif Warnings_Detected > 1 then
Write_Str (", ");
Write_Int (Warnings_Detected);
Write_Str (" warnings");
end if;
Write_Eol;
end if;
end Finalize_Binderr;
------------------------
-- Initialize_Binderr --
------------------------
procedure Initialize_Binderr is
begin
Errors_Detected := 0;
Warnings_Detected := 0;
end Initialize_Binderr;
end Binderr;
gprbuild-gpl-2014-src/gnat/mlib.adb 0000644 0000767 0000145 00000036505 12323721731 016470 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M L I B --
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2009, AdaCore --
-- --
-- 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Interfaces.C.Strings;
with System;
with Hostparm;
with Opt;
with Output; use Output;
with MLib.Utl; use MLib.Utl;
with Prj.Com;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
package body MLib is
-------------------
-- Build_Library --
-------------------
procedure Build_Library
(Ofiles : Argument_List;
Output_File : String;
Output_Dir : String)
is
begin
if Opt.Verbose_Mode and not Opt.Quiet_Output then
Write_Line ("building a library...");
Write_Str (" make ");
Write_Line (Output_File);
end if;
Ar (Output_Dir &
"lib" & Output_File & ".a", Objects => Ofiles);
end Build_Library;
------------------------
-- Check_Library_Name --
------------------------
procedure Check_Library_Name (Name : String) is
begin
if Name'Length = 0 then
Prj.Com.Fail ("library name cannot be empty");
end if;
if Name'Length > Max_Characters_In_Library_Name then
Prj.Com.Fail ("illegal library name """
& Name
& """: too long");
end if;
if not Is_Letter (Name (Name'First)) then
Prj.Com.Fail ("illegal library name """
& Name
& """: should start with a letter");
end if;
for Index in Name'Range loop
if not Is_Alphanumeric (Name (Index)) then
Prj.Com.Fail ("illegal library name """
& Name
& """: should include only letters and digits");
end if;
end loop;
end Check_Library_Name;
--------------------
-- Copy_ALI_Files --
--------------------
procedure Copy_ALI_Files
(Files : Argument_List;
To : Path_Name_Type;
Interfaces : String_List)
is
Success : Boolean := False;
To_Dir : constant String := Get_Name_String (To);
Is_Interface : Boolean := False;
procedure Verbose_Copy (Index : Positive);
-- In verbose mode, output a message that the indexed file is copied
-- to the destination directory.
------------------
-- Verbose_Copy --
------------------
procedure Verbose_Copy (Index : Positive) is
begin
if Opt.Verbose_Mode then
Write_Str ("Copying """);
Write_Str (Files (Index).all);
Write_Str (""" to """);
Write_Str (To_Dir);
Write_Line ("""");
end if;
end Verbose_Copy;
-- Start of processing for Copy_ALI_Files
begin
if Interfaces'Length = 0 then
-- If there are no Interfaces, copy all the ALI files as is
for Index in Files'Range loop
Verbose_Copy (Index);
Set_Writable
(To_Dir &
Directory_Separator &
Base_Name (Files (Index).all));
Copy_File
(Files (Index).all,
To_Dir,
Success,
Mode => Overwrite,
Preserve => Preserve);
exit when not Success;
end loop;
else
-- Copy only the interface ALI file, and put the special indicator
-- "SL" on the P line.
for Index in Files'Range loop
declare
File_Name : String := Base_Name (Files (Index).all);
begin
Canonical_Case_File_Name (File_Name);
-- Check if this is one of the interface ALIs
Is_Interface := False;
for Index in Interfaces'Range loop
if File_Name = Interfaces (Index).all then
Is_Interface := True;
exit;
end if;
end loop;
-- If it is an interface ALI, copy line by line. Insert
-- the interface indication at the end of the P line.
-- Do not copy ALI files that are not Interfaces.
if Is_Interface then
Success := False;
Verbose_Copy (Index);
Set_Writable
(To_Dir &
Directory_Separator &
Base_Name (Files (Index).all));
declare
FD : File_Descriptor;
Len : Integer;
Actual_Len : Integer;
S : String_Access;
Curr : Natural;
P_Line_Found : Boolean;
Status : Boolean;
begin
-- Open the file
Name_Len := Files (Index)'Length;
Name_Buffer (1 .. Name_Len) := Files (Index).all;
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.NUL;
FD := Open_Read (Name_Buffer'Address, Binary);
if FD /= Invalid_FD then
Len := Integer (File_Length (FD));
-- ??? Why "+3" here
S := new String (1 .. Len + 3);
-- Read the file. Note that the loop is not necessary
-- since the whole file is read at once except on VMS.
Curr := S'First;
while Curr <= Len loop
Actual_Len := Read (FD, S (Curr)'Address, Len);
-- Exit if we could not read for some reason
exit when Actual_Len = 0;
Curr := Curr + Actual_Len;
end loop;
-- We are done with the input file, so we close it
-- ignoring any bad status.
Close (FD, Status);
P_Line_Found := False;
-- Look for the P line. When found, add marker SL
-- at the beginning of the P line.
for Index in 1 .. Len - 3 loop
if (S (Index) = ASCII.LF
or else
S (Index) = ASCII.CR)
and then S (Index + 1) = 'P'
then
S (Index + 5 .. Len + 3) := S (Index + 2 .. Len);
S (Index + 2 .. Index + 4) := " SL";
P_Line_Found := True;
exit;
end if;
end loop;
if P_Line_Found then
-- Create new modified ALI file
Name_Len := To_Dir'Length;
Name_Buffer (1 .. Name_Len) := To_Dir;
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Directory_Separator;
Name_Buffer
(Name_Len + 1 .. Name_Len + File_Name'Length) :=
File_Name;
Name_Len := Name_Len + File_Name'Length + 1;
Name_Buffer (Name_Len) := ASCII.NUL;
FD := Create_File (Name_Buffer'Address, Binary);
-- Write the modified text and close the newly
-- created file.
if FD /= Invalid_FD then
Actual_Len := Write (FD, S (1)'Address, Len + 3);
Close (FD, Status);
-- Set Success to True only if the newly
-- created file has been correctly written.
Success := Status and then Actual_Len = Len + 3;
if Success then
-- Set_Read_Only is used here, rather than
-- Set_Non_Writable, so that gprbuild can
-- he compiled with older compilers.
Set_Read_Only
(Name_Buffer (1 .. Name_Len - 1));
end if;
end if;
end if;
end if;
end;
-- This is not an interface ALI
else
Success := True;
end if;
end;
if not Success then
Prj.Com.Fail ("could not copy ALI files to library dir");
end if;
end loop;
end if;
end Copy_ALI_Files;
----------------------
-- Create_Sym_Links --
----------------------
procedure Create_Sym_Links
(Lib_Path : String;
Lib_Version : String;
Lib_Dir : String;
Maj_Version : String)
is
function Symlink
(Oldpath : System.Address;
Newpath : System.Address) return Integer;
pragma Import (C, Symlink, "__gnat_symlink");
Version_Path : String_Access;
Success : Boolean;
Result : Integer;
pragma Unreferenced (Success, Result);
begin
Version_Path := new String (1 .. Lib_Version'Length + 1);
Version_Path (1 .. Lib_Version'Length) := Lib_Version;
Version_Path (Version_Path'Last) := ASCII.NUL;
if Maj_Version'Length = 0 then
declare
Newpath : String (1 .. Lib_Path'Length + 1);
begin
Newpath (1 .. Lib_Path'Length) := Lib_Path;
Newpath (Newpath'Last) := ASCII.NUL;
Delete_File (Lib_Path, Success);
Result := Symlink (Version_Path (1)'Address, Newpath'Address);
end;
else
declare
Newpath1 : String (1 .. Lib_Path'Length + 1);
Maj_Path : constant String :=
Lib_Dir & Directory_Separator & Maj_Version;
Newpath2 : String (1 .. Maj_Path'Length + 1);
Maj_Ver : String (1 .. Maj_Version'Length + 1);
begin
Newpath1 (1 .. Lib_Path'Length) := Lib_Path;
Newpath1 (Newpath1'Last) := ASCII.NUL;
Newpath2 (1 .. Maj_Path'Length) := Maj_Path;
Newpath2 (Newpath2'Last) := ASCII.NUL;
Maj_Ver (1 .. Maj_Version'Length) := Maj_Version;
Maj_Ver (Maj_Ver'Last) := ASCII.NUL;
Delete_File (Maj_Path, Success);
Result := Symlink (Version_Path (1)'Address, Newpath2'Address);
Delete_File (Lib_Path, Success);
Result := Symlink (Maj_Ver'Address, Newpath1'Address);
end;
end if;
end Create_Sym_Links;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
function Linker_Library_Path_Option return String_Access is
Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option");
-- Pointer to string representing the native linker option which
-- specifies the path where the dynamic loader should find shared
-- libraries. Equal to null string if this system doesn't support it.
S : constant String := Interfaces.C.Strings.Value (Run_Path_Option_Ptr);
begin
if S'Length = 0 then
return null;
else
return new String'(S);
end if;
end Linker_Library_Path_Option;
-------------------
-- Major_Id_Name --
-------------------
function Major_Id_Name
(Lib_Filename : String;
Lib_Version : String)
return String
is
Maj_Version : constant String := Lib_Version;
Last_Maj : Positive;
Last : Positive;
Ok_Maj : Boolean := False;
begin
Last_Maj := Maj_Version'Last;
while Last_Maj > Maj_Version'First loop
if Maj_Version (Last_Maj) in '0' .. '9' then
Last_Maj := Last_Maj - 1;
else
Ok_Maj := Last_Maj /= Maj_Version'Last and then
Maj_Version (Last_Maj) = '.';
if Ok_Maj then
Last_Maj := Last_Maj - 1;
end if;
exit;
end if;
end loop;
if Ok_Maj then
Last := Last_Maj;
while Last > Maj_Version'First loop
if Maj_Version (Last) in '0' .. '9' then
Last := Last - 1;
else
Ok_Maj := Last /= Last_Maj and then
Maj_Version (Last) = '.';
if Ok_Maj then
Last := Last - 1;
Ok_Maj :=
Maj_Version (Maj_Version'First .. Last) = Lib_Filename;
end if;
exit;
end if;
end loop;
end if;
if Ok_Maj then
return Maj_Version (Maj_Version'First .. Last_Maj);
else
return "";
end if;
end Major_Id_Name;
-------------------------------
-- Separate_Run_Path_Options --
-------------------------------
function Separate_Run_Path_Options return Boolean is
Separate_Paths : Boolean;
for Separate_Paths'Size use Character'Size;
pragma Import (C, Separate_Paths, "__gnat_separate_run_path_options");
begin
return Separate_Paths;
end Separate_Run_Path_Options;
-- Package elaboration
begin
-- Copy_Attributes always fails on VMS
if Hostparm.OpenVMS then
Preserve := None;
end if;
end MLib;
gprbuild-gpl-2014-src/gnat/targparm.adb 0000644 0000767 0000145 00000065307 12323721731 017364 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- T A R G P A R M --
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2014, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Csets; use Csets;
with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
package body Targparm is
use ASCII;
Parameters_Obtained : Boolean := False;
-- Set True after first call to Get_Target_Parameters. Used to avoid
-- reading system.ads more than once, since it cannot change.
-- The following array defines a tag name for each entry
type Targparm_Tags is
(AAM, -- AAMP
ACR, -- Always_Compatible_Rep
ASD, -- Atomic_Sync_Default
BDC, -- Backend_Divide_Checks
BOC, -- Backend_Overflow_Checks
CLA, -- Command_Line_Args
CLI, -- CLI (.NET)
CRT, -- Configurable_Run_Times
D32, -- Duration_32_Bits
DEN, -- Denorm
EXS, -- Exit_Status_Supported
FEL, -- Frontend_Layout
FFO, -- Fractional_Fixed_Ops
JVM, -- JVM
MOV, -- Machine_Overflows
MRN, -- Machine_Rounds
PAS, -- Preallocated_Stacks
RTX, -- RTX_RTSS_Kernel_Module
SAG, -- Support_Aggregates
SAP, -- Support_Atomic_Primitives
SCA, -- Support_Composite_Assign
SCC, -- Support_Composite_Compare
SCD, -- Stack_Check_Default
SCL, -- Stack_Check_Limits
SCP, -- Stack_Check_Probes
SLS, -- Support_Long_Shifts
SNZ, -- Signed_Zeros
SSL, -- Suppress_Standard_Library
UAM, -- Use_Ada_Main_Program_Name
VMS, -- OpenVMS
VXF, -- VAX Float
ZCD); -- ZCX_By_Default
Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False);
-- Flag is set True if corresponding parameter is scanned
-- The following list of string constants gives the parameter names
AAM_Str : aliased constant Source_Buffer := "AAMP";
ACR_Str : aliased constant Source_Buffer := "Always_Compatible_Rep";
ASD_Str : aliased constant Source_Buffer := "Atomic_Sync_Default";
BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks";
BOC_Str : aliased constant Source_Buffer := "Backend_Overflow_Checks";
CLA_Str : aliased constant Source_Buffer := "Command_Line_Args";
CLI_Str : aliased constant Source_Buffer := "CLI";
CRT_Str : aliased constant Source_Buffer := "Configurable_Run_Time";
D32_Str : aliased constant Source_Buffer := "Duration_32_Bits";
DEN_Str : aliased constant Source_Buffer := "Denorm";
EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported";
FEL_Str : aliased constant Source_Buffer := "Frontend_Layout";
FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops";
JVM_Str : aliased constant Source_Buffer := "JVM";
MOV_Str : aliased constant Source_Buffer := "Machine_Overflows";
MRN_Str : aliased constant Source_Buffer := "Machine_Rounds";
PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks";
RTX_Str : aliased constant Source_Buffer := "RTX_RTSS_Kernel_Module";
SAG_Str : aliased constant Source_Buffer := "Support_Aggregates";
SAP_Str : aliased constant Source_Buffer := "Support_Atomic_Primitives";
SCA_Str : aliased constant Source_Buffer := "Support_Composite_Assign";
SCC_Str : aliased constant Source_Buffer := "Support_Composite_Compare";
SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default";
SCL_Str : aliased constant Source_Buffer := "Stack_Check_Limits";
SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes";
SLS_Str : aliased constant Source_Buffer := "Support_Long_Shifts";
SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros";
SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library";
UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name";
VMS_Str : aliased constant Source_Buffer := "OpenVMS";
VXF_Str : aliased constant Source_Buffer := "VAX_Float";
ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default";
-- The following defines a set of pointers to the above strings,
-- indexed by the tag values.
type Buffer_Ptr is access constant Source_Buffer;
Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr :=
(AAM_Str'Access,
ACR_Str'Access,
ASD_Str'Access,
BDC_Str'Access,
BOC_Str'Access,
CLA_Str'Access,
CLI_Str'Access,
CRT_Str'Access,
D32_Str'Access,
DEN_Str'Access,
EXS_Str'Access,
FEL_Str'Access,
FFO_Str'Access,
JVM_Str'Access,
MOV_Str'Access,
MRN_Str'Access,
PAS_Str'Access,
RTX_Str'Access,
SAG_Str'Access,
SAP_Str'Access,
SCA_Str'Access,
SCC_Str'Access,
SCD_Str'Access,
SCL_Str'Access,
SCP_Str'Access,
SLS_Str'Access,
SNZ_Str'Access,
SSL_Str'Access,
UAM_Str'Access,
VMS_Str'Access,
VXF_Str'Access,
ZCD_Str'Access);
-----------------------
-- Local Subprograms --
-----------------------
procedure Set_Profile_Restrictions (P : Profile_Name);
-- Set Restrictions_On_Target for the given profile
---------------------------
-- Get_Target_Parameters --
---------------------------
-- Version which reads in system.ads
procedure Get_Target_Parameters
(Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
Set_RND : Set_RND_Type := null)
is
Text : Source_Buffer_Ptr;
Hi : Source_Ptr;
begin
if Parameters_Obtained then
return;
end if;
Name_Buffer (1 .. 10) := "system.ads";
Name_Len := 10;
Read_Source_File (Name_Find, Lo => 0, Hi => Hi, Src => Text);
if Text = null then
Write_Line ("fatal error, run-time library not installed correctly");
Write_Line ("cannot locate file system.ads");
raise Unrecoverable_Error;
end if;
Get_Target_Parameters
(System_Text => Text,
Source_First => 0,
Source_Last => Hi,
Make_Id => Make_Id,
Make_SC => Make_SC,
Set_RND => Set_RND);
end Get_Target_Parameters;
-- Version where caller supplies system.ads text
procedure Get_Target_Parameters
(System_Text : Source_Buffer_Ptr;
Source_First : Source_Ptr;
Source_Last : Source_Ptr;
Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
Set_RND : Set_RND_Type := null)
is
P : Source_Ptr;
-- Scans source buffer containing source of system.ads
Fatal : Boolean := False;
-- Set True if a fatal error is detected
Result : Boolean;
-- Records boolean from system line
begin
if Parameters_Obtained then
return;
else
Parameters_Obtained := True;
end if;
Opt.Address_Is_Private := False;
P := Source_First;
Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop
-- Skip comments quickly
if System_Text (P) = '-' then
goto Line_Loop_Continue;
-- Test for type Address is private
elsif System_Text (P .. P + 26) = " type Address is private;" then
Opt.Address_Is_Private := True;
P := P + 26;
goto Line_Loop_Continue;
-- Test for pragma Profile (Ravenscar);
elsif System_Text (P .. P + 26) =
"pragma Profile (Ravenscar);"
then
Set_Profile_Restrictions (Ravenscar);
Opt.Task_Dispatching_Policy := 'F';
Opt.Locking_Policy := 'C';
P := P + 27;
goto Line_Loop_Continue;
-- Test for pragma Profile (Restricted);
elsif System_Text (P .. P + 27) =
"pragma Profile (Restricted);"
then
Set_Profile_Restrictions (Restricted);
P := P + 28;
goto Line_Loop_Continue;
-- Test for pragma Restrictions
elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
P := P + 21;
Rloop : for K in All_Boolean_Restrictions loop
declare
Rname : constant String := Restriction_Id'Image (K);
begin
for J in Rname'Range loop
if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
/= Rname (J)
then
goto Rloop_Continue;
end if;
end loop;
if System_Text (P + Rname'Length) = ')' then
Restrictions_On_Target.Set (K) := True;
goto Line_Loop_Continue;
end if;
end;
<>
null;
end loop Rloop;
Ploop : for K in All_Parameter_Restrictions loop
declare
Rname : constant String :=
All_Parameter_Restrictions'Image (K);
V : Natural;
-- Accumulates value
begin
for J in Rname'Range loop
if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
/= Rname (J)
then
goto Ploop_Continue;
end if;
end loop;
if System_Text (P + Rname'Length .. P + Rname'Length + 3) =
" => "
then
P := P + Rname'Length + 4;
V := 0;
loop
if System_Text (P) in '0' .. '9' then
declare
pragma Unsuppress (Overflow_Check);
begin
-- Accumulate next digit
V := 10 * V +
Character'Pos (System_Text (P)) -
Character'Pos ('0');
exception
-- On overflow, we just ignore the pragma since
-- that is the standard handling in this case.
when Constraint_Error =>
goto Line_Loop_Continue;
end;
elsif System_Text (P) = '_' then
null;
elsif System_Text (P) = ')' then
Restrictions_On_Target.Value (K) := V;
Restrictions_On_Target.Set (K) := True;
goto Line_Loop_Continue;
else
exit Ploop;
end if;
P := P + 1;
end loop;
else
exit Ploop;
end if;
end;
<>
null;
end loop Ploop;
-- No_Dependence case
if System_Text (P .. P + 16) = "No_Dependence => " then
P := P + 17;
-- Skip this processing (and simply ignore No_Dependence lines)
-- if caller did not supply the three subprograms we need to
-- process these lines.
if Make_Id = null then
goto Line_Loop_Continue;
end if;
-- We have scanned out "pragma Restrictions (No_Dependence =>"
declare
Unit : Node_Id;
Id : Node_Id;
Start : Source_Ptr;
begin
Unit := Empty;
-- Loop through components of name, building up Unit
loop
Start := P;
while System_Text (P) /= '.'
and then
System_Text (P) /= ')'
loop
P := P + 1;
end loop;
Id := Make_Id (System_Text (Start .. P - 1));
-- If first name, just capture the identifier
if Unit = Empty then
Unit := Id;
else
Unit := Make_SC (Unit, Id);
end if;
exit when System_Text (P) = ')';
P := P + 1;
end loop;
Set_RND (Unit);
goto Line_Loop_Continue;
end;
end if;
-- Here if unrecognizable restrictions pragma form
Set_Standard_Error;
Write_Line
("fatal error: system.ads is incorrectly formatted");
Write_Str ("unrecognized or incorrect restrictions pragma: ");
while System_Text (P) /= ')'
and then
System_Text (P) /= ASCII.LF
loop
Write_Char (System_Text (P));
P := P + 1;
end loop;
Write_Eol;
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
P := P + 21;
Opt.Global_Discard_Names := True;
goto Line_Loop_Continue;
-- Locking Policy
elsif System_Text (P .. P + 22) = "pragma Locking_Policy (" then
P := P + 23;
Opt.Locking_Policy := System_Text (P);
Opt.Locking_Policy_Sloc := System_Location;
goto Line_Loop_Continue;
-- Normalize_Scalars
elsif System_Text (P .. P + 24) = "pragma Normalize_Scalars;" then
P := P + 25;
Opt.Normalize_Scalars := True;
Opt.Init_Or_Norm_Scalars := True;
goto Line_Loop_Continue;
-- Partition_Elaboration_Policy
elsif System_Text (P .. P + 36) =
"pragma Partition_Elaboration_Policy ("
then
P := P + 37;
Opt.Partition_Elaboration_Policy := System_Text (P);
Opt.Partition_Elaboration_Policy_Sloc := System_Location;
goto Line_Loop_Continue;
-- Polling (On)
elsif System_Text (P .. P + 19) = "pragma Polling (On);" then
P := P + 20;
Opt.Polling_Required := True;
goto Line_Loop_Continue;
-- Ignore pragma Pure (System)
elsif System_Text (P .. P + 20) = "pragma Pure (System);" then
P := P + 21;
goto Line_Loop_Continue;
-- Queuing Policy
elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then
P := P + 23;
Opt.Queuing_Policy := System_Text (P);
Opt.Queuing_Policy_Sloc := System_Location;
goto Line_Loop_Continue;
-- Suppress_Exception_Locations
elsif System_Text (P .. P + 35) =
"pragma Suppress_Exception_Locations;"
then
P := P + 36;
Opt.Exception_Locations_Suppressed := True;
goto Line_Loop_Continue;
-- Task_Dispatching Policy
elsif System_Text (P .. P + 31) =
"pragma Task_Dispatching_Policy ("
then
P := P + 32;
Opt.Task_Dispatching_Policy := System_Text (P);
Opt.Task_Dispatching_Policy_Sloc := System_Location;
goto Line_Loop_Continue;
-- No other pragmas are permitted
elsif System_Text (P .. P + 6) = "pragma " then
Set_Standard_Error;
Write_Line ("unrecognized line in system.ads: ");
while System_Text (P) /= ')'
and then System_Text (P) /= ASCII.LF
loop
Write_Char (System_Text (P));
P := P + 1;
end loop;
Write_Eol;
Set_Standard_Output;
Fatal := True;
-- See if we have a Run_Time_Name
elsif System_Text (P .. P + 38) =
" Run_Time_Name : constant String := """
then
P := P + 39;
Name_Len := 0;
while System_Text (P) in 'A' .. 'Z'
or else
System_Text (P) in 'a' .. 'z'
or else
System_Text (P) in '0' .. '9'
or else
System_Text (P) = ' '
or else
System_Text (P) = '_'
loop
Add_Char_To_Name_Buffer (System_Text (P));
P := P + 1;
end loop;
if System_Text (P) /= '"'
or else System_Text (P + 1) /= ';'
or else (System_Text (P + 2) /= ASCII.LF
and then
System_Text (P + 2) /= ASCII.CR)
then
Set_Standard_Error;
Write_Line
("incorrectly formatted Run_Time_Name in system.ads");
Set_Standard_Output;
Fatal := True;
else
Run_Time_Name_On_Target := Name_Enter;
end if;
goto Line_Loop_Continue;
-- See if we have an Executable_Extension
elsif System_Text (P .. P + 45) =
" Executable_Extension : constant String := """
then
P := P + 46;
Name_Len := 0;
while System_Text (P) /= '"'
and then System_Text (P) /= ASCII.LF
loop
Add_Char_To_Name_Buffer (System_Text (P));
P := P + 1;
end loop;
if System_Text (P) /= '"' or else System_Text (P + 1) /= ';' then
Set_Standard_Error;
Write_Line
("incorrectly formatted Executable_Extension in system.ads");
Set_Standard_Output;
Fatal := True;
else
Executable_Extension_On_Target := Name_Enter;
end if;
goto Line_Loop_Continue;
-- Next see if we have a configuration parameter
else
Config_Param_Loop : for K in Targparm_Tags loop
if System_Text (P + 3 .. P + 2 + Targparm_Str (K)'Length) =
Targparm_Str (K).all
then
P := P + 3 + Targparm_Str (K)'Length;
if Targparm_Flags (K) then
Set_Standard_Error;
Write_Line
("fatal error: system.ads is incorrectly formatted");
Write_Str ("duplicate line for parameter: ");
for J in Targparm_Str (K)'Range loop
Write_Char (Targparm_Str (K).all (J));
end loop;
Write_Eol;
Set_Standard_Output;
Fatal := True;
else
Targparm_Flags (K) := True;
end if;
while System_Text (P) /= ':'
or else System_Text (P + 1) /= '='
loop
P := P + 1;
end loop;
P := P + 2;
while System_Text (P) = ' ' loop
P := P + 1;
end loop;
Result := (System_Text (P) = 'T');
case K is
when AAM => AAMP_On_Target := Result;
when ACR => Always_Compatible_Rep_On_Target := Result;
when ASD => Atomic_Sync_Default_On_Target := Result;
when BDC => Backend_Divide_Checks_On_Target := Result;
when BOC => Backend_Overflow_Checks_On_Target := Result;
when CLA => Command_Line_Args_On_Target := Result;
when CLI =>
if Result then
VM_Target := CLI_Target;
Tagged_Type_Expansion := False;
end if;
-- This is wrong, this processing should be done in
-- Gnat1drv.Adjust_Global_Switches. It is not the
-- right level for targparm to know about tagged
-- type extension???
when CRT => Configurable_Run_Time_On_Target := Result;
when D32 => Duration_32_Bits_On_Target := Result;
when DEN => Denorm_On_Target := Result;
when EXS => Exit_Status_Supported_On_Target := Result;
when FEL => Frontend_Layout_On_Target := Result;
when FFO => Fractional_Fixed_Ops_On_Target := Result;
when JVM =>
if Result then
VM_Target := JVM_Target;
Tagged_Type_Expansion := False;
end if;
-- This is wrong, this processing should be done in
-- Gnat1drv.Adjust_Global_Switches. It is not the
-- right level for targparm to know about tagged
-- type extension???
when MOV => Machine_Overflows_On_Target := Result;
when MRN => Machine_Rounds_On_Target := Result;
when PAS => Preallocated_Stacks_On_Target := Result;
when RTX => RTX_RTSS_Kernel_Module_On_Target := Result;
when SAG => Support_Aggregates_On_Target := Result;
when SAP => Support_Atomic_Primitives_On_Target := Result;
when SCA => Support_Composite_Assign_On_Target := Result;
when SCC => Support_Composite_Compare_On_Target := Result;
when SCD => Stack_Check_Default_On_Target := Result;
when SCL => Stack_Check_Limits_On_Target := Result;
when SCP => Stack_Check_Probes_On_Target := Result;
when SLS => Support_Long_Shifts_On_Target := Result;
when SSL => Suppress_Standard_Library_On_Target := Result;
when SNZ => Signed_Zeros_On_Target := Result;
when UAM => Use_Ada_Main_Program_Name_On_Target := Result;
when VMS => OpenVMS_On_Target := Result;
when VXF => VAX_Float_On_Target := Result;
when ZCD => ZCX_By_Default_On_Target := Result;
goto Line_Loop_Continue;
end case;
-- Here we are seeing a parameter we do not understand. We
-- simply ignore this (will happen when an old compiler is
-- used to compile a newer version of GNAT which does not
-- support the parameter).
end if;
end loop Config_Param_Loop;
end if;
-- Here after processing one line of System spec
<>
while System_Text (P) /= CR and then System_Text (P) /= LF loop
P := P + 1;
exit when P >= Source_Last;
end loop;
while System_Text (P) = CR or else System_Text (P) = LF loop
P := P + 1;
exit when P >= Source_Last;
end loop;
if P >= Source_Last then
Set_Standard_Error;
Write_Line ("fatal error, system.ads not formatted correctly");
Write_Line ("unexpected end of file");
Set_Standard_Output;
raise Unrecoverable_Error;
end if;
end loop Line_Loop;
-- Now that OpenVMS_On_Target has been given its definitive value,
-- change the multi-unit index character from '~' to '$' for OpenVMS.
if OpenVMS_On_Target then
Multi_Unit_Index_Character := '$';
end if;
if Fatal then
raise Unrecoverable_Error;
end if;
end Get_Target_Parameters;
------------------------------
-- Set_Profile_Restrictions --
------------------------------
procedure Set_Profile_Restrictions (P : Profile_Name) is
R : Restriction_Flags renames Profile_Info (P).Set;
V : Restriction_Values renames Profile_Info (P).Value;
begin
for J in R'Range loop
if R (J) then
Restrictions_On_Target.Set (J) := True;
if J in All_Parameter_Restrictions then
Restrictions_On_Target.Value (J) := V (J);
end if;
end if;
end loop;
end Set_Profile_Restrictions;
end Targparm;
gprbuild-gpl-2014-src/gnat/gnatvsn.adb 0000644 0000767 0000145 00000010044 12323721731 017213 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T V S N --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2007, 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 3, 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. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- &`#", N);
end if;
end Check_Restriction_No_Use_Of_Attribute;
----------------------------------------
-- Check_Restriction_No_Use_Of_Pragma --
----------------------------------------
procedure Check_Restriction_No_Use_Of_Pragma (N : Node_Id) is
Id : constant Node_Id := Pragma_Identifier (N);
P_Id : constant Pragma_Id := Get_Pragma_Id (Chars (Id));
begin
-- Ignore call if node N is not in the main source unit, since we only
-- give messages for the main unit. This avoids giving messages for
-- aspects that are specified in withed units.
if not In_Extended_Main_Source_Unit (N) then
return;
end if;
-- If nothing set, nothing to check
if not No_Use_Of_Pragma_Set then
return;
end if;
Error_Msg_Sloc := No_Use_Of_Pragma (P_Id);
if Error_Msg_Sloc /= No_Location then
Error_Msg_Node_1 := Id;
Error_Msg_Warn := No_Use_Of_Pragma_Warning (P_Id);
Error_Msg_N
("<*
New_Name := Name_Simple_Barriers;
when Name_Max_Entry_Queue_Depth =>
New_Name := Name_Max_Entry_Queue_Length;
when Name_No_Dynamic_Interrupts =>
New_Name := Name_No_Dynamic_Attachment;
when Name_No_Requeue =>
New_Name := Name_No_Requeue_Statements;
when Name_No_Task_Attributes =>
New_Name := Name_No_Task_Attributes_Package;
-- SPARK is special in that we unconditionally warn
when Name_SPARK =>
Error_Msg_Name_1 := Name_SPARK;
Error_Msg_N ("restriction identifier % is obsolescent??", N);
Error_Msg_Name_1 := Name_SPARK_05;
Error_Msg_N ("|use restriction identifier % instead??", N);
return Name_SPARK_05;
when others =>
return Old_Name;
end case;
-- Output warning if we are warning on obsolescent features for all
-- cases other than SPARK.
if Warn_On_Obsolescent_Feature then
Error_Msg_Name_1 := Old_Name;
Error_Msg_N ("restriction identifier % is obsolescent?j?", N);
Error_Msg_Name_1 := New_Name;
Error_Msg_N ("|use restriction identifier % instead?j?", N);
end if;
return New_Name;
end Process_Restriction_Synonyms;
--------------------------------------
-- Reset_Cunit_Boolean_Restrictions --
--------------------------------------
procedure Reset_Cunit_Boolean_Restrictions is
begin
for J in Cunit_Boolean_Restrictions loop
Restrictions.Set (J) := False;
end loop;
end Reset_Cunit_Boolean_Restrictions;
-----------------------------------------------
-- Restore_Config_Cunit_Boolean_Restrictions --
-----------------------------------------------
procedure Restore_Config_Cunit_Boolean_Restrictions is
begin
Cunit_Boolean_Restrictions_Restore (Config_Cunit_Boolean_Restrictions);
end Restore_Config_Cunit_Boolean_Restrictions;
------------------------
-- Restricted_Profile --
------------------------
function Restricted_Profile return Boolean is
begin
if Restricted_Profile_Cached then
return Restricted_Profile_Result;
else
Restricted_Profile_Result := True;
Restricted_Profile_Cached := True;
declare
R : Restriction_Flags renames Profile_Info (Restricted).Set;
V : Restriction_Values renames Profile_Info (Restricted).Value;
begin
for J in R'Range loop
if R (J)
and then (Restrictions.Set (J) = False
or else Restriction_Warnings (J)
or else
(J in All_Parameter_Restrictions
and then Restrictions.Value (J) > V (J)))
then
Restricted_Profile_Result := False;
exit;
end if;
end loop;
return Restricted_Profile_Result;
end;
end if;
end Restricted_Profile;
------------------------
-- Restriction_Active --
------------------------
function Restriction_Active (R : All_Restrictions) return Boolean is
begin
return Restrictions.Set (R) and then not Restriction_Warnings (R);
end Restriction_Active;
--------------------------------
-- Restriction_Check_Required --
--------------------------------
function Restriction_Check_Required (R : All_Restrictions) return Boolean is
begin
return Restrictions.Set (R);
end Restriction_Check_Required;
---------------------
-- Restriction_Msg --
---------------------
procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is
Msg : String (1 .. 100);
Len : Natural := 0;
procedure Add_Char (C : Character);
-- Append given character to Msg, bumping Len
procedure Add_Str (S : String);
-- Append given string to Msg, bumping Len appropriately
procedure Id_Case (S : String; Quotes : Boolean := True);
-- Given a string S, case it according to current identifier casing,
-- except for SPARK_05 (an acronym) which is set all upper case, and
-- store in Error_Msg_String. Then append `~` to the message buffer
-- to output the string unchanged surrounded in quotes. The quotes
-- are suppressed if Quotes = False.
--------------
-- Add_Char --
--------------
procedure Add_Char (C : Character) is
begin
Len := Len + 1;
Msg (Len) := C;
end Add_Char;
-------------
-- Add_Str --
-------------
procedure Add_Str (S : String) is
begin
Msg (Len + 1 .. Len + S'Length) := S;
Len := Len + S'Length;
end Add_Str;
-------------
-- Id_Case --
-------------
procedure Id_Case (S : String; Quotes : Boolean := True) is
begin
Name_Buffer (1 .. S'Last) := S;
Name_Len := S'Length;
if R = SPARK_05 then
Set_All_Upper_Case;
else
Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
end if;
Error_Msg_Strlen := Name_Len;
Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
if Quotes then
Add_Str ("`~`");
else
Add_Char ('~');
end if;
end Id_Case;
-- Start of processing for Restriction_Msg
begin
-- Set warning message if warning
if Restriction_Warnings (R) then
Add_Str ("?*?");
-- If real violation (not warning), then mark it as non-serious unless
-- it is a violation of No_Finalization in which case we leave it as a
-- serious message, since otherwise we get crashes during attempts to
-- expand stuff that is not properly formed due to assumptions made
-- about no finalization being present.
elsif R /= No_Finalization then
Add_Char ('|');
end if;
Error_Msg_Sloc := Restrictions_Loc (R);
-- Set main message, adding implicit if no source location
if Error_Msg_Sloc > No_Location
or else Error_Msg_Sloc = System_Location
then
Add_Str ("violation of restriction ");
else
Add_Str ("violation of implicit restriction ");
Error_Msg_Sloc := No_Location;
end if;
-- Case of parameterized restriction
if R in All_Parameter_Restrictions then
Add_Char ('`');
Id_Case (Restriction_Id'Image (R), Quotes => False);
Add_Str (" = ^`");
Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R)));
-- Case of boolean restriction
else
Id_Case (Restriction_Id'Image (R));
end if;
-- Case of no secondary profile continuation message
if Restriction_Profile_Name (R) = No_Profile then
if Error_Msg_Sloc /= No_Location then
Add_Char ('#');
end if;
Add_Char ('!');
Error_Msg_N (Msg (1 .. Len), N);
-- Case of secondary profile continuation message present
else
Add_Char ('!');
Error_Msg_N (Msg (1 .. Len), N);
Len := 0;
Add_Char ('\');
-- Set as warning if warning case
if Restriction_Warnings (R) then
Add_Str ("??");
end if;
-- Set main message
Add_Str ("from profile ");
Id_Case (Profile_Name'Image (Restriction_Profile_Name (R)));
-- Add location if we have one
if Error_Msg_Sloc /= No_Location then
Add_Char ('#');
end if;
-- Output unconditional message and we are done
Add_Char ('!');
Error_Msg_N (Msg (1 .. Len), N);
end if;
end Restriction_Msg;
---------------
-- Same_Unit --
---------------
function Same_Unit (U1, U2 : Node_Id) return Boolean is
begin
if Nkind (U1) = N_Identifier and then Nkind (U2) = N_Identifier then
return Chars (U1) = Chars (U2);
elsif Nkind_In (U1, N_Selected_Component, N_Expanded_Name)
and then
Nkind_In (U2, N_Selected_Component, N_Expanded_Name)
then
return Same_Unit (Prefix (U1), Prefix (U2))
and then
Same_Unit (Selector_Name (U1), Selector_Name (U2));
else
return False;
end if;
end Same_Unit;
--------------------------------------------
-- Save_Config_Cunit_Boolean_Restrictions --
--------------------------------------------
procedure Save_Config_Cunit_Boolean_Restrictions is
begin
Config_Cunit_Boolean_Restrictions := Cunit_Boolean_Restrictions_Save;
end Save_Config_Cunit_Boolean_Restrictions;
------------------------------
-- Set_Hidden_Part_In_SPARK --
------------------------------
procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr) is
begin
SPARK_Hides.Increment_Last;
SPARK_Hides.Table (SPARK_Hides.Last).Start := Loc1;
SPARK_Hides.Table (SPARK_Hides.Last).Stop := Loc2;
end Set_Hidden_Part_In_SPARK;
------------------------------
-- Set_Profile_Restrictions --
------------------------------
procedure Set_Profile_Restrictions
(P : Profile_Name;
N : Node_Id;
Warn : Boolean)
is
R : Restriction_Flags renames Profile_Info (P).Set;
V : Restriction_Values renames Profile_Info (P).Value;
begin
for J in R'Range loop
if R (J) then
declare
Already_Restricted : constant Boolean := Restriction_Active (J);
begin
-- Set the restriction
if J in All_Boolean_Restrictions then
Set_Restriction (J, N);
else
Set_Restriction (J, N, V (J));
end if;
-- Record that this came from a Profile[_Warnings] restriction
Restriction_Profile_Name (J) := P;
-- Set warning flag, except that we do not set the warning
-- flag if the restriction was already active and this is
-- the warning case. That avoids a warning overriding a real
-- restriction, which should never happen.
if not (Warn and Already_Restricted) then
Restriction_Warnings (J) := Warn;
end if;
end;
end if;
end loop;
end Set_Profile_Restrictions;
---------------------
-- Set_Restriction --
---------------------
-- Case of Boolean restriction
procedure Set_Restriction
(R : All_Boolean_Restrictions;
N : Node_Id)
is
begin
Restrictions.Set (R) := True;
if Restricted_Profile_Cached and Restricted_Profile_Result then
null;
else
Restricted_Profile_Cached := False;
end if;
-- Set location, but preserve location of system restriction for nice
-- error msg with run time name.
if Restrictions_Loc (R) /= System_Location then
Restrictions_Loc (R) := Sloc (N);
end if;
-- Note restriction came from restriction pragma, not profile
Restriction_Profile_Name (R) := No_Profile;
-- Record the restriction if we are in the main unit, or in the extended
-- main unit. The reason that we test separately for Main_Unit is that
-- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
-- gnat.adc do not appear to be in the extended main source unit (they
-- probably should do ???)
if Current_Sem_Unit = Main_Unit
or else In_Extended_Main_Source_Unit (N)
then
if not Restriction_Warnings (R) then
Main_Restrictions.Set (R) := True;
end if;
end if;
end Set_Restriction;
-- Case of parameter restriction
procedure Set_Restriction
(R : All_Parameter_Restrictions;
N : Node_Id;
V : Integer)
is
begin
if Restricted_Profile_Cached and Restricted_Profile_Result then
null;
else
Restricted_Profile_Cached := False;
end if;
if Restrictions.Set (R) then
if V < Restrictions.Value (R) then
Restrictions.Value (R) := V;
Restrictions_Loc (R) := Sloc (N);
end if;
else
Restrictions.Set (R) := True;
Restrictions.Value (R) := V;
Restrictions_Loc (R) := Sloc (N);
end if;
-- Record the restriction if we are in the main unit, or in the extended
-- main unit. The reason that we test separately for Main_Unit is that
-- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
-- gnat.adc do not appear to be the extended main source unit (they
-- probably should do ???)
if Current_Sem_Unit = Main_Unit
or else In_Extended_Main_Source_Unit (N)
then
if Main_Restrictions.Set (R) then
if V < Main_Restrictions.Value (R) then
Main_Restrictions.Value (R) := V;
end if;
elsif not Restriction_Warnings (R) then
Main_Restrictions.Set (R) := True;
Main_Restrictions.Value (R) := V;
end if;
end if;
-- Note restriction came from restriction pragma, not profile
Restriction_Profile_Name (R) := No_Profile;
end Set_Restriction;
-----------------------------------
-- Set_Restriction_No_Dependence --
-----------------------------------
procedure Set_Restriction_No_Dependence
(Unit : Node_Id;
Warn : Boolean;
Profile : Profile_Name := No_Profile)
is
begin
-- Loop to check for duplicate entry
for J in No_Dependences.First .. No_Dependences.Last loop
-- Case of entry already in table
if Same_Unit (Unit, No_Dependences.Table (J).Unit) then
-- Error has precedence over warning
if not Warn then
No_Dependences.Table (J).Warn := False;
end if;
return;
end if;
end loop;
-- Entry is not currently in table
No_Dependences.Append ((Unit, Warn, Profile));
end Set_Restriction_No_Dependence;
------------------------------------------------
-- Set_Restriction_No_Specification_Of_Aspect --
------------------------------------------------
procedure Set_Restriction_No_Specification_Of_Aspect
(N : Node_Id;
Warning : Boolean)
is
A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N));
begin
No_Specification_Of_Aspects (A_Id) := Sloc (N);
if Warning = False then
No_Specification_Of_Aspect_Warning (A_Id) := False;
end if;
No_Specification_Of_Aspect_Set := True;
end Set_Restriction_No_Specification_Of_Aspect;
-----------------------------------------
-- Set_Restriction_No_Use_Of_Attribute --
-----------------------------------------
procedure Set_Restriction_No_Use_Of_Attribute
(N : Node_Id;
Warning : Boolean)
is
A_Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
begin
No_Use_Of_Attribute_Set := True;
No_Use_Of_Attribute (A_Id) := Sloc (N);
if Warning = False then
No_Use_Of_Attribute_Warning (A_Id) := False;
end if;
end Set_Restriction_No_Use_Of_Attribute;
--------------------------------------
-- Set_Restriction_No_Use_Of_Pragma --
--------------------------------------
procedure Set_Restriction_No_Use_Of_Pragma
(N : Node_Id;
Warning : Boolean)
is
A_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N));
begin
No_Use_Of_Pragma_Set := True;
No_Use_Of_Pragma (A_Id) := Sloc (N);
if Warning = False then
No_Use_Of_Pragma_Warning (A_Id) := False;
end if;
end Set_Restriction_No_Use_Of_Pragma;
-----------------------------
-- Check_SPARK_Restriction --
-----------------------------
procedure Check_SPARK_Restriction
(Msg : String;
N : Node_Id;
Force : Boolean := False)
is
Msg_Issued : Boolean;
Save_Error_Msg_Sloc : Source_Ptr;
Onode : constant Node_Id := Original_Node (N);
begin
-- Output message if Force set
if Force
-- Or if this node comes from source
or else Comes_From_Source (N)
-- Or if this is a range node which rewrites a range attribute and
-- the range attribute comes from source.
or else (Nkind (N) = N_Range
and then Nkind (Onode) = N_Attribute_Reference
and then Attribute_Name (Onode) = Name_Range
and then Comes_From_Source (Onode))
-- Or this is an expression that does not come from source, which is
-- a rewriting of an expression that does come from source.
or else (Nkind (N) in N_Subexpr and then Comes_From_Source (Onode))
then
if Restriction_Check_Required (SPARK_05)
and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
then
return;
end if;
-- Since the call to Restriction_Msg from Check_Restriction may set
-- Error_Msg_Sloc to the location of the pragma restriction, save and
-- restore the previous value of the global variable around the call.
Save_Error_Msg_Sloc := Error_Msg_Sloc;
Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
Error_Msg_Sloc := Save_Error_Msg_Sloc;
if Msg_Issued then
Error_Msg_F ("\\| " & Msg, N);
end if;
end if;
end Check_SPARK_Restriction;
procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is
Msg_Issued : Boolean;
Save_Error_Msg_Sloc : Source_Ptr;
begin
pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\');
if Comes_From_Source (Original_Node (N)) then
if Restriction_Check_Required (SPARK_05)
and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
then
return;
end if;
-- Since the call to Restriction_Msg from Check_Restriction may set
-- Error_Msg_Sloc to the location of the pragma restriction, save and
-- restore the previous value of the global variable around the call.
Save_Error_Msg_Sloc := Error_Msg_Sloc;
Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
Error_Msg_Sloc := Save_Error_Msg_Sloc;
if Msg_Issued then
Error_Msg_F ("\\| " & Msg1, N);
Error_Msg_F (Msg2, N);
end if;
end if;
end Check_SPARK_Restriction;
----------------------------------
-- Suppress_Restriction_Message --
----------------------------------
function Suppress_Restriction_Message (N : Node_Id) return Boolean is
begin
-- We only output messages for the extended main source unit
if In_Extended_Main_Source_Unit (N) then
return False;
-- If loaded by rtsfind, then suppress message
elsif Sloc (N) <= No_Location then
return True;
-- Otherwise suppress message if internal file
else
return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
end if;
end Suppress_Restriction_Message;
---------------------
-- Tasking_Allowed --
---------------------
function Tasking_Allowed return Boolean is
begin
return not Restrictions.Set (No_Tasking)
and then (not Restrictions.Set (Max_Tasks)
or else Restrictions.Value (Max_Tasks) > 0);
end Tasking_Allowed;
end Restrict;
gprbuild-gpl-2014-src/gnat/sem_aux.ads 0000644 0000767 0000145 00000052024 12323721731 017221 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ A U X --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- --
-- --
-- --
-- --
-- --
-- --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Package containing utility procedures used throughout the compiler,
-- and also by ASIS so dependencies are limited to ASIS included packages.
-- Historical note. Many of the routines here were originally in Einfo, but
-- Einfo is supposed to be a relatively low level package dealing with the
-- content of entities in the tree, so this package is used for routines that
-- require more than minimal semantic knowledge.
with Alloc; use Alloc;
with Namet; use Namet;
with Table;
with Types; use Types;
with Sinfo; use Sinfo;
package Sem_Aux is
--------------------------------
-- Obsolescent Warnings Table --
--------------------------------
-- This table records entities for which a pragma Obsolescent with a
-- message argument has been processed.
type OWT_Record is record
Ent : Entity_Id;
-- The entity to which the pragma applies
Msg : String_Id;
-- The string containing the message
end record;
package Obsolescent_Warnings is new Table.Table (
Table_Component_Type => OWT_Record,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => Alloc.Obsolescent_Warnings_Initial,
Table_Increment => Alloc.Obsolescent_Warnings_Increment,
Table_Name => "Obsolescent_Warnings");
procedure Initialize;
-- Called at the start of compilation of each new main source file to
-- initialize the allocation of the Obsolescent_Warnings table. Note that
-- Initialize must not be called if Tree_Read is used.
procedure Tree_Read;
-- Initializes Obsolescent_Warnings table from current tree file using the
-- relevant Table.Tree_Read routine.
procedure Tree_Write;
-- Writes out Obsolescent_Warnings table to current tree file using the
-- relevant Table.Tree_Write routine.
-----------------
-- Subprograms --
-----------------
function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id;
-- The argument Id is a type or subtype entity. If the argument is a
-- subtype then it returns the subtype or type from which the subtype was
-- obtained, otherwise it returns Empty.
function Available_View (Ent : Entity_Id) return Entity_Id;
-- Ent denotes an abstract state or a type that may come from a limited
-- with clause. Return the non-limited view of Ent if there is one or Ent
-- if this is not the case.
function Constant_Value (Ent : Entity_Id) return Node_Id;
-- Ent is a variable, constant, named integer, or named real entity. This
-- call obtains the initialization expression for the entity. Will return
-- Empty for a deferred constant whose full view is not available or
-- in some other cases of internal entities, which cannot be treated as
-- constants from the point of view of constant folding. Empty is also
-- returned for variables with no initialization expression.
function Corresponding_Unsigned_Type (Typ : Entity_Id) return Entity_Id;
-- Typ is a signed integer subtype. This routine returns the standard
-- unsigned type with the same Esize as the implementation base type of
-- Typ, e.g. Long_Integer => Long_Unsigned.
function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id;
-- For any entity, Ent, returns the closest dynamic scope in which the
-- entity is declared or Standard_Standard for library-level entities.
function First_Discriminant (Typ : Entity_Id) return Entity_Id;
-- Typ is a type with discriminants. The discriminants are the first
-- entities declared in the type, so normally this is equivalent to
-- First_Entity. The exception arises for tagged types, where the tag
-- itself is prepended to the front of the entity chain, so the
-- First_Discriminant function steps past the tag if it is present.
function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id;
-- Typ is a type with discriminants. Gives the first discriminant stored
-- in an object of this type. In many cases, these are the same as the
-- normal visible discriminants for the type, but in the case of renamed
-- discriminants, this is not always the case.
--
-- For tagged types, and untagged types which are root types or derived
-- types but which do not rename discriminants in their root type, the
-- stored discriminants are the same as the actual discriminants of the
-- type, and hence this function is the same as First_Discriminant.
--
-- For derived non-tagged types that rename discriminants in the root type
-- this is the first of the discriminants that occur in the root type. To
-- be precise, in this case stored discriminants are entities attached to
-- the entity chain of the derived type which are a copy of the
-- discriminants of the root type. Furthermore their Is_Completely_Hidden
-- flag is set since although they are actually stored in the object, they
-- are not in the set of discriminants that is visible in the type.
--
-- For derived untagged types, the set of stored discriminants are the real
-- discriminants from Gigi's standpoint, i.e. those that will be stored in
-- actual objects of the type.
function First_Subtype (Typ : Entity_Id) return Entity_Id;
-- Applies to all types and subtypes. For types, yields the first subtype
-- of the type. For subtypes, yields the first subtype of the base type of
-- the subtype.
function First_Tag_Component (Typ : Entity_Id) return Entity_Id;
-- Typ must be a tagged record type. This function returns the Entity for
-- the first _Tag field in the record type.
function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind;
-- Op must be an entity with an Ekind of E_Operator. This function returns
-- the Nkind value that would be used to construct a binary operator node
-- referencing this entity. It is an error to call this function if Ekind
-- (Op) /= E_Operator.
function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind;
-- Op must be an entity with an Ekind of E_Operator. This function returns
-- the Nkind value that would be used to construct a unary operator node
-- referencing this entity. It is an error to call this function if Ekind
-- (Op) /= E_Operator.
function Get_Rep_Item
(E : Entity_Id;
Nam : Name_Id;
Check_Parents : Boolean := True) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for an instance of a
-- rep item (pragma, attribute definition clause, or aspect specification)
-- whose name matches the given name Nam. If Check_Parents is False then it
-- only returns rep item that has been directly specified for E (and not
-- inherited from its parents, if any). If one is found, it is returned,
-- otherwise Empty is returned. A special case is that when Nam is
-- Name_Priority, the call will also find Interrupt_Priority.
function Get_Rep_Item
(E : Entity_Id;
Nam1 : Name_Id;
Nam2 : Name_Id;
Check_Parents : Boolean := True) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for an instance of a
-- rep item (pragma, attribute definition clause, or aspect specification)
-- whose name matches one of the given names Nam1 or Nam2. If Check_Parents
-- is False then it only returns rep item that has been directly specified
-- for E (and not inherited from its parents, if any). If one is found, it
-- is returned, otherwise Empty is returned. A special case is that when
-- one of the given names is Name_Priority, the call will also find
-- Interrupt_Priority.
function Get_Rep_Pragma
(E : Entity_Id;
Nam : Name_Id;
Check_Parents : Boolean := True) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for an instance of a
-- representation pragma whose name matches the given name Nam. If
-- Check_Parents is False then it only returns representation pragma that
-- has been directly specified for E (and not inherited from its parents,
-- if any). If one is found and if it is the first rep item in the list
-- that matches Nam, it is returned, otherwise Empty is returned. A special
-- case is that when Nam is Name_Priority, the call will also find
-- Interrupt_Priority.
function Get_Rep_Pragma
(E : Entity_Id;
Nam1 : Name_Id;
Nam2 : Name_Id;
Check_Parents : Boolean := True) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for an instance of a
-- representation pragma whose name matches one of the given names Nam1 or
-- Nam2. If Check_Parents is False then it only returns representation
-- pragma that has been directly specified for E (and not inherited from
-- its parents, if any). If one is found and if it is the first rep item in
-- the list that matches one of the given names, it is returned, otherwise
-- Empty is returned. A special case is that when one of the given names is
-- Name_Priority, the call will also find Interrupt_Priority.
function Has_Rep_Item
(E : Entity_Id;
Nam : Name_Id;
Check_Parents : Boolean := True) return Boolean;
-- Searches the Rep_Item chain for the given entity E, for an instance of a
-- rep item (pragma, attribute definition clause, or aspect specification)
-- with the given name Nam. If Check_Parents is False then it only checks
-- for a rep item that has been directly specified for E (and not inherited
-- from its parents, if any). If found then True is returned, otherwise
-- False indicates that no matching entry was found.
function Has_Rep_Item
(E : Entity_Id;
Nam1 : Name_Id;
Nam2 : Name_Id;
Check_Parents : Boolean := True) return Boolean;
-- Searches the Rep_Item chain for the given entity E, for an instance of a
-- rep item (pragma, attribute definition clause, or aspect specification)
-- with the given names Nam1 or Nam2. If Check_Parents is False then it
-- only checks for a rep item that has been directly specified for E (and
-- not inherited from its parents, if any). If found then True is returned,
-- otherwise False indicates that no matching entry was found.
function Has_Rep_Pragma
(E : Entity_Id;
Nam : Name_Id;
Check_Parents : Boolean := True) return Boolean;
-- Searches the Rep_Item chain for the given entity E, for an instance of a
-- representation pragma with the given name Nam. If Check_Parents is False
-- then it only checks for a representation pragma that has been directly
-- specified for E (and not inherited from its parents, if any). If found
-- and if it is the first rep item in the list that matches Nam then True
-- is returned, otherwise False indicates that no matching entry was found.
function Has_Rep_Pragma
(E : Entity_Id;
Nam1 : Name_Id;
Nam2 : Name_Id;
Check_Parents : Boolean := True) return Boolean;
-- Searches the Rep_Item chain for the given entity E, for an instance of a
-- representation pragma with the given names Nam1 or Nam2. If
-- Check_Parents is False then it only checks for a rep item that has been
-- directly specified for E (and not inherited from its parents, if any).
-- If found and if it is the first rep item in the list that matches one of
-- the given names then True is returned, otherwise False indicates that no
-- matching entry was found.
function Has_External_Tag_Rep_Clause (T : Entity_Id) return Boolean;
-- Defined in tagged types. Set if an External_Tag rep. clause has been
-- given for this type. Use to avoid the generation of the default
-- External_Tag.
--
-- Note: we used to use an entity flag for this purpose, but that was wrong
-- because it was not propagated from the private view to the full view. We
-- could have added that propagation, but it would have been an annoying
-- irregularity compared to other representation aspects, and the cost of
-- looking up the aspect when needed is small.
function Has_Unconstrained_Elements (T : Entity_Id) return Boolean;
-- True if T has discriminants and is unconstrained, or is an array type
-- whose element type Has_Unconstrained_Elements.
function Has_Variant_Part (Typ : Entity_Id) return Boolean;
-- Return True if the first subtype of Typ is a discriminated record type
-- which has a variant part. False otherwise.
function In_Generic_Body (Id : Entity_Id) return Boolean;
-- Determine whether entity Id appears inside a generic body
function Initialization_Suppressed (Typ : Entity_Id) return Boolean;
pragma Inline (Initialization_Suppressed);
-- Returns True if initialization should be suppressed for the given type
-- or subtype. This is true if Suppress_Initialization is set either for
-- the subtype itself, or for the corresponding base type.
function Is_Body (N : Node_Id) return Boolean;
-- Determine whether an arbitrary node denotes a body
function Is_By_Copy_Type (Ent : Entity_Id) return Boolean;
-- Ent is any entity. Returns True if Ent is a type entity where the type
-- is required to be passed by copy, as defined in (RM 6.2(3)).
function Is_By_Reference_Type (Ent : Entity_Id) return Boolean;
-- Ent is any entity. Returns True if Ent is a type entity where the type
-- is required to be passed by reference, as defined in (RM 6.2(4-9)).
function Is_Derived_Type (Ent : Entity_Id) return Boolean;
-- Determines if the given entity Ent is a derived type. Result is always
-- false if argument is not a type.
function Is_Generic_Formal (E : Entity_Id) return Boolean;
-- Determine whether E is a generic formal parameter. In particular this is
-- used to set the visibility of generic formals of a generic package
-- declared with a box or with partial parameterization.
function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean;
-- Ent is any entity. Determines if given entity is an unconstrained array
-- type or subtype, a discriminated record type or subtype with no initial
-- discriminant values or a class wide type or subtype and returns True if
-- so. False for other type entities, or any entities that are not types.
function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean;
-- Implements definition in Ada 2012 RM-7.5 (8.1/3). This differs from the
-- following predicate in that an untagged record with immutably limited
-- components is NOT by itself immutably limited. This matters, e.g. when
-- checking the legality of an access to the current instance.
function Is_Limited_View (Ent : Entity_Id) return Boolean;
-- Ent is any entity. True for a type that is "inherently" limited (i.e.
-- cannot become nonlimited). From the Ada 2005 RM-7.5(8.1/2), "a type with
-- a part that is of a task, protected, or explicitly limited record type".
-- These are the types that are defined as return-by-reference types in Ada
-- 95 (see RM95-6.5(11-16)). In Ada 2005, these are the types that require
-- build-in-place for function calls. Note that build-in-place is allowed
-- for other types, too. This is also used for identifying pure procedures
-- whose calls should not be eliminated (RM 10.2.1(18/2)).
function Is_Limited_Type (Ent : Entity_Id) return Boolean;
-- Ent is any entity. Returns true if Ent is a limited type (limited
-- private type, limited interface type, task type, protected type,
-- composite containing a limited component, or a subtype of any of
-- these types). This older routine overlaps with the previous one, this
-- should be cleaned up???
function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id;
-- Given a subtype Typ, this function finds out the nearest ancestor from
-- which constraints and predicates are inherited. There is no simple link
-- for doing this, consider:
--
-- subtype R is Integer range 1 .. 10;
-- type T is new R;
--
-- In this case the nearest ancestor is R, but the Etype of T'Base will
-- point to R'Base, so we have to go rummaging in the declarations to get
-- this information. It is used for making sure we freeze this before we
-- freeze Typ, and also for retrieving inherited predicate information.
-- For the case of base types or first subtypes, there is no useful entity
-- to return, so Empty is returned.
--
-- Note: this is similar to Ancestor_Subtype except that it also deals
-- with the case of derived types.
function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id;
-- This is similar to Enclosing_Dynamic_Scope except that if Ent is itself
-- a dynamic scope, then it is returned. Otherwise the result is the same
-- as that returned by Enclosing_Dynamic_Scope.
function Next_Tag_Component (Tag : Entity_Id) return Entity_Id;
-- Tag must be an entity representing a _Tag field of a tagged record.
-- The result returned is the next _Tag field in this record, or Empty
-- if this is the last such field.
function Number_Discriminants (Typ : Entity_Id) return Pos;
-- Typ is a type with discriminants, yields number of discriminants in type
function Object_Type_Has_Constrained_Partial_View
(Typ : Entity_Id;
Scop : Entity_Id) return Boolean;
-- Return True if type of object has attribute Has_Constrained_Partial_View
-- set to True; in addition, within a generic body, return True if subtype
-- of the object is a descendant of an untagged generic formal private or
-- derived type, and the subtype is not an unconstrained array subtype
-- (RM 3.3(23.10/3)).
function Ultimate_Alias (Prim : Entity_Id) return Entity_Id;
pragma Inline (Ultimate_Alias);
-- Return the last entity in the chain of aliased entities of Prim. If Prim
-- has no alias return Prim.
function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
-- Unit_Id is the simple name of a program unit, this function returns the
-- corresponding xxx_Declaration node for the entity. Also applies to the
-- body entities for subprograms, tasks and protected units, in which case
-- it returns the subprogram, task or protected body node for it. The unit
-- may be a child unit with any number of ancestors.
function Package_Specification (Pack_Id : Entity_Id) return Node_Id;
-- Given an entity for a package or generic package, return corresponding
-- package specification. Simplifies handling of child units, and better
-- than the old idiom: Specification (Unit_Declaration_Node (Pack_Id)).
end Sem_Aux;
gprbuild-gpl-2014-src/gnat/uname.adb 0000644 0000767 0000145 00000047250 12323721731 016651 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- U N A M E --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, 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 3, 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. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- -gnatmake and Nam is "gcc", the returned value will be a pointer
-- to "-gcc". In the specific case where AAMP_On_Target is set, the
-- name "gcc" is mapped to "gnaamp", and names of the form "gnat*" are
-- mapped to "gnaamp*". This function clobbers Name_Buffer and Name_Len.
-- Also look at any suffix, e.g. gnatmake-4.1 -> "gcc-4.1". Prog is the
-- default name of the current program being executed, e.g. "gnatmake",
-- "gnatlink".
procedure Write_Program_Name;
-- Writes name of program as invoked to the current output (normally
-- standard output).
procedure Fail (S : String);
pragma No_Return (Fail);
-- Outputs error message S preceded by the name of the executing program
-- and exits with E_Fatal. The output goes to standard error, except if
-- special output is in effect (see Output).
function Is_Directory_Separator (C : Character) return Boolean;
-- Returns True if C is a directory separator
function Get_Directory (Name : File_Name_Type) return File_Name_Type;
-- Get the prefix directory name (if any) from Name. The last separator
-- is preserved. Return the normalized current directory if there is no
-- directory part in the name.
function Is_Readonly_Library (File : File_Name_Type) return Boolean;
-- Check if this library file is a read-only file
function Strip_Directory (Name : File_Name_Type) return File_Name_Type;
-- Strips the prefix directory name (if any) from Name. Returns the
-- stripped name. Name cannot end with a directory separator.
function Strip_Suffix (Name : File_Name_Type) return File_Name_Type;
-- Strips the suffix (the last '.' and whatever comes after it) from Name.
-- Returns the stripped name.
function Executable_Name
(Name : File_Name_Type;
Only_If_No_Suffix : Boolean := False) return File_Name_Type;
-- Given a file name it adds the appropriate suffix at the end so that
-- it becomes the name of the executable on the system at end. For
-- instance under DOS it adds the ".exe" suffix, whereas under UNIX no
-- suffix is added.
function Executable_Name
(Name : String;
Only_If_No_Suffix : Boolean := False) return String;
-- Same as above, with String parameters
function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type;
-- Returns the time stamp of file Name. Name should include relative path
-- information in order to locate it. If the source file cannot be opened,
-- or Name = No_File, and all blank time stamp is returned (this is not an
-- error situation).
function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type;
-- Same as above for a path name
type String_Access_List is array (Positive range <>) of String_Access;
-- Dereferenced type used to return a list of file specs in
-- To_Canonical_File_List.
type String_Access_List_Access is access all String_Access_List;
-- Type used to return a String_Access_List without dragging in secondary
-- stack.
function To_Canonical_File_List
(Wildcard_Host_File : String;
Only_Dirs : Boolean) return String_Access_List_Access;
-- Expand a wildcard host syntax file or directory specification (e.g. on
-- a VMS host, any file or directory spec that contains: "*", or "%", or
-- "...") and return a list of valid Unix syntax file or directory specs.
-- If Only_Dirs is True, then only return directories.
function To_Canonical_Dir_Spec
(Host_Dir : String;
Prefix_Style : Boolean) return String_Access;
-- Convert a host syntax directory specification (e.g. on a VMS host:
-- "SYS$DEVICE:[DIR]") to canonical (Unix) syntax (e.g. "/sys$device/dir").
-- If Prefix_Style then make it a valid file specification prefix. A file
-- specification prefix is a directory specification that can be appended
-- with a simple file specification to yield a valid absolute or relative
-- path to a file. On a conversion to Unix syntax this simply means the
-- spec has a trailing slash ("/").
function To_Canonical_File_Spec
(Host_File : String) return String_Access;
-- Convert a host syntax file specification (e.g. on a VMS host:
-- "SYS$DEVICE:[DIR]FILE.EXT;69 to canonical (Unix) syntax (e.g.
-- "/sys$device/dir/file.ext.69").
function To_Canonical_Path_Spec
(Host_Path : String) return String_Access;
-- Convert a host syntax Path specification (e.g. on a VMS host:
-- "SYS$DEVICE:[BAR],DISK$USER:[FOO] to canonical (Unix) syntax (e.g.
-- "/sys$device/foo:disk$user/foo").
function To_Host_Dir_Spec
(Canonical_Dir : String;
Prefix_Style : Boolean) return String_Access;
-- Convert a canonical syntax directory specification to host syntax. The
-- Prefix_Style flag is currently ignored but should be set to False.
-- Note that the caller must free result.
function To_Host_File_Spec
(Canonical_File : String) return String_Access;
-- Convert a canonical syntax file specification to host syntax
function Relocate_Path
(Prefix : String;
Path : String) return String_Ptr;
-- Given an absolute path and a prefix, if Path starts with Prefix,
-- replace the Prefix substring with the root installation directory.
-- By default, try to compute the root installation directory by looking
-- at the executable name as it was typed on the command line and, if
-- needed, use the PATH environment variable. If the above computation
-- fails, return Path. This function assumes Prefix'First = Path'First.
function Shared_Lib (Name : String) return String;
-- Returns the runtime shared library in the form -l- where
-- version is the GNAT runtime library option for the platform. For example
-- this routine called with Name set to "gnat" will return "-lgnat-5.02"
-- on UNIX and Windows and -lgnat_5_02 on VMS.
---------------------
-- File attributes --
---------------------
-- The following subprograms offer services similar to those found in
-- System.OS_Lib, but with the ability to extra multiple information from
-- a single system call, depending on the system. This can result in fewer
-- system calls when reused.
-- In all these subprograms, the requested value is either read from the
-- File_Attributes parameter (resulting in no system call), or computed
-- from the disk and then cached in the File_Attributes parameter (possibly
-- along with other values).
type File_Attributes is private;
Unknown_Attributes : constant File_Attributes;
-- A cache for various attributes for a file (length, accessibility,...)
-- This must be initialized to Unknown_Attributes prior to the first call.
function Is_Directory
(Name : C_File_Name;
Attr : access File_Attributes) return Boolean;
function Is_Regular_File
(Name : C_File_Name;
Attr : access File_Attributes) return Boolean;
function Is_Symbolic_Link
(Name : C_File_Name;
Attr : access File_Attributes) return Boolean;
-- Return the type of the file,
function File_Length
(Name : C_File_Name;
Attr : access File_Attributes) return Long_Integer;
-- Return the length (number of bytes) of the file
function File_Time_Stamp
(Name : C_File_Name;
Attr : access File_Attributes) return OS_Time;
function File_Time_Stamp
(Name : Path_Name_Type;
Attr : access File_Attributes) return Time_Stamp_Type;
-- Return the time stamp of the file
function Is_Readable_File
(Name : C_File_Name;
Attr : access File_Attributes) return Boolean;
function Is_Executable_File
(Name : C_File_Name;
Attr : access File_Attributes) return Boolean;
function Is_Writable_File
(Name : C_File_Name;
Attr : access File_Attributes) return Boolean;
-- Return the access rights for the file
-------------------------
-- Search Dir Routines --
-------------------------
function Include_Dir_Default_Prefix return String;
-- Return the directory of the run-time library sources, as modified
-- by update_path.
function Object_Dir_Default_Prefix return String;
-- Return the directory of the run-time library ALI and object files, as
-- modified by update_path.
procedure Add_Default_Search_Dirs;
-- This routine adds the default search dirs indicated by the environment
-- variables and sdefault package, as well as the library search dirs set
-- by option -gnateO for GNAT2WHY.
procedure Add_Lib_Search_Dir (Dir : String);
-- Add Dir at the end of the library file search path
procedure Add_Src_Search_Dir (Dir : String);
-- Add Dir at the end of the source file search path
procedure Get_Next_Dir_In_Path_Init
(Search_Path : String_Access);
function Get_Next_Dir_In_Path
(Search_Path : String_Access) return String_Access;
-- These subprograms are used to parse out the directory names in a search
-- path specified by a Search_Path argument. The procedure initializes an
-- internal pointer to point to the initial directory name, and calls to
-- the function return successive directory names, with a null pointer
-- marking the end of the list.
type Search_File_Type is (Include, Objects);
procedure Add_Search_Dirs
(Search_Path : String_Ptr;
Path_Type : Search_File_Type);
-- These procedure adds all the search directories that are in Search_Path
-- in the proper file search path (library or source)
function Get_Primary_Src_Search_Directory return String_Ptr;
-- Retrieved the primary directory (directory containing the main source
-- file for Gnatmake.
function Nb_Dir_In_Src_Search_Path return Natural;
function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr;
-- Functions to access the directory names in the source search path
function Nb_Dir_In_Obj_Search_Path return Natural;
function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr;
-- Functions to access the directory names in the Object search path
Include_Search_File : constant String_Access :=
new String'("ada_source_path");
Objects_Search_File : constant String_Access :=
new String'("ada_object_path");
-- Names of the files containing the default include or objects search
-- directories. These files, located in Sdefault.Search_Dir_Prefix, do
-- not necessarily exist.
Exec_Name : String_Ptr;
-- Executable name as typed by the user (used to compute the
-- executable prefix).
function Read_Default_Search_Dirs
(Search_Dir_Prefix : String_Access;
Search_File : String_Access;
Search_Dir_Default_Name : String_Access) return String_Access;
-- Read and return the default search directories from the file located
-- in Search_Dir_Prefix (as modified by update_path) and named Search_File.
-- If no such file exists or an error occurs then instead return the
-- Search_Dir_Default_Name (as modified by update_path).
function Get_RTS_Search_Dir
(Search_Dir : String;
File_Type : Search_File_Type) return String_Ptr;
-- This function retrieves the paths to the search (resp. lib) dirs and
-- return them. The search dir can be absolute or relative. If the search
-- dir contains Include_Search_File (resp. Object_Search_File), then this
-- function reads and returns the default search directories from the file.
-- Otherwise, if the directory is absolute, it will try to find 'adalib'
-- (resp. 'adainclude'). If found, null is returned. If the directory is
-- relative, the following directories for the directories 'adalib' and
-- 'adainclude' will be scanned:
--
-- - current directory (from which the tool has been spawned)
-- - $GNAT_ROOT/gcc/gcc-lib/$targ/$vers/
-- - $GNAT_ROOT/gcc/gcc-lib/$targ/$vers/rts-
--
-- The scan will stop as soon as the directory being searched for (adalib
-- or adainclude) is found. If the scan fails, null is returned.
-----------------------
-- Source File Input --
-----------------------
-- Source file input routines are used by the compiler to read the main
-- source files and the subsidiary source files (e.g. with'ed units), and
-- also by the binder to check presence/time stamps of sources.
procedure Read_Source_File
(N : File_Name_Type;
Lo : Source_Ptr;
Hi : out Source_Ptr;
Src : out Source_Buffer_Ptr;
T : File_Type := Source);
-- Allocates a Source_Buffer of appropriate length and then reads the
-- entire contents of the source file N into the buffer. The address of
-- the allocated buffer is returned in Src.
--
-- Each line of text is terminated by one of the sequences:
--
-- CR
-- CR/LF
-- LF
-- The source is terminated by an EOF (16#1A#) character, which is the last
-- character of the returned source buffer (note that any EOF characters in
-- positions other than the last source character are treated as blanks).
--
-- The logical lower bound of the source buffer is the input value of Lo,
-- and on exit Hi is set to the logical upper bound of the source buffer.
-- Note that the returned value in Src points to an array with a physical
-- lower bound of zero. This virtual origin addressing approach means that
-- a constrained array pointer can be used with a low bound of zero which
-- results in more efficient code.
--
-- If the given file cannot be opened, then the action depends on whether
-- this file is the current main unit (i.e. its name matches the name
-- returned by the most recent call to Next_Main_Source). If so, then the
-- failure to find the file is a fatal error, an error message is output,
-- and program execution is terminated. Otherwise (for the case of a
-- subsidiary source loaded directly or indirectly using with), a file
-- not found condition causes null to be set as the result value.
--
-- Note that the name passed to this function is the simple file name,
-- without any directory information. The implementation is responsible
-- for searching for the file in the appropriate directories.
--
-- Note the special case that if the file name is gnat.adc, then the search
-- for the file is done ONLY in the directory corresponding to the current
-- compilation environment, i.e. in the same directory where the ali and
-- object files will be written.
function Full_Source_Name return File_Name_Type;
function Current_Source_File_Stamp return Time_Stamp_Type;
-- Returns the full name/time stamp of the source file most recently read
-- using Read_Source_File. Calling this routine entails no source file
-- directory lookup penalty.
procedure Full_Source_Name
(N : File_Name_Type;
Full_File : out File_Name_Type;
Attr : access File_Attributes);
function Full_Source_Name (N : File_Name_Type) return File_Name_Type;
function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type;
-- Returns the full name/time stamp of the source file whose simple name
-- is N which should not include path information. Note that if the file
-- cannot be located No_File is returned for the first routine and an all
-- blank time stamp is returned for the second (this is not an error
-- situation). The full name includes appropriate directory information.
-- The source file directory lookup penalty is incurred every single time
-- the routines are called unless you have previously called
-- Source_File_Data (Cache => True). See below.
--
-- The procedural version also returns some file attributes for the ALI
-- file (to save on system calls later on).
function Current_File_Index return Int;
-- Return the index in its source file of the current main unit
function Matching_Full_Source_Name
(N : File_Name_Type;
T : Time_Stamp_Type) return File_Name_Type;
-- Same semantics than Full_Source_Name but will search on the source path
-- until a source file with time stamp matching T is found. If none is
-- found returns No_File.
procedure Source_File_Data (Cache : Boolean);
-- By default source file data (full source file name and time stamp)
-- are looked up every time a call to Full_Source_Name (N) or
-- Source_File_Stamp (N) is made. This may be undesirable in certain
-- applications as this is uselessly slow if source file data does not
-- change during program execution. When this procedure is called with
-- Cache => True access to source file data does not incur a penalty if
-- this data was previously retrieved.
procedure Dump_Source_File_Names;
-- Prints out the names of all source files that have been read by
-- Read_Source_File, except those that come from the run-time library
-- (i.e. Include_Dir_Default_Prefix). The text is sent to whatever Output
-- is currently using (e.g. standard output or standard error).
-------------------------------------------
-- Representation of Library Information --
-------------------------------------------
-- Associated with each compiled source file is library information, a
-- string of bytes whose exact format is described in the body of Lib.Writ.
-- Compiling a source file generates this library information for the
-- compiled unit, and access the library information for units that were
-- compiled previously on which the unit being compiled depends.
-- How this information is stored is up to the implementation of this
-- package. At the interface level, this information is simply associated
-- with its corresponding source.
-- Several different implementations are possible:
-- 1. The information could be directly associated with the source file,
-- e.g. placed in a resource fork of this file on the Mac, or on
-- MS-DOS, written to the source file after the end of file mark.
-- 2. The information could be written into the generated object module
-- if the system supports the inclusion of arbitrary informational
-- byte streams into object files. In this case there must be a naming
-- convention that allows object files to be located given the name of
-- the corresponding source file.
-- 3. The information could be written to a separate file, whose name is
-- related to the name of the source file by a fixed convention.
-- Which of these three methods is chosen depends on the constraints of the
-- host operating system. The interface described here is independent of
-- which of these approaches is used. Currently all versions of GNAT use
-- the third approach with a file name of xxx.ali where xxx is the source
-- file name.
-------------------------------
-- Library Information Input --
-------------------------------
-- These subprograms are used by the binder to read library information
-- files, see section above for representation of these files.
function Read_Library_Info
(Lib_File : File_Name_Type;
Fatal_Err : Boolean := False) return Text_Buffer_Ptr;
-- Allocates a Text_Buffer of appropriate length and reads in the entire
-- source of the library information from the library information file
-- whose name is given by the parameter Name.
--
-- See description of Read_Source_File for details on the format of the
-- returned text buffer (the format is identical). The lower bound of
-- the Text_Buffer is always zero
--
-- If the specified file cannot be opened, then the action depends on
-- Fatal_Err. If Fatal_Err is True, an error message is given and the
-- compilation is abandoned. Otherwise if Fatal_Err is False, then null
-- is returned. Note that the Lib_File is a simple name which does not
-- include any directory information. The implementation is responsible
-- for searching for the file in appropriate directories.
--
-- If Opt.Check_Object_Consistency is set to True then this routine checks
-- whether the object file corresponding to the Lib_File is consistent with
-- it. The object file is inconsistent if the object does not exist or if
-- it has an older time stamp than Lib_File. This check is not performed
-- when the Lib_File is "locked" (i.e. read/only) because in this case the
-- object file may be buried in a library. In case of inconsistencies
-- Read_Library_Info behaves as if it did not find Lib_File (namely if
-- Fatal_Err is False, null is returned).
function Read_Library_Info_From_Full
(Full_Lib_File : File_Name_Type;
Lib_File_Attr : access File_Attributes;
Fatal_Err : Boolean := False) return Text_Buffer_Ptr;
-- Same as Read_Library_Info, except Full_Lib_File must contains the full
-- path to the library file (instead of having Read_Library_Info recompute
-- it).
-- Lib_File_Attr should be an initialized set of attributes for the
-- library file (it can be initialized to Unknown_Attributes, but in
-- general will have been initialized by a previous call to Find_File).
function Full_Library_Info_Name return File_Name_Type;
function Full_Object_File_Name return File_Name_Type;
-- Returns the full name of the library/object file most recently read
-- using Read_Library_Info, including appropriate directory information.
-- Calling this routine entails no library file directory lookup
-- penalty. Note that the object file corresponding to a library file
-- is not actually read. Its time stamp is affected when the flag
-- Opt.Check_Object_Consistency is set.
function Current_Library_File_Stamp return Time_Stamp_Type;
function Current_Object_File_Stamp return Time_Stamp_Type;
-- The time stamps of the files returned by the previous two routines.
-- It is an error to call Current_Object_File_Stamp if
-- Opt.Check_Object_Consistency is set to False.
procedure Full_Lib_File_Name
(N : File_Name_Type;
Lib_File : out File_Name_Type;
Attr : out File_Attributes);
function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type;
-- Returns the full name of library file N. N should not include
-- path information. Note that if the file cannot be located No_File is
-- returned for the first routine and an all blank time stamp is returned
-- for the second (this is not an error situation). The full name includes
-- the appropriate directory information. The library file directory lookup
-- penalty is incurred every single time this routine is called.
-- The procedural version also returns some file attributes for the ALI
-- file (to save on system calls later on).
function Lib_File_Name
(Source_File : File_Name_Type;
Munit_Index : Nat := 0) return File_Name_Type;
-- Given the name of a source file, returns the name of the corresponding
-- library information file. This may be the name of the object file or of
-- a separate file used to store the library information. In the current
-- implementation, a separate file (the ALI file) is always used. In either
-- case the returned result is suitable for calling Read_Library_Info. The
-- Munit_Index is the unit index in multiple unit per file mode, or zero in
-- normal single unit per file mode (used to add ~nnn suffix). Note: this
-- subprogram is in this section because it is used by the compiler to
-- determine the proper library information names to be placed in the
-- generated library information file.
-----------------
-- Termination --
-----------------
Current_Exit_Status : Integer := 0;
-- Exit status that is set with procedure OS_Exit_Through_Exception below
-- and can be used in exception handler for Types.Terminate_Program to call
-- Set_Exit_Status as the last action of the program.
procedure OS_Exit_Through_Exception (Status : Integer);
pragma No_Return (OS_Exit_Through_Exception);
-- Set the Current_Exit_Status, then raise Types.Terminate_Program
type Exit_Code_Type is (
E_Success, -- No warnings or errors
E_Warnings, -- Compiler warnings generated
E_No_Code, -- No code generated
E_No_Compile, -- Compilation not needed (smart recompilation)
E_Errors, -- Compiler error messages generated
E_Fatal, -- Fatal (serious) error, e.g. source file not found
E_Abort); -- Internally detected compiler error
procedure Exit_Program (Exit_Code : Exit_Code_Type);
pragma No_Return (Exit_Program);
-- A call to Exit_Program terminates execution with the given status. A
-- status of zero indicates normal completion, a non-zero status indicates
-- abnormal termination.
-------------------------
-- Command Line Access --
-------------------------
-- Direct interface to command line parameters. (We don't want to use
-- the predefined command line package because it defines functions
-- returning string)
function Arg_Count return Natural;
pragma Import (C, Arg_Count, "__gnat_arg_count");
-- Get number of arguments (note: optional globbing may be enabled)
procedure Fill_Arg (A : System.Address; Arg_Num : Integer);
pragma Import (C, Fill_Arg, "__gnat_fill_arg");
-- Store one argument
function Len_Arg (Arg_Num : Integer) return Integer;
pragma Import (C, Len_Arg, "__gnat_len_arg");
-- Get length of argument
ALI_Default_Suffix : constant String_Ptr := new String'("ali");
ALI_Suffix : String_Ptr := ALI_Default_Suffix;
-- The suffixes used for the ALI files
function Prep_Suffix return String;
-- The suffix used for pre-processed files
private
Current_Main : File_Name_Type := No_File;
-- Used to save a simple file name between calls to Next_Main_Source and
-- Read_Source_File. If the file name argument to Read_Source_File is
-- No_File, that indicates that the file whose name was returned by the
-- last call to Next_Main_Source (and stored here) is to be read.
Target_Object_Suffix : constant String := Get_Target_Object_Suffix.all;
-- The suffix used for the target object files
Output_FD : File_Descriptor;
-- File descriptor for current library info, list, tree, or binder output
Output_File_Name : File_Name_Type;
-- File_Name_Type for name of open file whose FD is in Output_FD, the name
-- stored does not include the trailing NUL character.
Argument_Count : constant Integer := Arg_Count - 1;
-- Number of arguments (excluding program name)
type File_Name_Array is array (Int range <>) of String_Ptr;
type File_Name_Array_Ptr is access File_Name_Array;
File_Names : File_Name_Array_Ptr :=
new File_Name_Array (1 .. Int (Argument_Count) + 2);
-- As arguments are scanned, file names are stored in this array. The
-- strings do not have terminating NUL files. The array is extensible,
-- because when using project files, there may be more files than
-- arguments on the command line.
type File_Index_Array is array (Int range <>) of Int;
type File_Index_Array_Ptr is access File_Index_Array;
File_Indexes : File_Index_Array_Ptr :=
new File_Index_Array (1 .. Int (Argument_Count) + 2);
Current_File_Name_Index : Int := 0;
-- The index in File_Names of the last file opened by Next_Main_Source
-- or Next_Main_Lib_File. The value 0 indicates that no files have been
-- opened yet.
procedure Create_File_And_Check
(Fdesc : out File_Descriptor;
Fmode : Mode);
-- Create file whose name (NUL terminated) is in Name_Buffer (with the
-- length in Name_Len), and place the resulting descriptor in Fdesc. Issue
-- message and exit with fatal error if file cannot be created. The Fmode
-- parameter is set to either Text or Binary (for details see description
-- of System.OS_Lib.Create_File).
type Program_Type is (Compiler, Binder, Make, Gnatls, Unspecified);
-- Program currently running
procedure Set_Program (P : Program_Type);
-- Indicates to the body of Osint the program currently running. This
-- procedure is called by the child packages of Osint. A check is made
-- that this procedure is not called more than once.
function More_Files return Boolean;
-- Implements More_Source_Files and More_Lib_Files
function Next_Main_File return File_Name_Type;
-- Implements Next_Main_Source and Next_Main_Lib_File
function Object_File_Name (N : File_Name_Type) return File_Name_Type;
-- Constructs the name of the object file corresponding to library file N.
-- If N is a full file name than the returned file name will also be a full
-- file name. Note that no lookup in the library file directories is done
-- for this file. This routine merely constructs the name.
procedure Write_Info (Info : String);
-- Implementation of Write_Binder_Info, Write_Debug_Info and
-- Write_Library_Info (identical)
procedure Write_With_Check (A : Address; N : Integer);
-- Writes N bytes from buffer starting at address A to file whose FD is
-- stored in Output_FD, and whose file name is stored as a File_Name_Type
-- in Output_File_Name. A check is made for disk full, and if this is
-- detected, the file being written is deleted, and a fatal error is
-- signalled.
File_Attributes_Size : constant Natural := 32;
-- This should be big enough to fit a "struct file_attributes" on any
-- system. It doesn't cause any malfunction if it is too big (which avoids
-- the need for either mapping the struct exactly or importing the sizeof
-- from C, which would result in dynamic code). However, it does waste
-- space (e.g. when a component of this type appears in a record, if it is
-- unnecessarily large). Note: for runtime units, use System.OS_Constants.
-- SIZEOF_struct_file_attributes instead, which has the exact value.
type File_Attributes is
array (1 .. File_Attributes_Size)
of System.Storage_Elements.Storage_Element;
for File_Attributes'Alignment use Standard'Maximum_Alignment;
Unknown_Attributes : constant File_Attributes := (others => 0);
-- Will be initialized properly at elaboration (for efficiency later on,
-- avoid function calls every time we want to reset the attributes).
end Osint;
gprbuild-gpl-2014-src/gnat/binderr.ads 0000644 0000767 0000145 00000015107 12323721731 017206 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- B I N D E R R --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package contains the routines to output error messages for the binder
-- and also the routines for handling fatal error conditions in the binder.
with Namet; use Namet;
with Types; use Types;
package Binderr is
Errors_Detected : Int;
-- Number of errors detected so far
Warnings_Detected : Int;
-- Number of warnings detected
Info_Prefix_Suppress : Boolean := False;
-- If set to True, the normal "info: " header before messages generated
-- by Error_Msg_Info will be omitted.
---------------------------------------------------------
-- Error Message Text and Message Insertion Characters --
---------------------------------------------------------
-- Error message text strings are composed of letters, digits and the
-- special characters space, comma, period, colon and semicolon,
-- apostrophe and parentheses. Special insertion characters can also
-- appear which cause the error message circuit to modify the given
-- string as follows:
-- Insertion character { (Left brace: insert file name from Names table)
-- The character { is replaced by the text for the file name specified
-- by the File_Name_Type value stored in Error_Msg_File_1. The name is
-- always enclosed in quotes. A second { may appear in a single message
-- in which case it is similarly replaced by the name which is
-- specified by the File_Name_Type value stored in Error_Msg_File_2.
-- Insertion character $ (Dollar: insert unit name from Names table)
-- The character & is replaced by the text for the unit name specified
-- by the Name_Id value stored in Error_Msg_Unit_1. The name is always
-- enclosed in quotes. A second $ may appear in a single message in
-- which case it is similarly replaced by the name which is specified
-- by the Name_Id value stored in Error_Msg_Unit_2.
-- Insertion character # (Pound: insert non-negative number in decimal)
-- The character # is replaced by the contents of Error_Msg_Nat_1
-- converted into an unsigned decimal string. A second # may appear
-- in a single message, in which case it is similarly replaced by
-- the value stored in Error_Msg_Nat_2.
-- Insertion character ? (Question mark: warning message)
-- The character ?, which must be the first character in the message
-- string, signals a warning message instead of an error message.
-----------------------------------------------------
-- Global Values Used for Error Message Insertions --
-----------------------------------------------------
-- The following global variables are essentially additional parameters
-- passed to the error message routine for insertion sequences described
-- above. The reason these are passed globally is that the insertion
-- mechanism is essentially an untyped one in which the appropriate
-- variables are set depending on the specific insertion characters used.
Error_Msg_Name_1 : Name_Id;
-- Name_Id value for % insertion characters in message
Error_Msg_File_1 : File_Name_Type;
Error_Msg_File_2 : File_Name_Type;
-- Name_Id values for { insertion characters in message
Error_Msg_Unit_1 : Unit_Name_Type;
Error_Msg_Unit_2 : Unit_Name_Type;
-- Name_Id values for $ insertion characters in message
Error_Msg_Nat_1 : Nat;
Error_Msg_Nat_2 : Nat;
-- Integer values for # insertion characters in message
------------------------------
-- Error Output Subprograms --
------------------------------
procedure Error_Msg (Msg : String);
-- Output specified error message to standard error or standard output
-- as governed by the brief and verbose switches, and update error
-- counts appropriately
procedure Error_Msg_Info (Msg : String);
-- Output information line. Indentical in effect to Error_Msg, except
-- that the prefix is info: instead of error: and the error count is
-- not incremented. The prefix may be suppressed by setting the global
-- variable Info_Prefix_Suppress to True.
procedure Error_Msg_Output (Msg : String; Info : Boolean);
-- Output given message, with insertions, to current message output file.
-- The second argument is True for an info message, false for a normal
-- warning or error message. Normally this is not called directly, but
-- rather only by Error_Msg or Error_Msg_Info. It is called directly
-- when the caller must control whether the output goes to stderr or
-- stdout (Error_Msg_Output always goes to the current output file).
procedure Finalize_Binderr;
-- Finalize error output for one file
procedure Initialize_Binderr;
-- Initialize error output for one file
end Binderr;
gprbuild-gpl-2014-src/gnat/prj-part.ads 0000644 0000767 0000145 00000010231 12323721731 017311 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . P A R T --
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2013, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Implements the parsing of project files into a tree
with Prj.Tree; use Prj.Tree;
package Prj.Part is
type Errout_Mode is
(Always_Finalize,
Finalize_If_Error,
Never_Finalize);
-- Whether Parse should call Errout.Finalize (which prints the error
-- messages on stdout). When Never_Finalize is used, Errout is not reset
-- either at the beginning of Parse.
procedure Parse
(In_Tree : Project_Node_Tree_Ref;
Project : out Project_Node_Id;
Project_File_Name : String;
Errout_Handling : Errout_Mode := Always_Finalize;
Packages_To_Check : String_List_Access;
Store_Comments : Boolean := False;
Current_Directory : String := "";
Is_Config_File : Boolean;
Env : in out Prj.Tree.Environment;
Target_Name : String := "";
Implicit_Project : Boolean := False);
-- Parse project file and all its imported project files and create a tree.
-- Return the node for the project (or Empty_Node if parsing failed). If
-- Always_Errout_Finalize is True, Errout.Finalize is called in all cases,
-- Otherwise, Errout.Finalize is only called if there are errors (but not
-- if there are only warnings). Packages_To_Check indicates the packages
-- where any unknown attribute produces an error. For other packages, an
-- unknown attribute produces a warning. When Store_Comments is True,
-- comments are stored in the parse tree.
--
-- Current_Directory is used for optimization purposes only, avoiding extra
-- system calls.
--
-- Is_Config_File should be set to True if the project represents a config
-- file (.cgpr) since some specific checks apply.
--
-- Target_Name will be used to initialize the default project path, unless
-- In_Tree.Project_Path has already been initialized (which is the
-- recommended use).
--
-- If Implicit_Project is True, the main project file being parsed is
-- deemed to be in the current working directory, even if it is not the
-- case. Implicit_Project is set to True when a tool such as gprbuild is
-- invoked without a project file and is using an implicit project file
-- that is virtually in the current working directory, but is physically
-- in another directory.
end Prj.Part;
gprbuild-gpl-2014-src/gnat/mlib-fil.ads 0000644 0000767 0000145 00000005156 12323721731 017257 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M L I B . F I L --
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2007, AdaCore --
-- --
-- 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides a set of routines to deal with file extensions
package MLib.Fil is
function Ext_To
(Filename : String;
New_Ext : String := "") return String;
-- Return Filename with the extension changed to New_Ext
function Append_To
(Filename : String;
Ext : String) return String;
-- Return Filename with the extension Ext
function Get_Ext (Filename : String) return String;
-- Return extension of filename
function Is_Archive (Filename : String) return Boolean;
-- Test if filename is an archive
function Is_C (Filename : String) return Boolean;
-- Test if Filename is a C file
function Is_Obj (Filename : String) return Boolean;
-- Test if Filename is an object file
end MLib.Fil;
gprbuild-gpl-2014-src/gnat/prj-nmsc.ads 0000644 0000767 0000145 00000006403 12323721731 017311 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . N M S C --
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2011, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Find source dirs and source files for a project
with Prj.Tree;
private package Prj.Nmsc is
procedure Process_Naming_Scheme
(Tree : Project_Tree_Ref;
Root_Project : Project_Id;
Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
Flags : Processing_Flags);
-- Perform consistency and semantic checks on all the projects in the tree.
-- This procedure interprets the various case statements in the project
-- based on the current external references. After checking the validity of
-- the naming scheme, it searches for all the source files of the project.
-- The result of this procedure is a filled-in data structure for
-- Project_Id which contains all the information about the project. This
-- information is only valid while the external references are preserved.
procedure Process_Aggregated_Projects
(Tree : Project_Tree_Ref;
Project : Project_Id;
Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
Flags : Processing_Flags);
-- Assuming Project is an aggregate project, find out (based on the
-- current external references) what are the projects it aggregates.
-- This has to be done in phase 1 of the processing, so that we know the
-- full list of languages required for root_project and its aggregated
-- projects. As a result, it cannot be done as part of
-- Process_Naming_Scheme.
end Prj.Nmsc;
gprbuild-gpl-2014-src/gnat/einfo.ads 0000644 0000767 0000145 00001600044 12323721731 016662 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E I N F O --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, 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 3, 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. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- AM and it
-- services anonymous access-to-controlled types with an undetermined
-- lifetime.
-- Has_Atomic_Components (Flag86) [implementation base type only]
-- Defined in all types and objects. Set only for an array type or
-- an array object if a valid pragma Atomic_Components applies to the
-- type or object. Note that in the case of an object, this flag is
-- only set on the object if there was an explicit pragma for the
-- object. In other words, the proper test for whether an object has
-- atomic components is to see if either the object or its base type
-- has this flag set. Note that in the case of a type, the pragma will
-- be chained to the rep item chain of the first subtype in the usual
-- manner.
-- Has_Attach_Handler (synthesized)
-- Applies to record types that are constructed by the expander to
-- represent protected types. Returns True if there is at least one
-- Attach_Handler pragma in the corresponding specification.
-- Has_Biased_Representation (Flag139)
-- Defined in discrete types (where it applies to the type'size value),
-- and to objects (both stand-alone and components), where it applies to
-- the size of the object from a size or record component clause. In
-- all cases it indicates that the size in question is smaller than
-- would normally be required, but that the size requirement can be
-- satisfied by using a biased representation, in which stored values
-- have the low bound (Expr_Value (Type_Low_Bound (T)) subtracted to
-- reduce the required size. For example, a type with a range of 1..2
-- takes one bit, using 0 to represent 1 and 1 to represent 2.
--
-- Note that in the object and component cases, the flag is only set if
-- the type is unbiased, but the object specifies a smaller size than the
-- size of the type, forcing biased representation for the object, but
-- the subtype is still an unbiased type.
-- Has_Completion (Flag26)
-- Defined in all entities that require a completion (functions,
-- procedures, private types, limited private types, incomplete types,
-- constants and packages that require a body). The flag is set if the
-- completion has been encountered and analyzed.
-- Has_Completion_In_Body (Flag71)
-- Defined in all entities for types and subtypes. Set only in "Taft
-- amendment types" (incomplete types whose full declaration appears in
-- the package body).
-- Has_Complex_Representation (Flag140) [implementation base type only]
-- Defined in all type entities. Set only for a record base type to
-- which a valid pragma Complex_Representation applies.
-- Has_Component_Size_Clause (Flag68) [implementation base type only]
-- Defined in all type entities. Set if a component size clause is
-- Defined for the given type. Note that this flag can be False even
-- if Component_Size is non-zero (happens in the case of derived types).
-- Has_Constrained_Partial_View (Flag187)
-- Defined in private type and their completions, when the private
-- type has no discriminants and the full view has discriminants with
-- defaults. In Ada 2005 heap-allocated objects of such types are not
-- constrained, and can change their discriminants with full assignment.
--
-- Ada 2012 has an additional rule (3.3. (23/10.3)) concerning objects
-- declared in a generic package body. Objects whose type is an untagged
-- generic formal private type are considered to have a constrained
-- partial view. The predicate Object_Type_Has_Constrained_Partial_View
-- in sem_aux is used to test for this case.
-- Has_Contiguous_Rep (Flag181)
-- Defined in enumeration types. Set if the type as a representation
-- clause whose entries are successive integers.
-- Has_Controlling_Result (Flag98)
-- Defined in E_Function entities. Set if the function is a primitive
-- function of a tagged type which can dispatch on result.
-- Has_Controlled_Component (Flag43) [base type only]
-- Defined in all type and subtype entities. Set only for composite type
-- entities which contain a component that either is a controlled type,
-- or itself contains controlled component (i.e. either Is_Controlled or
-- Has_Controlled_Component is set for at least one component).
-- Has_Convention_Pragma (Flag119)
-- Defined in all entities. Set for an entity for which a valid pragma
-- Convention, Import, or Export has been given. Used to prevent more
-- than one such pragma appearing for a given entity (RM B.1(45)).
-- Has_Delayed_Aspects (Flag200)
-- Defined in all entities. Set if the Rep_Item chain for the entity has
-- one or more N_Aspect_Definition nodes chained which are not to be
-- evaluated till the freeze point. The aspect definition expression
-- clause has been preanalyzed to get visibility at the point of use,
-- but no other action has been taken.
-- Has_Delayed_Freeze (Flag18)
-- Defined in all entities. Set to indicate that an explicit freeze
-- node must be generated for the entity at its freezing point. See
-- separate section ("Delayed Freezing and Elaboration") for details.
-- Has_Default_Aspect (Flag39) [base type only]
-- Defined in entities for types and subtypes, set for scalar types with
-- a Default_Value aspect and array types with a Default_Component_Value
-- apsect. If this flag is set, then a corresponding aspect specification
-- node will be present on the rep item chain for the entity.
-- Has_Delayed_Rep_Aspects (Flag261)
-- Defined in all type and subtypes. This flag is set if there is at
-- least one aspect for a representation characteristic that has to be
-- delayed and is one of the characteristics that may be inherited by
-- types derived from this type if not overridden. If this flag is set,
-- then types derived from this type have May_Inherit_Delayed_Rep_Aspects
-- set, signalling that Freeze.Inhert_Delayed_Rep_Aspects must be called
-- at the freeze point of the derived type.
-- Has_Discriminants (Flag5)
-- Defined in all types and subtypes. For types that are allowed to have
-- discriminants (record types and subtypes, task types and subtypes,
-- protected types and subtypes, private types, limited private types,
-- and incomplete types), indicates if the corresponding type or subtype
-- has a known discriminant part. Always false for all other types.
-- Has_Dispatch_Table (Flag220)
-- Defined in E_Record_Types that are tagged. Set to indicate that the
-- corresponding dispatch table is already built. This flag is used to
-- avoid duplicate construction of library level dispatch tables (because
-- the declaration of library level objects cause premature construction
-- of the table); otherwise the code that builds the table is added at
-- the end of the list of declarations of the package.
-- Has_Dynamic_Predicate_Aspect (Flag258)
-- Defined in all types and subtypes. Set if a Dynamic_Predicate aspect
-- was explicitly applied to the type. Generally we treat predicates as
-- static if possible, regardless of whether they are specified using
-- Predicate, Static_Predicate, or Dynamic_Predicate. And if a predicate
-- can be treated as static (i.e. its expression is predicate-static),
-- then the flag Has_Static_Predicate will be set True. But there are
-- cases where legality is affected by the presence of an explicit
-- Dynamic_Predicate aspect. For example, even if a predicate looks
-- static, you can't use it in a case statement if there is an explicit
-- Dynamic_Predicate aspect specified. So test Has_Static_Predicate if
-- you just want to know if the predicate can be evaluated statically,
-- but test Has_Dynamic_Predicate_Aspect to enforce legality rules about
-- the use of dynamic predicates.
-- Has_Entries (synthesized)
-- Applies to concurrent types. True if any entries are declared
-- within the task or protected definition for the type.
-- Has_Enumeration_Rep_Clause (Flag66)
-- Defined in enumeration types. Set if an enumeration representation
-- clause has been given for this enumeration type. Used to prevent more
-- than one enumeration representation clause for a given type. Note
-- that this does not imply a representation with holes, since the rep
-- clause may merely confirm the default 0..N representation.
-- Has_Exit (Flag47)
-- Defined in loop entities. Set if the loop contains an exit statement.
-- Has_Foreign_Convention (synthesized)
-- Applies to all entities. Determines if the Convention for the
-- entity is a foreign convention (i.e. is other than Convention_Ada,
-- Convention_Intrinsic, Convention_Entry or Convention_Protected).
-- Has_Forward_Instantiation (Flag175)
-- Defined in package entities. Set for packages that instantiate local
-- generic entities before the corresponding generic body has been seen.
-- If a package has a forward instantiation, we cannot inline subprograms
-- appearing in the same package because the placement requirements of
-- the instance will conflict with the linear elaboration of front-end
-- inlining.
-- Has_Fully_Qualified_Name (Flag173)
-- Defined in all entities. Set if the name in the Chars field has been
-- replaced by the fully qualified name, as used for debug output. See
-- Exp_Dbug for a full description of the use of this flag and also the
-- related flag Has_Qualified_Name.
-- Has_Gigi_Rep_Item (Flag82)
-- Defined in all entities. Set if the rep item chain (referenced by
-- First_Rep_Item and linked through the Next_Rep_Item chain) contains a
-- representation item that needs to be specially processed by the back
-- end, i.e. one of the following items:
--
-- Machine_Attribute pragma
-- Linker_Alias pragma
-- Linker_Constructor pragma
-- Linker_Destructor pragma
-- Weak_External pragma
-- Thread_Local_Storage pragma
--
-- If this flag is set, then the backend should scan the rep item chain
-- to process any of these items that appear. At least one such item will
-- be present.
--
-- Has_Homonym (Flag56)
-- Defined in all entities. Set if an entity has a homonym in the same
-- scope. Used by the backend to generate unique names for all entities.
-- Has_Implicit_Dereference (Flag251)
-- Defined in types and discriminants. Set if the type has an aspect
-- Implicit_Dereference. Set also on the discriminant named in the aspect
-- clause, to simplify type resolution.
-- Has_Independent_Components (Flag34) [base type only]
-- Defined in types. Set if the aspect Independent_Components applies
-- (in the base type only), if corresponding pragma or aspect applies.
-- In the case of an object of anonymous array type, the flag is set on
-- the created array type.
-- Has_Inheritable_Invariants (Flag248)
-- Defined in all type entities. Set in private types from which one
-- or more Invariant'Class aspects will be inherited if a another type is
-- derived from the type (i.e. those types which have an Invariant'Class
-- aspect, or which inherit one or more Invariant'Class aspects). Also
-- set in the corresponding full types. Note that it might be the full
-- type which has inheritable invariants, and in this case the flag will
-- also be set in the private type.
-- Has_Initial_Value (Flag219)
-- Defined in entities for variables and out parameters. Set if there
-- is an explicit initial value expression in the declaration of the
-- variable. Note that this is set only if this initial value is
-- explicit, it is not set for the case of implicit initialization
-- of access types or controlled types. Always set to False for out
-- parameters. Also defined in entities for in and in-out parameters,
-- but always false in these cases.
-- Has_Interrupt_Handler (synthesized)
-- Applies to all protected type entities. Set if the protected type
-- definition contains at least one procedure to which a pragma
-- Interrupt_Handler applies.
-- Has_Invariants (Flag232)
-- Defined in all type entities and in subprogram entities. Set in
-- private types if an Invariant or Invariant'Class aspect applies to the
-- type, or if the type inherits one or more Invariant'Class aspects.
-- Also set in the corresponding full type. Note: if this flag is set
-- True, then usually the Invariant_Procedure attribute is set once the
-- type is frozen, however this may not be true in some error situations.
-- Note that it might be the full type which has inheritable invariants,
-- and then the flag will also be set in the private type.
-- Has_Loop_Entry_Attributes (Flag260)
-- Defined in E_Loop entities. Set when the loop is subject to at least
-- one attribute 'Loop_Entry. The flag also implies that the loop has
-- already been transformed. See Expand_Loop_Entry_Attribute for details.
-- Has_Machine_Radix_Clause (Flag83)
-- Defined in decimal types and subtypes, set if a Machine_Radix
-- representation clause is present. This flag is used to detect
-- the error of multiple machine radix clauses for a single type.
-- Has_Master_Entity (Flag21)
-- Defined in entities that can appear in the scope stack (see spec
-- of Sem). It is set if a task master entity (_master) has been
-- declared and initialized in the corresponding scope.
-- Has_Missing_Return (Flag142)
-- Defined in functions and generic functions. Set if there is one or
-- more missing return statements in the function. This is used to
-- control wrapping of the body in Exp_Ch6 to ensure that the program
-- error exception is correctly raised in this case at runtime.
-- Has_Nested_Block_With_Handler (Flag101)
-- Defined in scope entities. Set if there is a nested block within the
-- scope that has an exception handler and the two scopes are in the
-- same procedure. This is used by the backend for controlling certain
-- optimizations to ensure that they are consistent with exceptions.
-- See documentation in backend for further details.
-- Has_Non_Null_Refinement (synth)
-- Defined in E_Abstract_State entities. True if the state has at least
-- one variable or state constituent in aspect/pragma Refined_State.
-- Has_Non_Standard_Rep (Flag75) [implementation base type only]
-- Defined in all type entities. Set when some representation clause
-- or pragma causes the representation of the item to be significantly
-- modified. In this category are changes of small or radix for a
-- fixed-point type, change of component size for an array, and record
-- or enumeration representation clauses, as well as packed pragmas.
-- All other representation clauses (e.g. Size and Alignment clauses)
-- are not considered to be significant since they do not affect
-- stored bit patterns.
-- Has_Null_Abstract_State (synth)
-- Defined in package entities. True if the package is subject to a null
-- Abstract_State aspect/pragma.
-- Has_Null_Refinement (synth)
-- Defined in E_Abstract_State entities. True if the state has a null
-- refinement in aspect/pragma Refined_State.
-- Has_Object_Size_Clause (Flag172)
-- Defined in entities for types and subtypes. Set if an Object_Size
-- clause has been processed for the type Used to prevent multiple
-- Object_Size clauses for a given entity.
-- Has_Out_Or_In_Out_Parameter (Flag110)
-- Present in function and generic function entities. Set if the function
-- has at least one OUT or IN OUT parameter (allowed only in Ada 2012).
-- Has_Per_Object_Constraint (Flag154)
-- Defined in E_Component entities. Set if the subtype of the component
-- has a per object constraint. Per object constraints result from the
-- following situations :
--
-- 1. N_Attribute_Reference - when the prefix is the enclosing type and
-- the attribute is Access.
-- 2. N_Discriminant_Association - when the expression uses the
-- discriminant of the enclosing type.
-- 3. N_Index_Or_Discriminant_Constraint - when at least one of the
-- individual constraints is a per object constraint.
-- 4. N_Range - when the lower or upper bound uses the discriminant of
-- the enclosing type.
-- 5. N_Range_Constraint - when the range expression uses the
-- discriminant of the enclosing type.
-- Has_Postconditions (Flag240)
-- Defined in subprogram entities. Set if postconditions are active for
-- the procedure, and a _postconditions procedure has been generated.
-- Has_Pragma_Controlled (Flag27) [implementation base type only]
-- Defined in access type entities. It is set if a pragma Controlled
-- applies to the access type.
-- Has_Pragma_Elaborate_Body (Flag150)
-- Defined in all entities. Set in compilation unit entities if a
-- pragma Elaborate_Body applies to the compilation unit.
-- Has_Pragma_Inline (Flag157)
-- Defined in all entities. Set for functions and procedures for which a
-- pragma Inline or Inline_Always applies to the subprogram. Note that
-- this flag can be set even if Is_Inlined is not set. This happens for
-- pragma Inline (if Inline_Active is False). In other words, the flag
-- Has_Pragma_Inline represents the formal semantic status, and is used
-- for checking semantic correctness. The flag Is_Inlined indicates
-- whether inlining is actually active for the entity.
-- Has_Pragma_Inline_Always (Flag230)
-- Defined in all entities. Set for functions and procedures for which a
-- pragma Inline_Always applies. Note that if this flag is set, the flag
-- Has_Pragma_Inline is also set.
-- Has_Pragma_No_Inline (Flag201)
-- Defined in all entities. Set for functions and procedures for which a
-- pragma No_Inline applies. Note that if this flag is set, the flag
-- Has_Pragma_Inline_Always cannot be set.
-- Has_Pragma_Ordered (Flag198) [implementation base type only]
-- Defined in entities for enumeration types. If set indicates that a
-- valid pragma Ordered was given for the type. This flag is inherited
-- by derived enumeration types. We don't need to distinguish the derived
-- case since we allow multiple occurrences of this pragma anyway.
-- Has_Pragma_Pack (Flag121) [implementation base type only]
-- Defined in array and record type entities. If set, indicates that a
-- valid pragma Pack was given for the type. Note that this flag is not
-- inherited by derived type. See also the Is_Packed flag.
-- Has_Pragma_Pure (Flag203)
-- Defined in all entities. If set, indicates that a valid pragma Pure
-- was given for the entity. In some cases, we need to test whether
-- Is_Pure was explicitly set using this pragma.
-- Has_Pragma_Preelab_Init (Flag221)
-- Defined in type and subtype entities. If set indicates that a valid
-- pragma Preelaborable_Initialization applies to the type.
-- Has_Pragma_Pure_Function (Flag179)
-- Defined in all entities. If set, indicates that a valid pragma
-- Pure_Function was given for the entity. In some cases, we need to
-- know that Is_Pure was explicitly set using this pragma. We also set
-- this flag for some internal entities that we know should be treated
-- as pure for optimization purposes.
-- Has_Pragma_Thread_Local_Storage (Flag169)
-- Defined in all entities. If set, indicates that a valid pragma
-- Thread_Local_Storage was given for the entity.
-- Has_Pragma_Unmodified (Flag233)
-- Defined in all entities. Can only be set for variables (E_Variable,
-- E_Out_Parameter, E_In_Out_Parameter). Set if a valid pragma Unmodified
-- applies to the variable, indicating that no warning should be given
-- if the entity is never modified. Note that clients should generally
-- not test this flag directly, but instead use function Has_Unmodified.
-- Has_Pragma_Unreferenced (Flag180)
-- Defined in all entities. Set if a valid pragma Unreferenced applies
-- to the entity, indicating that no warning should be given if the
-- entity has no references, but a warning should be given if it is
-- in fact referenced. For private types, this flag is set in both the
-- private entity and full entity if the pragma applies to either. Note
-- that clients should generally not test this flag directly, but instead
-- use function Has_Unreferenced.
-- Has_Pragma_Unreferenced_Objects (Flag212)
-- Defined in type and subtype entities. Set if a valid pragma
-- Unreferenced_Objects applies to the type, indicating that no warning
-- should be given for objects of such a type for being unreferenced
-- (but unlike the case with pragma Unreferenced, it is ok to reference
-- such an object and no warning is generated.
-- Has_Predicates (Flag250)
-- Defined in type and subtype entities. Set if a pragma Predicate or
-- Predicate aspect applies to the type or subtype, or if it inherits a
-- Predicate aspect from its parent or progenitor types.
-- Has_Primitive_Operations (Flag120) [base type only]
-- Defined in all type entities. Set if at least one primitive operation
-- is defined for the type.
-- Has_Private_Ancestor (Flag151)
-- Applies to untagged derived types and to type extensions. True when
-- some ancestor is derived from a private type, making some components
-- invisible and aggregates illegal. Used to check the legality of
-- selected components and aggregates. The flag is set at the point of
-- derivation. The legality of an aggregate of a type with a private
-- ancestor must be checked because it also depends on the visibility
-- at the point the aggregate is resolved. See sem_aggr.adb. This is
-- part of AI05-0115.
-- Has_Private_Declaration (Flag155)
-- Defined in all entities. Set if it is the defining entity of a private
-- type declaration or its corresponding full declaration. This flag is
-- thus preserved when the full and the partial views are exchanged, to
-- indicate if a full type declaration is a completion. Used for semantic
-- checks in E.4(18) and elsewhere.
-- Has_Protected (Flag271) [base type only]
-- Defined in all type entities. Set on protected types themselves, and
-- also (recursively) on any composite type which has a component for
-- which Has_Protected is set. The meaning is that an allocator for
-- or declaration of such an object must create the required protected
-- objects. Note: the flag is not set on access types, even if they
-- designate an object that Has_Protected.
-- Has_Qualified_Name (Flag161)
-- Defined in all entities. Set if the name in the Chars field has
-- been replaced by its qualified name, as used for debug output. See
-- Exp_Dbug for a full description of qualification requirements. For
-- some entities, the name is the fully qualified name, but there are
-- exceptions. In particular, for local variables in procedures, we
-- do not include the procedure itself or higher scopes. See also the
-- flag Has_Fully_Qualified_Name, which is set if the name does indeed
-- include the fully qualified name.
-- Has_RACW (Flag214)
-- Defined in package spec entities. Set if the spec contains the
-- declaration of a remote access-to-classwide type.
-- Has_Record_Rep_Clause (Flag65) [implementation base type only]
-- Defined in record types. Set if a record representation clause has
-- been given for this record type. Used to prevent more than one such
-- clause for a given record type. Note that this is initially cleared
-- for a derived type, even though the representation is inherited. See
-- also the flag Has_Specified_Layout.
-- Has_Recursive_Call (Flag143)
-- Defined in procedures. Set if a direct parameterless recursive call
-- is detected while analyzing the body. Used to activate some error
-- checks for infinite recursion.
-- Has_Shift_Operator (Flag267) [base type only]
-- Defined in integer types. Set in the base type of an integer type for
-- which at least one of the shift operators is defined.
-- Has_Size_Clause (Flag29)
-- Defined in entities for types and objects. Set if a size clause is
-- defined for the entity. Used to prevent multiple Size clauses for a
-- given entity. Note that it is always initially cleared for a derived
-- type, even though the Size for such a type is inherited from a Size
-- clause given for the parent type.
-- Has_Small_Clause (Flag67)
-- Defined in ordinary fixed point types (but not subtypes). Indicates
-- that a small clause has been given for the entity. Used to prevent
-- multiple Small clauses for a given entity. Note that it is always
-- initially cleared for a derived type, even though the Small for such
-- a type is inherited from a Small clause given for the parent type.
-- Has_Specified_Layout (Flag100) [implementation base type only]
-- Defined in all type entities. Set for a record type or subtype if
-- the record layout has been specified by a record representation
-- clause. Note that this differs from the flag Has_Record_Rep_Clause
-- in that it is inherited by a derived type. Has_Record_Rep_Clause is
-- used to indicate that the type is mentioned explicitly in a record
-- representation clause, and thus is not inherited by a derived type.
-- This flag is always False for non-record types.
-- Has_Specified_Stream_Input (Flag190)
-- Has_Specified_Stream_Output (Flag191)
-- Has_Specified_Stream_Read (Flag192)
-- Has_Specified_Stream_Write (Flag193)
-- Defined in all type and subtype entities. Set for a given view if the
-- corresponding stream-oriented attribute has been defined by an
-- attribute definition clause. When such a clause occurs, a TSS is set
-- on the underlying full view; the flags are used to track visibility of
-- the attribute definition clause for partial or incomplete views.
-- Has_Static_Discriminants (Flag211)
-- Defined in record subtypes constrained by discriminant values. Set if
-- all the discriminant values have static values, meaning that in the
-- case of a variant record, the component list can be trimmed down to
-- include only the components corresponding to these discriminants.
-- Has_Static_Predicate (Flag269)
-- Defined in all types and subtypes. Set if the type (which must be a
-- scalar type) has a predicate whose expression is predicate-static.
-- This can result from use of any of a Predicate, Static_Predicate, or
-- Dynamic_Predicate aspect. We can distinguish these cases by testing
-- Has_Static_Predicate_Aspect and Has_Dynamic_Predicate_Aspect. See
-- description of the latter flag for further information on dynamic
-- predicates which are also static.
-- Has_Static_Predicate_Aspect (Flag259)
-- Defined in all types and subtypes. Set if a Static_Predicate aspect
-- applies to the type. Note that we can tell if a static predicate is
-- present by looking at Has_Static_Predicate, but this could have come
-- from a Predicate aspect or pragma or even from a Dynamic_Predicate
-- aspect. When we need to know the difference (e.g. to know what set of
-- check policies apply, use this flag and Has_Dynamic_Predicate_Aspect
-- to determine which case we have).
-- Has_Storage_Size_Clause (Flag23) [implementation base type only]
-- Defined in task types and access types. It is set if a Storage_Size
-- clause is present for the type. Used to prevent multiple clauses for
-- one type. Note that this flag is initially cleared for a derived type
-- even though the Storage_Size for such a type is inherited from a
-- Storage_Size clause given for the parent type. Note that in the case
-- of access types, this flag is defined only in the root type, since a
-- storage size clause cannot be given to a derived type.
-- Has_Stream_Size_Clause (Flag184)
-- Defined in all entities. It is set for types which have a Stream_Size
-- clause attribute. Used to prevent multiple Stream_Size clauses for a
-- given entity, and also whether it is necessary to check for a stream
-- size clause.
-- Has_Task (Flag30) [base type only]
-- Defined in all type entities. Set on task types themselves, and also
-- (recursively) on any composite type which has a component for which
-- Has_Task is set. The meaning is that an allocator or declaration of
-- such an object must create the required tasks. Note: the flag is not
-- set on access types, even if they designate an object that Has_Task.
-- Has_Thunks (Flag228)
-- Applies to E_Constant entities marked Is_Tag. True for secondary tag
-- referencing a dispatch table whose contents are pointers to thunks.
-- Has_Unchecked_Union (Flag123) [base type only]
-- Defined in all type entities. Set on unchecked unions themselves
-- and (recursively) on any composite type which has a component for
-- which Has_Unchecked_Union is set. The meaning is that a comparison
-- operation for the type is not permitted. Note that the flag is not
-- set on access types, even if they designate an object that has
-- the flag Has_Unchecked_Union set.
-- Has_Unknown_Discriminants (Flag72)
-- Defined in all entities. Set for types with unknown discriminants.
-- Types can have unknown discriminants either from their declaration or
-- through type derivation. The use of this flag exactly meets the spec
-- in RM 3.7(26). Note that all class-wide types are considered to have
-- unknown discriminants. Note that both flags Has_Discriminants and
-- Has_Unknown_Discriminants may be true for a type. Class-wide types and
-- their subtypes have unknown discriminants and can have declared ones
-- as well. Private types declared with unknown discriminants may have a
-- full view that has explicit discriminants, and both flag will be set
-- on the partial view, to insure that discriminants are properly
-- inherited in certain contexts.
-- Has_Up_Level_Access (Flag215)
-- Defined in E_Variable and E_Constant entities. Set if the entity
-- is a local variable declared in a subprogram p and is accessed in
-- a subprogram nested inside p. Currently this flag is only set when
-- VM_Target /= No_VM, for efficiency, since only the .NET back-end
-- makes use of it to generate proper code for up-level references.
-- Has_Visible_Refinement (Flag263)
-- Defined in E_Abstract_State entities. Set when a state has at least
-- one refinement constituent and analysis is in the region between
-- pragma Refined_State and the end of the package body declarations.
-- Has_Volatile_Components (Flag87) [implementation base type only]
-- Defined in all types and objects. Set only for an array type or array
-- object if a valid pragma Volatile_Components or a valid pragma
-- Atomic_Components applies to the type or object. Note that in the case
-- of an object, this flag is only set on the object if there was an
-- explicit pragma for the object. In other words, the proper test for
-- whether an object has volatile components is to see if either the
-- object or its base type has this flag set. Note that in the case of a
-- type the pragma will be chained to the rep item chain of the first
-- subtype in the usual manner.
-- Has_Xref_Entry (Flag182)
-- Defined in all entities. Set if an entity has an entry in the Xref
-- information generated in ali files. This is true for all source
-- entities in the extended main source file. It is also true of entities
-- in other packages that are referenced directly or indirectly from the
-- main source file (indirect reference occurs when the main source file
-- references an entity with a type reference. See package Lib.Xref for
-- further details).
-- Hiding_Loop_Variable (Node8)
-- Defined in variables. Set only if a variable of a discrete type is
-- hidden by a loop variable in the same local scope, in which case
-- the Hiding_Loop_Variable field of the hidden variable points to
-- the E_Loop_Parameter entity doing the hiding. Used in processing
-- warning messages if the hidden variable turns out to be unused
-- or is referenced without being set.
-- Homonym (Node4)
-- Defined in all entities. Link for list of entities that have the
-- same source name and that are declared in the same or enclosing
-- scopes. Homonyms in the same scope are overloaded. Used for name
-- resolution and for the generation of debugging information.
-- Implementation_Base_Type (synthesized)
-- Applies to all entities. For types, similar to Base_Type, but never
-- returns a private type when applied to a non-private type. Instead in
-- this case, it always returns the Underlying_Type of the base type, so
-- that we still have a concrete type. For entities other than types,
-- returns the entity unchanged.
-- Import_Pragma (Node35)
-- Defined in subprogram entities. Set if a valid pragma Import or pragma
-- Import_Function or pragma Import_Procedure aplies to the subprogram,
-- in which case this field points to the pragma (we can't use the normal
-- Rep_Item chain mechanism, because a single pragma Import can apply
-- to multiple subprogram entities.
-- In_Package_Body (Flag48)
-- Defined in package entities. Set on the entity that denotes the
-- package (the defining occurrence of the package declaration) while
-- analyzing and expanding the package body. Reset on completion of
-- analysis/expansion.
-- In_Private_Part (Flag45)
-- Defined in all entities. Can be set only in package entities and
-- objects. For package entities, this flag is set to indicate that the
-- private part of the package is being analyzed. The flag is reset at
-- the end of the package declaration. For objects it indicates that the
-- declaration of the object occurs in the private part of a package.
-- Initialization_Statements (Node28)
-- Defined in constants and variables. For a composite object initialized
-- initialized with an aggregate that has been converted to a sequence
-- of assignments, points to a block statement containing the
-- assignments.
-- Inner_Instances (Elist23)
-- Defined in generic units. Contains element list of units that are
-- instantiated within the given generic. Used to diagnose circular
-- instantiations.
-- Interface_Alias (Node25)
-- Defined in subprograms that cover a primitive operation of an abstract
-- interface type. Can be set only if the Is_Hidden flag is also set,
-- since such entities are always hidden. Points to its associated
-- interface subprogram. It is used to register the subprogram in
-- secondary dispatch table of the interface (Ada 2005: AI-251).
-- Interface_Name (Node21)
-- Defined in constants, variables, exceptions, functions, procedures,
-- packages, components (JGNAT only), discriminants (JGNAT only), and
-- access to subprograms (JGNAT only). Set to Empty unless an export,
-- import, or interface name pragma has explicitly specified an external
-- name, in which case it references an N_String_Literal node for the
-- specified external name. In the case of exceptions, the field is set
-- by Import_Exception/Export_Exception (which can be used in OpenVMS
-- versions only). Note that if this field is Empty, and Is_Imported
-- or Is_Exported is set, then the default interface name is the name
-- of the entity, cased in a manner that is appropriate to the system
-- in use. Note that Interface_Name is ignored if an address clause
-- is present (since it is meaningless in this case).
--
-- An additional special case usage of this field is in JGNAT for
-- E_Component and E_Discriminant. JGNAT allows these entities to be
-- imported by specifying pragma Import within a component's containing
-- record definition. This supports interfacing to object fields defined
-- within Java classes, and such pragmas are generated by the jvm2ada
-- binding generator tool whenever it processes classes with public
-- object fields. A pragma Import for a component can define the
-- External_Name of the imported Java field (which is generally needed,
-- because Java names are case sensitive).
-- Interfaces (Elist25)
-- Defined in record types and subtypes. List of abstract interfaces
-- implemented by a tagged type that are not already implemented by the
-- ancestors (Ada 2005: AI-251).
-- Invariant_Procedure (synthesized)
-- Defined in types and subtypes. Set for private types if one or more
-- Invariant, or Invariant'Class, or inherited Invariant'Class aspects
-- apply to the type. Points to the entity for a procedure which checks
-- the invariant. This invariant procedure takes a single argument of the
-- given type, and returns if the invariant holds, or raises exception
-- Assertion_Error with an appropriate message if it does not hold. This
-- attribute is defined but always empty for private subtypes. This
-- attribute is also set for the corresponding full type.
--
-- Note: the reason this is marked as a synthesized attribute is that the
-- way this is stored is as an element of the Subprograms_For_Type field.
-- In_Use (Flag8)
-- Defined in packages and types. Set when analyzing a use clause for
-- the corresponding entity. Reset at end of corresponding declarative
-- part. The flag on a type is also used to determine the visibility of
-- the primitive operators of the type.
-- Is_Abstract_Subprogram (Flag19)
-- Defined in all subprograms and entries. Set for abstract subprograms.
-- Always False for enumeration literals and entries. See also
-- Requires_Overriding.
-- Is_Abstract_Type (Flag146)
-- Defined in all types. Set for abstract types.
-- Is_Access_Constant (Flag69)
-- Defined in access types and subtypes. Indicates that the keyword
-- constant was present in the access type definition.
-- Is_Access_Protected_Subprogram_Type (synthesized)
-- Applies to all types, true for named and anonymous access to
-- protected subprograms.
-- Is_Access_Type (synthesized)
-- Applies to all entities, true for access types and subtypes
-- Is_Ada_2005_Only (Flag185)
-- Defined in all entities, true if a valid pragma Ada_05 or Ada_2005
-- applies to the entity which specifically names the entity, indicating
-- that the entity is Ada 2005 only. Note that this flag is not set if
-- the entity is part of a unit compiled with the normal no-argument form
-- of pragma Ada_05 or Ada_2005.
-- Is_Ada_2012_Only (Flag199)
-- Defined in all entities, true if a valid pragma Ada_12 or Ada_2012
-- applies to the entity which specifically names the entity, indicating
-- that the entity is Ada 2012 only. Note that this flag is not set if
-- the entity is part of a unit compiled with the normal no-argument form
-- of pragma Ada_12 or Ada_2012.
-- Is_Aliased (Flag15)
-- Defined in all entities. Set for objects and types whose declarations
-- carry the keyword aliased, and on record components that have the
-- keyword. For Ada 2012, also applies to formal parameters.
-- Is_AST_Entry (Flag132)
-- Defined in entry entities. Set if a valid pragma AST_Entry applies
-- to the entry. This flag can only be set in OpenVMS versions of GNAT.
-- Note: we also allow the flag to appear in entry families, but given
-- the current implementation of the pragma AST_Entry, this flag will
-- always be False in entry families.
-- Is_Atomic (Flag85)
-- Defined in all type entities, and also in constants, components and
-- variables. Set if a pragma Atomic or Shared applies to the entity.
-- In the case of private and incomplete types, this flag is set in
-- both the partial view and the full view.
-- Is_Array_Type (synthesized)
-- Applies to all entities, true for array types and subtypes
-- Is_Asynchronous (Flag81)
-- Defined in all type entities and in procedure entities. Set
-- if a pragma Asynchronous applies to the entity.
-- Is_Base_Type (synthesized)
-- Applies to type and subtype entities. True if entity is a base type
-- Is_Bit_Packed_Array (Flag122) [implementation base type only]
-- Defined in all entities. This flag is set for a packed array type that
-- is bit packed (i.e. the component size is known by the front end and
-- is in the range 1-7, 9-15, 17-31, or 33-63). Is_Packed is always set
-- if Is_Bit_Packed_Array is set, but it is possible for Is_Packed to be
-- set without Is_Bit_Packed_Array for the case of an array having one or
-- more index types that are enumeration types with non-standard
-- enumeration representations.
-- Is_Boolean_Type (synthesized)
-- Applies to all entities, true for boolean types and subtypes,
-- i.e. Standard.Boolean and all types ultimately derived from it.
-- Is_Called (Flag102)
-- Defined in subprograms. Returns true if the subprogram is called
-- in the unit being compiled or in a unit in the context. Used for
-- inlining.
-- Is_Character_Type (Flag63)
-- Defined in all entities. Set for character types and subtypes,
-- i.e. enumeration types that have at least one character literal.
-- Is_Child_Unit (Flag73)
-- Defined in all entities. Set only for defining entities of program
-- units that are child units (but False for subunits).
-- Is_Class_Wide_Type (synthesized)
-- Applies to all entities, true for class wide types and subtypes
-- Is_Class_Wide_Equivalent_Type (Flag35)
-- Defined in record types and subtypes. Set to True, if the type acts
-- as a class-wide equivalent type, i.e. the Equivalent_Type field of
-- some class-wide subtype entity references this record type.
-- Is_Compilation_Unit (Flag149)
-- Defined in all entities. Set if the entity is a package or subprogram
-- entity for a compilation unit other than a subunit (since we treat
-- subunits as part of the same compilation operation as the ultimate
-- parent, we do not consider them to be separate units for this flag).
-- Is_Completely_Hidden (Flag103)
-- Defined in all entities. This flag can be set only for E_Discriminant
-- entities. This flag can be set only for girder discriminants of
-- untagged types. When set, the entity is a girder discriminant of a
-- derived untagged type which is not directly visible in the derived
-- type because the derived type or one of its ancestors have renamed the
-- discriminants in the root type. Note: there are girder discriminants
-- which are not Completely_Hidden (e.g. discriminants of a root type).
-- Is_Composite_Type (synthesized)
-- Applies to all entities, true for all composite types and
-- subtypes. Either Is_Composite_Type or Is_Elementary_Type (but
-- not both) is true of any type.
-- Is_Concurrent_Record_Type (Flag20)
-- Defined in record types and subtypes. Set if the type was created
-- by the expander to represent a task or protected type. For every
-- concurrent type, such as record type is constructed, and task and
-- protected objects are instances of this record type at runtime
-- (The backend will replace declarations of the concurrent type using
-- the declarations of the corresponding record type). See Exp_Ch9 for
-- further details.
-- Is_Concurrent_Type (synthesized)
-- Applies to all entities, true for task types and subtypes and for
-- protected types and subtypes.
-- Is_Constant_Object (synthesized)
-- Applies to all entities, true for E_Constant, E_Loop_Parameter, and
-- E_In_Parameter entities.
-- Is_Constrained (Flag12)
-- Defined in types or subtypes which may have index, discriminant
-- or range constraint (i.e. array types and subtypes, record types
-- and subtypes, string types and subtypes, and all numeric types).
-- Set if the type or subtype is constrained.
-- Is_Constr_Subt_For_U_Nominal (Flag80)
-- Defined in all types and subtypes. Set only for the constructed
-- subtype of an object whose nominal subtype is unconstrained. Note
-- that the constructed subtype itself will be constrained.
-- Is_Constr_Subt_For_UN_Aliased (Flag141)
-- Defined in all types and subtypes. This flag can be set only if
-- Is_Constr_Subt_For_U_Nominal is also set. It indicates that in
-- addition the object concerned is aliased. This flag is used by
-- the backend to determine whether a template must be constructed.
-- Is_Constructor (Flag76)
-- Defined in function and procedure entities. Set if a pragma
-- CPP_Constructor applies to the subprogram.
-- Is_Controlled (Flag42) [base type only]
-- Defined in all type entities. Indicates that the type is controlled,
-- i.e. is either a descendant of Ada.Finalization.Controlled or of
-- Ada.Finalization.Limited_Controlled.
-- Is_Controlling_Formal (Flag97)
-- Defined in all Formal_Kind entities. Marks the controlling parameters
-- of dispatching operations.
-- Is_CPP_Class (Flag74)
-- Defined in all type entities, set only for tagged types to which a
-- valid pragma Import (CPP, ...) or pragma CPP_Class has been applied.
-- Is_Decimal_Fixed_Point_Type (synthesized)
-- Applies to all type entities, true for decimal fixed point
-- types and subtypes.
-- Is_Descendent_Of_Address (Flag223)
-- Defined in all entities. True if the entity is type System.Address,
-- or (recursively) a subtype or derived type of System.Address.
-- Is_Discrete_Type (synthesized)
-- Applies to all entities, true for all discrete types and subtypes
-- Is_Discrete_Or_Fixed_Point_Type (synthesized)
-- Applies to all entities, true for all discrete types and subtypes
-- and all fixed-point types and subtypes.
-- Is_Discrim_SO_Function (Flag176)
-- Defined in all entities. Set only in E_Function entities that Layout
-- creates to compute discriminant-dependent dynamic size/offset values.
-- Is_Discriminant_Check_Function (Flag264)
-- Defined in all entities. Set only in E_Function entities for functions
-- created to do discriminant checks.
-- Is_Discriminal (synthesized)
-- Applies to all entities, true for renamings of discriminants. Such
-- entities appear as constants or IN parameters.
-- Is_Dispatch_Table_Entity (Flag234)
-- Applies to all entities. Set to indicate to the backend that this
-- entity is associated with a dispatch table.
-- Is_Dispatching_Operation (Flag6)
-- Defined in all entities. Set for procedures, functions, generic
-- procedures, and generic functions if the corresponding operation
-- is dispatching.
-- Is_Dynamic_Scope (synthesized)
-- Applies to all Entities. Returns True if the entity is a dynamic
-- scope (i.e. a block, subprogram, task_type, entry
-- or extended return statement).
-- Is_Elementary_Type (synthesized)
-- Applies to all entities, true for all elementary types and
-- subtypes. Either Is_Composite_Type or Is_Elementary_Type (but
-- not both) is true of any type.
-- Is_Eliminated (Flag124)
-- Defined in type entities, subprogram entities, and object entities.
-- Indicates that the corresponding entity has been eliminated by use
-- of pragma Eliminate. Also used to mark subprogram entities whose
-- declaration and body are within unreachable code that is removed.
-- Is_Enumeration_Type (synthesized)
-- Defined in all entities, true for enumeration types and subtypes
-- Is_Entry (synthesized)
-- Applies to all entities, True only for entry and entry family
-- entities and False for all other entity kinds.
-- Is_Entry_Formal (Flag52)
-- Defined in all entities. Set only for entry formals (which can only
-- be in, in-out or out parameters). This flag is used to speed up the
-- test for the need to replace references in Exp_Ch2.
-- Is_Exported (Flag99)
-- Defined in all entities. Set if the entity is exported. For now we
-- only allow the export of constants, exceptions, functions, procedures
-- and variables, but that may well change later on. Exceptions can only
-- be exported in the OpenVMS and Java VM implementations of GNAT.
-- Is_External_State (synthesized)
-- Applies to all entities, true for abstract states that are subject to
-- option External.
-- Is_Finalizer (synthesized)
-- Applies to all entities, true for procedures containing finalization
-- code to process local or library level objects.
-- Is_First_Subtype (Flag70)
-- Defined in all entities. True for first subtypes (RM 3.2.1(6)),
-- i.e. the entity in the type declaration that introduced the type.
-- This may be the base type itself (e.g. for record declarations and
-- enumeration type declarations), or it may be the first subtype of
-- an anonymous base type (e.g. for integer type declarations or
-- constrained array declarations).
-- Is_Fixed_Point_Type (synthesized)
-- Applies to all entities, true for decimal and ordinary fixed
-- point types and subtypes
-- Is_Floating_Point_Type (synthesized)
-- Applies to all entities, true for float types and subtypes
-- Is_Formal (synthesized)
-- Applies to all entities, true for IN, IN OUT and OUT parameters
-- Is_Formal_Object (synthesized)
-- Applies to all entities, true for generic IN and IN OUT parameters
-- Is_Formal_Subprogram (Flag111)
-- Defined in all entities. Set for generic formal subprograms.
-- Is_For_Access_Subtype (Flag118)
-- Defined in E_Private_Subtype and E_Record_Subtype entities. Means the
-- sole purpose of the type is to be designated by an Access_Subtype and
-- hence should not be expanded into components because the type may not
-- have been found or frozen yet.
-- Is_Frozen (Flag4)
-- Defined in all type and subtype entities. Set if type or subtype has
-- been frozen.
-- Is_Generic_Actual_Type (Flag94)
-- Defined in all type and subtype entities. Set in the subtype
-- declaration that renames the generic formal as a subtype of the
-- actual. Guarantees that the subtype is not static within the instance.
-- Is_Generic_Instance (Flag130)
-- Defined in all entities. Set to indicate that the entity is an
-- instance of a generic unit, or a formal package (which is an instance
-- of the template).
-- Is_Generic_Subprogram (synthesized)
-- Applies to all entities. Yields True for a generic subprogram
-- (generic function, generic subprogram), False for all other entities.
-- Is_Generic_Type (Flag13)
-- Defined in all entities. Set for types which are generic formal types.
-- Such types have an Ekind that corresponds to their classification, so
-- the Ekind cannot be used to identify generic formal types.
-- Is_Generic_Unit (synthesized)
-- Applies to all entities. Yields True for a generic unit (generic
-- package, generic function, generic procedure), and False for all
-- other entities.
-- Is_Ghost_Entity (synthesized)
-- Applies to all entities. Yields True for a subprogram or a whole
-- object that has convention Ghost. For now only functions can have
-- Ghost convention, so this will be false for other than functions,
-- but we expect that to change in the future.
-- Is_Ghost_Subprogram (synthesized)
-- Applies to all entities. Yields True for a subprogram that has a Ghost
-- convention. Note: for now, only ghost functions are allowed, so this
-- will always be false for procedures, but that is expected to change in
-- the future.
-- Is_Hidden (Flag57)
-- Defined in all entities. Set for all entities declared in the
-- private part or body of a package. Also marks generic formals of a
-- formal package declared without a box. For library level entities,
-- this flag is set if the entity is not publicly visible. This flag
-- is reset when compiling the body of the package where the entity
-- is declared, when compiling the private part or body of a public
-- child unit, and when compiling a private child unit (see Install_
-- Private_Declaration in sem_ch7).
-- Is_Hidden_Open_Scope (Flag171)
-- Defined in all entities. Set for a scope that contains the
-- instantiation of a child unit, and whose entities are not visible
-- during analysis of the instance.
-- Is_Immediately_Visible (Flag7)
-- Defined in all entities. Set if entity is immediately visible, i.e.
-- is defined in some currently open scope (RM 8.3(4)).
-- Is_Implementation_Defined (Flag254)
-- Defined in all entities. Set if a pragma Implementation_Defined is
-- applied to the pragma. Used to mark all implementation defined
-- identifiers in standard library packages, and to implement the
-- restriction No_Implementation_Identifiers.
-- Is_Imported (Flag24)
-- Defined in all entities. Set if the entity is imported. For now we
-- only allow the import of exceptions, functions, procedures, packages.
-- and variables. Exceptions can only be imported in the OpenVMS and
-- Java VM implementations of GNAT. Packages and types can only be
-- imported in the Java VM implementation.
-- Is_Incomplete_Or_Private_Type (synthesized)
-- Applies to all entities, true for private and incomplete types
-- Is_Incomplete_Type (synthesized)
-- Applies to all entities, true for incomplete types and subtypes
-- Is_Independent (Flag268)
-- Defined in record components. Set if a valid pragma or aspect
-- Independent applies to the component, or if a valid pragma or aspect
-- Independent_Components applies to the enclosing record type.
-- Is_Inlined (Flag11)
-- Defined in all entities. Set for functions and procedures which are
-- to be inlined. For subprograms created during expansion, this flag
-- may be set directly by the expander to request inlining. Also set
-- for packages that contain inlined subprograms, whose bodies must be
-- be compiled. Is_Inlined is also set on generic subprograms and is
-- inherited by their instances. It is also set on the body entities
-- of inlined subprograms. See also Has_Pragma_Inline.
-- Is_Instantiated (Flag126)
-- Defined in generic packages and generic subprograms. Set if the unit
-- is instantiated from somewhere in the extended main source unit. This
-- flag is used to control warnings about the unit being uninstantiated.
-- Also set in a package that is used as an actual for a generic package
-- formal in an instantiation. Also set on a parent instance, in the
-- instantiation of a child, which is implicitly declared in the parent.
-- Is_Integer_Type (synthesized)
-- Applies to all entities, true for integer types and subtypes
-- Is_Interface (Flag186)
-- Defined in record types and subtypes. Set to indicate that the current
-- entity corresponds with an abstract interface. Because abstract
-- interfaces are conceptually a special kind of abstract tagged types
-- we represent them by means of tagged record types and subtypes
-- marked with this attribute. This allows us to reuse most of the
-- compiler support for abstract tagged types to implement interfaces
-- (Ada 2005: AI-251).
-- Is_Internal (Flag17)
-- Defined in all entities. Set to indicate an entity created during
-- semantic processing (e.g. an implicit type, or a temporary). The
-- current uses of this flag are:
--
-- 1) Internal entities (such as temporaries generated for the result
-- of an inlined function call or dummy variables generated for the
-- debugger). Set to indicate that they need not be initialized, even
-- when scalars are initialized or normalized;
--
-- 2) Predefined primitives of tagged types. Set to mark that they
-- have specific properties: first they are primitives even if they
-- are not defined in the type scope (the freezing point is not
-- necessarily in the same scope), and second the predefined equality
-- can be overridden by a user-defined equality, no body will be
-- generated in this case.
--
-- 3) Object declarations generated by the expander that are implicitly
-- imported or exported so that they can be marked in Sprint output.
--
-- 4) Internal entities in the list of primitives of tagged types that
-- are used to handle secondary dispatch tables. These entities have
-- also the attribute Interface_Alias.
-- Is_Interrupt_Handler (Flag89)
-- Defined in procedures. Set if a pragma Interrupt_Handler applies
-- to the procedure. The procedure must be parameterless, and on all
-- targets except AAMP it must be a protected procedure.
-- Is_Intrinsic_Subprogram (Flag64)
-- Defined in functions and procedures. It is set if a valid pragma
-- Interface or Import is present for this subprogram specifying pragma
-- Intrinsic. Valid means that the name and profile of the subprogram
-- match the requirements of one of the recognized intrinsic subprograms
-- (see package Sem_Intr for details). Note: the value of Convention for
-- such an entity will be set to Convention_Intrinsic, but it is the
-- setting of Is_Intrinsic_Subprogram, NOT simply having convention set
-- to intrinsic, which causes intrinsic code to be generated.
-- Is_Invariant_Procedure (Flag257)
-- Defined in functions an procedures. Set for a generated invariant
-- procedure to identify it easily in the
-- Is_Itype (Flag91)
-- Defined in all entities. Set to indicate that a type is an Itype,
-- which means that the declaration for the type does not appear
-- explicitly in the tree. Instead the backend will elaborate the type
-- when it is first used. Has_Delayed_Freeze can be set for Itypes, and
-- the meaning is that the first use (the one which causes the type to be
-- defined) will be the freeze node. Note that an important restriction
-- on Itypes is that the first use of such a type (the one that causes it
-- to be defined) must be in the same scope as the type.
-- Is_Known_Non_Null (Flag37)
-- Defined in all entities. Relevant (and can be set) only for
-- objects of an access type. It is set if the object is currently
-- known to have a non-null value (meaning that no access checks
-- are needed). The indication can for example come from assignment
-- of an access parameter or an allocator whose value is known non-null.
--
-- Note: this flag is set according to the sequential flow of the
-- program, watching the current value of the variable. However, this
-- processing can miss cases of changing the value of an aliased or
-- constant object, so even if this flag is set, it should not be
-- believed if the variable is aliased or volatile. It would be a
-- little neater to avoid the flag being set in the first place in
-- such cases, but that's trickier, and there is only one place that
-- tests the value anyway.
--
-- The flag is dynamically set and reset as semantic analysis and
-- expansion proceeds. Its value is meaningless once the tree is
-- fully constructed, since it simply indicates the last state.
-- Thus this flag has no meaning to the backend.
-- Is_Known_Null (Flag204)
-- Defined in all entities. Relevant (and can be set ) only for
-- objects of an access type. It is set if the object is currently known
-- to have a null value (meaning that a dereference will surely raise
-- constraint error exception). The indication can come from an
-- assignment or object declaration.
--
-- The comments above about sequential flow and aliased and volatile for
-- the Is_Known_Non_Null flag apply equally to the Is_Known_Null flag.
-- Is_Known_Valid (Flag170)
-- Defined in all entities. Relevant for types (and subtype) and
-- for objects (and enumeration literals) of a discrete type.
--
-- The purpose of this flag is to implement the requirement stated
-- in (RM 13.9.1(9-11)) which require that the use of possibly invalid
-- values may not cause programs to become erroneous. See the function
-- Checks.Expr_Known_Valid for further details. Note that the setting
-- is conservative, in the sense that if the flag is set, it must be
-- right. If the flag is not set, nothing is known about the validity.
--
-- For enumeration literals, the flag is always set, since clearly
-- an enumeration literal represents a valid value. Range checks
-- where necessary will ensure that this valid value is appropriate.
--
-- For objects, the flag indicates the state of knowledge about the
-- current value of the object. This may be modified during expansion,
-- and thus the final value is not relevant to the backend.
--
-- For types and subtypes, the flag is set if all possible bit patterns
-- of length Object_Size (i.e. Esize of the type) represent valid values
-- of the type. In general for such tytpes, all values are valid, the
-- only exception being the case where an object of the type has an
-- explicit size that is greater than Object_Size.
--
-- For non-discrete objects, the setting of the Is_Known_Valid flag is
-- not defined, and is not relevant, since the considerations of the
-- requirement in (RM 13.9.1(9-11)) do not apply.
--
-- The flag is dynamically set and reset as semantic analysis and
-- expansion proceeds. Its value is meaningless once the tree is
-- fully constructed, since it simply indicates the last state.
-- Thus this flag has no meaning to the backend.
-- Is_Limited_Composite (Flag106)
-- Defined in all entities. Set for composite types that have a limited
-- component. Used to enforce the rule that operations on the composite
-- type that depend on the full view of the component do not become
-- visible until the immediate scope of the composite type itself
-- (RM 7.3.1 (5)).
-- Is_Limited_Interface (Flag197)
-- Defined in record types and subtypes. True for interface types, if
-- interface is declared limited, task, protected, or synchronized, or
-- is derived from a limited interface.
-- Is_Limited_Record (Flag25)
-- Defined in all entities. Set to true for record (sub)types if the
-- record is declared to be limited. Note that this flag is not set
-- simply because some components of the record are limited.
-- Is_Local_Anonymous_Access (Flag194)
-- Defined in access types. Set for an anonymous access type to indicate
-- that the type is created for a record component with an access
-- definition, an array component, or (pre-Ada 2012) a standalone object.
-- Such anonymous types have an accessibility level equal to that of the
-- declaration in which they appear, unlike the anonymous access types
-- that are created for access parameters, access discriminants, and
-- (as of Ada 2012) stand-alone objects.
-- Is_Machine_Code_Subprogram (Flag137)
-- Defined in subprogram entities. Set to indicate that the subprogram
-- is a machine code subprogram (i.e. its body includes at least one
-- code statement). Also indicates that all necessary semantic checks
-- as required by RM 13.8(3) have been performed.
-- Is_Modular_Integer_Type (synthesized)
-- Applies to all entities. True if entity is a modular integer type
-- Is_Non_Static_Subtype (Flag109)
-- Defined in all type and subtype entities. It is set in some (but not
-- all) cases in which a subtype is known to be non-static. Before this
-- flag was added, the computation of whether a subtype was static was
-- entirely synthesized, by looking at the bounds, and the immediate
-- subtype parent. However, this method does not work for some Itypes
-- that have no parent set (and the only way to find the immediate
-- subtype parent is to go through the tree). For now, this flag is set
-- conservatively, i.e. if it is set then for sure the subtype is non-
-- static, but if it is not set, then the type may or may not be static.
-- Thus the test for a static subtype is that this flag is clear AND that
-- the bounds are static AND that the parent subtype (if available to be
-- tested) is static. Eventually we should make sure this flag is always
-- set right, at which point, these comments can be removed, and the
-- tests for static subtypes greatly simplified.
-- Is_Null_Init_Proc (Flag178)
-- Defined in procedure entities. Set for generated init proc procedures
-- (used to initialize composite types), if the code for the procedure
-- is null (i.e. is a return and nothing else). Such null initialization
-- procedures are generated in case some client is compiled using the
-- Initialize_Scalars pragma, generating a call to this null procedure,
-- but there is no need to call such procedures within a compilation
-- unit, and this flag is used to suppress such calls.
-- Is_Null_State (synthesized)
-- Applies to all entities, true for an abstract state declared with
-- keyword null.
-- Is_Numeric_Type (synthesized)
-- Applies to all entities, true for all numeric types and subtypes
-- (integer, fixed, float).
-- Is_Object (synthesized)
-- Applies to all entities, true for entities representing objects,
-- including generic formal parameters.
-- Is_Obsolescent (Flag153)
-- Defined in all entities. Set for any entity for which a valid pragma
-- Obsolescent applies.
-- Is_Only_Out_Parameter (Flag226)
-- Defined in formal parameter entities. Set if this parameter is the
-- only OUT parameter for this formal part. If there is more than one
-- out parameter, or if there is some other IN OUT parameter then this
-- flag is not set in any of them. Used in generation of warnings.
-- Is_Optional_Parameter (Flag134)
-- Defined in parameter entities. Set if the parameter is specified as
-- optional by use of a First_Optional_Parameter argument to one of the
-- extended Import pragmas. Can only be set for OpenVMS versions of GNAT.
-- Is_Ordinary_Fixed_Point_Type (synthesized)
-- Applies to all entities, true for ordinary fixed point types and
-- subtypes.
-- Is_Package_Or_Generic_Package (synthesized)
-- Applies to all entities. True for packages and generic packages.
-- False for all other entities.
-- Is_Package_Body_Entity (Flag160)
-- Defined in all entities. Set for entities defined at the top level
-- of a package body. Used to control externally generated names.
-- Is_Packed (Flag51) [implementation base type only]
-- Defined in all type entities. This flag is set only for record and
-- array types which have a packed representation. There are three
-- cases which cause packing:
--
-- 1. Explicit use of pragma Pack for an array of package components
-- 2. Explicit use of pragma Pack to pack a record
-- 4. Setting Component_Size of an array to a bit-packable value
-- 3. Indexing an array with a non-standard enumeration type.
--
-- For records, Is_Packed is always set if Has_Pragma_Pack is set,
-- and can also be set on its own in a derived type which inherited
-- its packed status.
--
-- For arrays, Is_Packed is set if an array is bit packed (i.e. the
-- component size is known at compile time and is 1-7, 9-15 or 17-31),
-- or if the array has one or more index types that are enumeration
-- types with non-standard representations (in GNAT, we store such
-- arrays compactly, using the Pos of the enumeration type value).
--
-- As for the case of records, Is_Packed can be set on its own for a
-- derived type, with the same dual before/after freeze meaning.
-- Is_Packed can also be set as the result of an explicit component
-- size clause that specifies an appropriate component size.
--
-- In the bit packed array case, Is_Bit_Packed_Array will be set in
-- the bit packed case once the array type is frozen.
--
-- Before an array type is frozen, Is_Packed will always be set if
-- Has_Pragma_Pack is set. Before the freeze point, it is not possible
-- to know the component size, since the component type is not frozen
-- until the array type is frozen. Thus Is_Packed for an array type
-- before it is frozen means that packed is required. Then if it turns
-- out that the component size is not suitable for bit packing, the
-- Is_Packed flag gets turned off.
-- Is_Packed_Array (synth)
-- Applies to all entities, true if entity is for a packed array.
-- Is_Packed_Array_Impl_Type (Flag138)
-- Defined in all entities. This flag is set on the entity for the type
-- used to implement a packed array (either a modular type, or a subtype
-- of Packed_Bytes{1,2,4} as appropriate). The flag is set if and only
-- if the type appears in the Packed_Array_Impl_Type field of some other
-- entity. It is used by the backend to activate the special processing
-- for such types (unchecked conversions that would not otherwise be
-- allowed are allowed for such types). If Is_Packed_Array_Impl_Type is
-- set in an entity, then the Original_Array_Type field of this entity
-- points to the array type for which this is the Packed_Array_Impl_Type.
-- Is_Potentially_Use_Visible (Flag9)
-- Defined in all entities. Set if entity is potentially use visible,
-- i.e. it is defined in a package that appears in a currently active
-- use clause (RM 8.4(8)). Note that potentially use visible entities
-- are not necessarily use visible (RM 8.4(9-11)).
-- Is_Predicate_Function (Flag255)
-- Present in functions and procedures. Set for generated predicate
-- functions.
-- Is_Predicate_Function_M (Flag256)
-- Present in functions and procedures. Set for special version of
-- predicate function generated for use in membership tests, where
-- raise expressions are transformed to return False.
-- Is_Preelaborated (Flag59)
-- Defined in all entities, set in E_Package and E_Generic_Package
-- entities to which a pragma Preelaborate is applied, and also in
-- all entities within such packages. Note that the fact that this
-- flag is set does not necesarily mean that no elaboration code is
-- generated for the package.
-- Is_Primitive (Flag218)
-- Defined in overloadable entities and in generic subprograms. Set to
-- indicate that this is a primitive operation of some type, which may
-- be a tagged type or a non-tagged type. Used to verify overriding
-- indicators in bodies.
-- Is_Primitive_Wrapper (Flag195)
-- Defined in functions and procedures created by the expander to serve
-- as an indirection mechanism to overriding primitives of concurrent
-- types, entries and protected procedures.
-- Is_Prival (synthesized)
-- Applies to all entities, true for renamings of private protected
-- components. Such entities appear as constants or variables.
-- Is_Private_Composite (Flag107)
-- Defined in composite types that have a private component. Used to
-- enforce the rule that operations on the composite type that depend
-- on the full view of the component, do not become visible until the
-- immediate scope of the composite type itself (7.3.1 (5)). Both this
-- flag and Is_Limited_Composite are needed.
-- Is_Private_Descendant (Flag53)
-- Defined in entities that can represent library units (packages,
-- functions, procedures). Set if the library unit is itself a private
-- child unit, or if it is the descendent of a private child unit.
-- Is_Private_Primitive (Flag245)
-- Defined in subprograms. Set if the operation is a primitive of a
-- tagged type (procedure or function dispatching on result) whose
-- full view has not been seen. Used in particular for primitive
-- subprograms of a synchronized type declared between the two views
-- of the type, so that the wrapper built for such a subprogram can
-- be given the proper signature.
-- Is_Private_Type (synthesized)
-- Applies to all entities, true for private types and subtypes,
-- as well as for record with private types as subtypes
-- Is_Processed_Transient (Flag252)
-- Defined in entities of variables and constants. Set when a transient
-- object needs to be finalized and it has already been processed by the
-- transient scope machinery. This flag signals the general finalization
-- mechanism to ignore the transient object.
-- Is_Protected_Component (synthesized)
-- Applicable to all entities, true if the entity denotes a private
-- component of a protected type.
-- Is_Protected_Interface (synthesized)
-- Defined in types that are interfaces. True if interface is declared
-- protected, or is derived from protected interfaces.
-- Is_Protected_Type (synthesized)
-- Applies to all entities, true for protected types and subtypes
-- Is_Public (Flag10)
-- Defined in all entities. Set to indicate that an entity defined in
-- one compilation unit can be referenced from other compilation units.
-- If this reference causes a reference in the generated variable, for
-- example in the case of a variable name, then the backend will generate
-- an appropriate external name for use by the linker.
-- Is_Protected_Record_Type (synthesized)
-- Applies to all entities, true if Is_Concurrent_Record_Type is true and
-- Corresponding_Concurrent_Type is a protected type.
-- Is_Pure (Flag44)
-- Defined in all entities. Set in all entities of a unit to which a
-- pragma Pure is applied except for non-intrinsic imported subprograms,
-- and also set for the entity of the unit itself. In addition, this
-- flag may be set for any other functions or procedures that are known
-- to be side effect free, so in the case of subprograms, the Is_Pure
-- flag may be used by the optimizer to imply that it can assume freedom
-- from side effects (other than those resulting from assignment to out
-- parameters, or to objects designated by access parameters).
-- Is_Pure_Unit_Access_Type (Flag189)
-- Defined in access type and subtype entities. Set if the type or
-- subtype appears in a pure unit. Used to give an error message at
-- freeze time if the access type has a storage pool.
-- Is_RACW_Stub_Type (Flag244)
-- Defined in all types, true for the stub types generated for remote
-- access-to-class-wide types.
-- Is_Raised (Flag224)
-- Defined in exception entities. Set if the entity is referenced by a
-- a raise statement.
-- Is_Real_Type (synthesized)
-- Applies to all entities, true for real types and subtypes
-- Is_Record_Type (synthesized)
-- Applies to all entities, true for record types and subtypes,
-- includes class-wide types and subtypes (which are also records)
-- Is_Remote_Call_Interface (Flag62)
-- Defined in all entities. Set in E_Package and E_Generic_Package
-- entities to which a pragma Remote_Call_Interface is applied, and
-- also on entities declared in the visible part of such a package.
-- Is_Remote_Types (Flag61)
-- Defined in all entities. Set in E_Package and E_Generic_Package
-- entities to which a pragma Remote_Types is applied, and also on
-- entities declared in the visible part of the spec of such a package.
-- Also set for types which are generic formal types to which the
-- pragma Remote_Access_Type applies.
-- Is_Renaming_Of_Object (Flag112)
-- Defined in all entities, set only for a variable or constant for
-- which the Renamed_Object field is non-empty and for which the
-- renaming is handled by the front end, by macro substitution of
-- a copy of the (evaluated) name tree whereever the variable is used.
-- Is_Return_Object (Flag209)
-- Defined in all object entities. True if the object is the return
-- object of an extended_return_statement; False otherwise.
-- Is_Safe_To_Reevaluate (Flag249)
-- Defined in all entities. Set in variables that are initialized by
-- means of an assignment statement. When initialized their contents
-- never change and hence they can be seen by the backend as constants.
-- See also Is_True_Constant.
-- Is_Scalar_Type (synthesized)
-- Applies to all entities, true for scalar types and subtypes
-- Is_Shared_Passive (Flag60)
-- Defined in all entities. Set in E_Package and E_Generic_Package
-- entities to which a pragma Shared_Passive is applied, and also in
-- all entities within such packages.
-- Is_Standard_Character_Type (synthesized)
-- Applies to all entities, true for types and subtypes whose root type
-- is one of the standard character types (Character, Wide_Character,
-- Wide_Wide_Character).
-- Is_Statically_Allocated (Flag28)
-- Defined in all entities. This can only be set for exception,
-- variable, constant, and type/subtype entities. If the flag is set,
-- then the variable or constant must be allocated statically rather
-- than on the local stack frame. For exceptions, the meaning is that
-- the exception data should be allocated statically (and indeed this
-- flag is always set for exceptions, since exceptions do not have
-- local scope). For a type, the meaning is that the type must be
-- elaborated at the global level rather than locally. No type marked
-- with this flag may depend on a local variable, or on any other type
-- which does not also have this flag set to True. For a variable or
-- or constant, if the flag is set, then the type of the object must
-- either be declared at the library level, or it must also have the
-- flag set (since to allocate the object statically, its type must
-- also be elaborated globally).
-- Is_String_Type (synthesized)
-- Applies to all type entities. Determines if the given type is a
-- string type, i.e. it is directly a string type or string subtype,
-- or a string slice type, or an array type with one dimension and a
-- component type that is a character type.
-- Is_Subprogram (synthesized)
-- Applies to all entities, true for function, procedure and operator
-- entities.
-- Is_Synchronized_Interface (synthesized)
-- Defined in types that are interfaces. True if interface is declared
-- synchronized, task, or protected, or is derived from a synchronized
-- interface.
-- Is_Tag (Flag78)
-- Defined in E_Component and E_Constant entities. For regular tagged
-- type this flag is set on the tag component (whose name is Name_uTag).
-- For CPP_Class tagged types, this flag marks the pointer to the main
-- vtable (i.e. the one to be extended by derivation).
-- Is_Tagged_Type (Flag55)
-- Defined in all entities. Set for an entity for a tagged type.
-- Is_Task_Interface (synthesized)
-- Defined in types that are interfaces. True if interface is declared as
-- a task interface, or if it is derived from task interfaces.
-- Is_Task_Record_Type (synthesized)
-- Applies to all entities. True if Is_Concurrent_Record_Type
-- Corresponding_Concurrent_Type is a task type.
-- Is_Task_Type (synthesized)
-- Applies to all entities. True for task types and subtypes
-- Is_Thunk (Flag225)
-- Defined in all entities. True for subprograms that are thunks: that is
-- small subprograms built by the expander for tagged types that cover
-- interface types. As part of the runtime call to an interface, thunks
-- displace the pointer to the object (pointer named "this" in the C++
-- terminology) from a secondary dispatch table to the primary dispatch
-- table associated with a given tagged type; if the thunk is a function
-- that returns an object which covers an interface type then the thunk
-- displaces the pointer to the object from the primary dispatch table to
-- the secondary dispatch table associated with the interface type. Set
-- by Expand_Interface_Thunk and used by Expand_Call to handle extra
-- actuals associated with accessibility level.
-- Is_Trivial_Subprogram (Flag235)
-- Defined in all entities. Set in subprograms where either the body
-- consists of a single null statement, or the first or only statement
-- of the body raises an exception. This is used for suppressing certain
-- warnings, see Sem_Ch6.Analyze_Subprogram_Body discussion for details.
-- Is_True_Constant (Flag163)
-- Defined in all entities for constants and variables. Set in constants
-- and variables which have an initial value specified but which are
-- never assigned, partially or in the whole. For variables, it means
-- that the variable was initialized but never modified, and hence can be
-- treated as a constant by the code generator. For a constant, it means
-- that the constant was not modified by generated code (e.g. to set a
-- discriminant in an init proc). Assignments by user or generated code
-- will reset this flag. See also Is_Safe_To_Reevaluate.
-- Is_Type (synthesized)
-- Applies to all entities, true for a type entity
-- Is_Unchecked_Union (Flag117) [implementation base type only]
-- Defined in all entities. Set only in record types to which the
-- pragma Unchecked_Union has been validly applied.
-- Is_Underlying_Record_View (Flag246) [base type only]
-- Defined in all entities. Set only in record types that represent the
-- underlying record view. This view is built for derivations of types
-- with unknown discriminants; it is a record with the same structure
-- as its corresponding record type, but whose parent is the full view
-- of the parent in the original type extension.
-- Is_Unsigned_Type (Flag144)
-- Defined in all types, but can be set only for discrete and fixed-point
-- type and subtype entities. This flag is only valid if the entity is
-- frozen. If set it indicates that the representation is known to be
-- unsigned (i.e. that no negative values appear in the range). This is
-- normally just a reflection of the lower bound of the subtype or base
-- type, but there is one case in which the setting is non-obvious,
-- namely the case of an unsigned subtype of a signed type from which
-- a further subtype is obtained using variable bounds. This further
-- subtype is still unsigned, but this cannot be determined by looking
-- at its bounds or the bounds of the corresponding base type.
-- Is_Valued_Procedure (Flag127)
-- Defined in procedure entities. Set if an Import_Valued_Procedure
-- or Export_Valued_Procedure pragma applies to the procedure entity.
-- Is_Visible_Formal (Flag206)
-- Defined in all entities. Set for instances of the formals of a
-- formal package. Indicates that the entity must be made visible in the
-- body of the instance, to reproduce the visibility of the generic.
-- This simplifies visibility settings in instance bodies.
-- Is_Visible_Lib_Unit (Flag116)
-- Defined in all (root or child) library unit entities. Once compiled,
-- library units remain chained to the entities in the parent scope, and
-- a separate flag must be used to indicate whether the names are visible
-- by selected notation, or not.
-- Is_VMS_Exception (Flag133)
-- Defined in all entities. Set only for exception entities where the
-- exception was specified in an Import_Exception or Export_Exception
-- pragma with the VMS option for Form. See description of these pragmas
-- for details. This flag can only be set in OpenVMS versions of GNAT.
-- Is_Volatile (Flag16)
-- Defined in all type entities, and also in constants, components and
-- variables. Set if a pragma Volatile applies to the entity. Also set
-- if pragma Shared or pragma Atomic applies to entity. In the case of
-- private or incomplete types, this flag is set in both the private
-- and full view. The flag is not set reliably on private subtypes,
-- and is always retrieved from the base type (but this is not a base-
-- type-only attribute because it applies to other entities). Note that
-- the backend should use Treat_As_Volatile, rather than Is_Volatile
-- to indicate code generation requirements for volatile variables.
-- Similarly, any front end test which is concerned with suppressing
-- optimizations on volatile objects should test Treat_As_Volatile
-- rather than testing this flag.
-- Is_Wrapper_Package (synthesized)
-- Defined in package entities. Indicates that the package has been
-- created as a wrapper for a subprogram instantiation.
-- Itype_Printed (Flag202)
-- Defined in all type and subtype entities. Set in Itypes if the Itype
-- has been printed by Sprint. This is used to avoid printing an Itype
-- more than once.
-- Kill_Elaboration_Checks (Flag32)
-- Defined in all entities. Set by the expander to kill elaboration
-- checks which are known not to be needed. Equivalent in effect to
-- the use of pragma Suppress (Elaboration_Checks) for that entity
-- except that the effect is permanent and cannot be undone by a
-- subsequent pragma Unsuppress.
-- Kill_Range_Checks (Flag33)
-- Defined in all entities. Equivalent in effect to the use of pragma
-- Suppress (Range_Checks) for that entity except that the result is
-- permanent and cannot be undone by a subsequent pragma Unsuppress.
-- This is currently only used in one odd situation in Sem_Ch3 for
-- record types, and it would be good to get rid of it???
-- Known_To_Have_Preelab_Init (Flag207)
-- Defined in all type and subtype entities. If set, then the type is
-- known to have preelaborable initialization. In the case of a partial
-- view of a private type, it is only possible for this to be set if a
-- pragma Preelaborable_Initialization is given for the type. For other
-- types, it is never set if the type does not have preelaborable
-- initialization, it may or may not be set if the type does have
-- preelaborable initialization.
-- Last_Aggregate_Assignment (Node30)
-- Applies to controlled constants and variables initialized by an
-- aggregate. Points to the last statement associated with the expansion
-- of the aggregate. The attribute is used by the finalization machinery
-- when marking an object as successfully initialized.
-- Last_Assignment (Node26)
-- Defined in entities for variables, and OUT or IN OUT formals. Set for
-- a local variable or formal to point to the left side of an assignment
-- statement assigning a value to the variable. Cleared if the value of
-- the entity is referenced. Used to warn about dubious assignment
-- statements whose value is not used.
-- Last_Entity (Node20)
-- Defined in all entities which act as scopes to which a list of
-- associated entities is attached (blocks, class subtypes and types,
-- entries, functions, loops, packages, procedures, protected objects,
-- record types and subtypes, private types, task types and subtypes).
-- Points to the last entry in the list of associated entities chained
-- through the Next_Entity field. Empty if no entities are chained.
-- Last_Formal (synthesized)
-- Applies to subprograms and subprogram types, and also in entries
-- and entry families. Returns last formal of the subprogram or entry.
-- The formals are the first entities declared in a subprogram or in
-- a subprogram type (the designated type of an Access_To_Subprogram
-- definition) or in an entry.
-- Limited_View (Node23)
-- Defined in non-generic package entities that are not instances. Bona
-- fide package with the limited-view list through the first_entity and
-- first_private attributes. The elements of this list are the shadow
-- entities created for the types and local packages that are declared
-- in a package appearing in a limited_with clause (Ada 2005: AI-50217).
-- Linker_Section_Pragma (Node33)
-- Present in constant, variable, type and subprogram entities. Points
-- to a linker section pragma that applies to the entity, or is Empty if
-- no such pragma applies. Note that for constants and variables, this
-- field may be set as a result of a linker section pragma applied to the
-- type of the object.
-- Lit_Indexes (Node15)
-- Defined in enumeration types and subtypes. Non-empty only for the
-- case of an enumeration root type, where it contains the entity for
-- the generated indexes entity. See unit Exp_Imgv for full details of
-- the nature and use of this entity for implementing the Image and
-- Value attributes for the enumeration type in question.
-- Lit_Strings (Node16)
-- Defined in enumeration types and subtypes. Non-empty only for the
-- case of an enumeration root type, where it contains the entity for
-- the literals string entity. See unit Exp_Imgv for full details of
-- the nature and use of this entity for implementing the Image and
-- Value attributes for the enumeration type in question.
-- Low_Bound_Tested (Flag205)
-- Defined in all entities. Currently this can only be set for formal
-- parameter entries of a standard unconstrained one-dimensional array
-- or string type. Indicates that an explicit test of the low bound of
-- the formal appeared in the code, e.g. in a pragma Assert. If this
-- flag is set, warnings about assuming the index low bound to be one
-- are suppressed.
-- Machine_Radix_10 (Flag84)
-- Defined in decimal types and subtypes, set if the Machine_Radix is 10,
-- as the result of the specification of a machine radix representation
-- clause. Note that it is possible for this flag to be set without
-- having Has_Machine_Radix_Clause True. This happens when a type is
-- derived from a type with a clause present.
-- Master_Id (Node17)
-- Defined in access types and subtypes. Empty unless Has_Task is
-- set for the designated type, in which case it points to the entity
-- for the Master_Id for the access type master. Also set for access-to-
-- limited-class-wide types whose root may be extended with task
-- components, and for access-to-limited-interfaces because they can be
-- used to reference tasks implementing such interface.
-- Materialize_Entity (Flag168)
-- Defined in all entities. Set only for renamed obects which should be
-- materialized for debugging purposes. This means that a memory location
-- containing the renamed address should be allocated. This is needed so
-- that the debugger can find the entity.
-- May_Inherit_Delayed_Rep_Aspects (Flag262)
-- Defined in all entities for types and subtypes. Set if the type is
-- derived from a type which has delayed rep aspects (marked by the flag
-- Has_Delayed_Rep_Aspects being set). In this case, at the freeze point
-- for the derived type we know that the parent type is frozen, and if
-- a given attribute has not been set for the derived type, we copy the
-- value from the parent type. See Freeze.Inherit_Delayed_Rep_Aspects.
-- Mechanism (Uint8) (returned as Mechanism_Type)
-- Defined in functions and non-generic formal parameters. Indicates
-- the mechanism to be used for the function return or for the formal
-- parameter. See full description in the spec of Sem_Mech. This field
-- is also set (to the default value of zero = Default_Mechanism) in a
-- subprogram body entity but not used in this context.
-- Modulus (Uint17) [base type only]
-- Defined in modular types. Contains the modulus. For the binary 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)
-- Defined 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 backend ensures that record packing does not
-- violate this rule. Currently the flag is set only for packed arrays
-- longer than 64 bits where the component size is not a power of 2.
-- Must_Have_Preelab_Init (Flag208)
-- Defined in entities for types and subtypes. Set in the full type of a
-- private type or subtype if a pragma Has_Preelaborable_Initialization
-- is present for the private type. Used to check that the full type has
-- preelaborable initialization at freeze time (this has to be deferred
-- to the freeze point because of the rule about overriding Initialize).
-- Needs_Debug_Info (Flag147)
-- Defined in all entities. Set if the entity requires normal debugging
-- information to be generated. This is true of all entities that have
-- Comes_From_Source set, and also transitively for entities associated
-- with such components (e.g. their types). It is true for all entities
-- in Debug_Generated_Code mode (-gnatD switch). This is the flag that
-- the backend should check to determine whether or not to generate
-- debugging information for an entity. Note that callers should always
-- use Sem_Util.Set_Debug_Info_Needed, rather than Set_Needs_Debug_Info,
-- so that the flag is set properly on subsidiary entities.
-- Needs_No_Actuals (Flag22)
-- Defined in callable entities (subprograms, entries, access to
-- subprograms) which can be called without actuals because all of
-- their formals (if any) have default values. This flag simplifies the
-- resolution of the syntactic ambiguity involving a call to these
-- entities when the return type is an array type, and a call can be
-- interpreted as an indexing of the result of the call. It is also
-- used to resolve various cases of entry calls.
-- Never_Set_In_Source (Flag115)
-- Defined in all entities, but can be set only for variables and
-- parameters. This flag is set if the object is never assigned a value
-- in user source code, either by assignment or by being used as an out
-- or in out parameter. Note that this flag is not reset from using an
-- initial value, so if you want to test for this case as well, test the
-- Has_Initial_Value flag also.
--
-- This flag is only for the purposes of issuing warnings, it must not
-- be used by the code generator to indicate that the variable is in
-- fact a constant, since some assignments in generated code do not
-- count (for example, the call to an init proc to assign some but
-- not all of the fields in a partially initialized record). The code
-- generator should instead use the flag Is_True_Constant.
--
-- For the purposes of this warning, the default assignment of
-- access variables to null is not considered the assignment of
-- of a value (so the warning can be given for code that relies
-- on this initial null value, when no other value is ever set).
--
-- In variables and out parameters, if this flag is set after full
-- processing of the corresponding declarative unit, it indicates that
-- the variable or parameter was never set, and a warning message can
-- be issued.
--
-- Note: this flag is initially set, and then cleared on encountering
-- any construct that might conceivably legitimately set the value.
-- Thus during the analysis of a declarative region and its associated
-- statement sequence, the meaning of the flag is "not set yet", and
-- once this analysis is complete the flag means "never assigned".
-- Note: for variables appearing in package declarations, this flag
-- is never set. That is because there is no way to tell if some
-- client modifies the variable (or in the case of variables in the
-- private part, if some child unit modifies the variables).
-- Note: in the case of renamed objects, the flag must be set in the
-- ultimate renamed object. Clients noting a possible modification
-- should use the Note_Possible_Modification procedure in Sem_Util
-- rather than Set_Never_Set_In_Source precisely to deal properly with
-- the renaming possibility.
-- Next_Component (synthesized)
-- Applies to record components. Returns the next component by following
-- the chain of declared entities until one is found which corresponds to
-- a component (Ekind is E_Component). Any internal types generated from
-- the subtype indications of the record components are skipped. Returns
-- Empty if no more components.
-- Next_Component_Or_Discriminant (synthesized)
-- Similar to Next_Component, but includes components and discriminants
-- so the input can have either E_Component or E_Discriminant, and the
-- same is true for the result. Returns Empty if no more components or
-- discriminants in the record.
-- Next_Discriminant (synthesized)
-- Applies to discriminants returned by First/Next_Discriminant.
-- Returns the next language-defined (ie: perhaps non-girder)
-- discriminant by following the chain of declared entities as long as
-- the kind of the entity corresponds to a discriminant. Note that the
-- discriminants might be the only components of the record.
-- Returns Empty if there are no more.
-- Next_Entity (Node2)
-- Defined in all entities. The entities of a scope are chained, with
-- the head of the list being in the First_Entity field of the scope
-- entity. All entities use the Next_Entity field as a forward pointer
-- for this list, with Empty indicating the end of the list. Since this
-- field is in the base part of the entity, the access routines for this
-- field are in Sinfo.
-- Next_Formal (synthesized)
-- Applies to the entity for a formal parameter. Returns the next
-- formal parameter of the subprogram or subprogram type. Returns
-- Empty if there are no more formals.
-- Next_Formal_With_Extras (synthesized)
-- Applies to the entity for a formal parameter. Returns the next
-- formal parameter of the subprogram or subprogram type. Returns
-- Empty if there are no more formals. The list returned includes
-- all the extra formals (see description of Extra_Formal field)
-- Next_Index (synthesized)
-- Applies to array types and subtypes and to string types and
-- subtypes. Yields the next index. The first index is obtained by
-- using the First_Index attribute, and then subsequent indexes are
-- obtained by applying Next_Index to the previous index. Empty is
-- returned to indicate that there are no more indexes. Note that
-- unlike most attributes in this package, Next_Index applies to
-- nodes for the indexes, not to entities.
-- Next_Inlined_Subprogram (Node12)
-- Defined in subprograms. Used to chain inlined subprograms used in
-- the current compilation, in the order in which they must be compiled
-- by the backend to insure that all inlinings are performed.
-- Next_Literal (synthesized)
-- Applies to enumeration literals, returns the next literal, or
-- Empty if applied to the last literal. This is actually a synonym
-- for Next, but its use is preferred in this context.
-- Non_Binary_Modulus (Flag58) [base type only]
-- Defined in all subtype and type entities. Set for modular integer
-- types if the modulus value is other than a power of 2.
-- Non_Limited_View (Node17)
-- Defined in abstract states and incomplete types that act as shadow
-- entities created when analysing a limited with clause (Ada 2005:
-- AI-50217). Points to the defining entity of the original declaration.
-- Nonzero_Is_True (Flag162) [base type only]
-- Defined in enumeration types. Set if any non-zero value is to be
-- interpreted as true. Currently this is set for derived Boolean
-- types which have a convention of C, C++ or Fortran.
-- No_Pool_Assigned (Flag131) [root type only]
-- Defined in access types. Set if a storage size clause applies to the
-- variable with a static expression value of zero. This flag is used to
-- generate errors if any attempt is made to allocate or free an instance
-- of such an access type. This is set only in the root type, since
-- derived types must have the same pool.
-- No_Return (Flag113)
-- Defined in all entities. Always false except in the case of procedures
-- and generic procedures for which a pragma No_Return is given.
-- Normalized_First_Bit (Uint8)
-- Defined in components and discriminants. Indicates the normalized
-- value of First_Bit for the component, i.e. the offset within the
-- lowest addressed storage unit containing part or all of the field.
-- Set to No_Uint if no first bit position is assigned yet.
-- Normalized_Position (Uint14)
-- Defined in components and discriminants. Indicates the normalized
-- value of Position for the component, i.e. the offset in storage
-- units from the start of the record to the lowest addressed storage
-- unit containing part or all of the field.
-- Normalized_Position_Max (Uint10)
-- Defined in components and discriminants. For almost all cases, this
-- is the same as Normalized_Position. The one exception is for the case
-- of a discriminated record containing one or more arrays whose length
-- depends on discriminants. In this case, the Normalized_Position_Max
-- field represents the maximum possible value of Normalized_Position
-- assuming min/max values for discriminant subscripts in all fields.
-- This is used by Layout in front end layout mode to properly computed
-- the maximum size such records (needed for allocation purposes when
-- there are default discriminants, and also for the 'Size value).
-- No_Strict_Aliasing (Flag136) [base type only]
-- Defined in access types. Set to direct the backend to avoid any
-- optimizations based on an assumption about the aliasing status of
-- objects designated by the access type. For the case of the gcc
-- backend, the effect is as though all references to objects of
-- the type were compiled with -fno-strict-aliasing. This flag is
-- set if an unchecked conversion with the access type as a target
-- type occurs in the same source unit as the declaration of the
-- access type, or if an explicit pragma No_Strict_Aliasing applies.
-- Number_Dimensions (synthesized)
-- Applies to array types and subtypes. Returns the number of dimensions
-- of the array type or subtype as a value of type Pos.
-- Number_Entries (synthesized)
-- Applies to concurrent types. Returns the number of entries that are
-- declared within the task or protected definition for the type.
-- Number_Formals (synthesized)
-- Applies to subprograms and subprogram types. Yields the number of
-- formals as a value of type Pos.
-- OK_To_Rename (Flag247)
-- Defined only in entities for variables. If this flag is set, it
-- means that if the entity is used as the initial value of an object
-- declaration, the object declaration can be safely converted into a
-- renaming to avoid an extra copy. This is set for variables which are
-- generated by the expander to hold the result of evaluating some
-- expression. Most notably, the local variables used to store the result
-- of concatenations are so marked (see Exp_Ch4.Expand_Concatenate). It
-- is only worth setting this flag for composites, since for primitive
-- types, it is cheaper to do the copy.
-- OK_To_Reorder_Components (Flag239) [base type only]
-- Defined in record types. Set if the backend is permitted to reorder
-- the components. If not set, the record must be layed out in the order
-- in which the components are declared textually. Currently this flag
-- can only be set by debug switches.
-- Optimize_Alignment_Space (Flag241)
-- Defined in type, subtype, variable, and constant entities. This
-- flag records that the type or object is to be layed out in a manner
-- consistent with Optimize_Alignment (Space) mode. The compiler and
-- binder ensure a consistent view of any given type or object. If pragma
-- Optimize_Alignment (Off) mode applies to the type/object, then neither
-- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set.
-- Optimize_Alignment_Time (Flag242)
-- Defined in type, subtype, variable, and constant entities. This
-- flag records that the type or object is to be layed out in a manner
-- consistent with Optimize_Alignment (Time) mode. The compiler and
-- binder ensure a consistent view of any given type or object. If pragma
-- Optimize_Alignment (Off) mode applies to the type/object, then neither
-- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set.
-- Original_Access_Type (Node26)
-- Defined in E_Access_Subprogram_Type entities. Set only if the access
-- type was generated by the expander as part of processing an access
-- to protected subprogram type. Points to the access to protected
-- subprogram type.
-- Original_Array_Type (Node21)
-- Defined in modular types and array types and subtypes. Set only if
-- the Is_Packed_Array_Impl_Type flag is set, indicating that the type
-- is the implementation type for a packed array, and in this case it
-- points to the original array type for which this is the packed
-- array implementation type.
-- Original_Record_Component (Node22)
-- Defined in components, including discriminants. The usage depends
-- on whether the record is a base type and whether it is tagged.
--
-- In base tagged types:
-- When the component is inherited in a record extension, it points
-- to the original component (the entity of the ancestor component
-- which is not itself inherited) otherwise it points to itself. The
-- backend uses this attribute to implement the automatic dereference
-- in the extension and to apply the transformation:
--
-- Rec_Ext.Comp -> Rec_Ext.Parent. ... .Parent.Comp
--
-- In base non-tagged types:
-- Always points to itself except for non-girder discriminants, where
-- it points to the girder discriminant it renames.
--
-- In subtypes (tagged and untagged):
-- Points to the component in the base type.
-- Overlays_Constant (Flag243)
-- Defined in all entities. Set only for a variable for which there is
-- an address clause which causes the variable to overlay a constant.
-- Overridden_Operation (Node26)
-- Defined in subprograms. For overriding operations, points to the
-- user-defined parent subprogram that is being overridden. Note: this
-- attribute uses the same field as Static_Initialization. The latter
-- is only defined for internal initialization procedures, for which
-- Overridden_Operation is irrelevant. Thus this attribute must not be
-- set for init_procs.
-- Package_Instantiation (Node26)
-- Defined in packages and generic packages. When defined, this field
-- references an N_Generic_Instantiation node associated with an
-- instantiated package. In the case where the referenced node has
-- been rewritten to an N_Package_Specification, the instantiation
-- node is available from the Original_Node field of the package spec
-- node. This is currently not guaranteed to be set in all cases, but
-- when set, the field is used in Get_Package_Instantiation_Node as
-- one of the means of obtaining the instantiation node. Eventually
-- it should be set in all cases, including package entities associated
-- with formal packages. ???
-- Packed_Array_Impl_Type (Node23)
-- Defined in array types and subtypes, including the string literal
-- subtype case, if the corresponding type is packed (either bit packed
-- or packed to eliminate holes in non-contiguous enumeration type index
-- types). References the type used to represent the packed array, which
-- is either a modular type for short static arrays, or an array of
-- System.Unsigned. Note that in some situations (internal types, and
-- references to fields of variant records), it is not always possible
-- to construct this type in advance of its use. If this field is empty,
-- then the necessary type is declared on the fly for each reference to
-- the array.
-- Parameter_Mode (synthesized)
-- Applies to formal parameter entities. This is a synonym for Ekind,
-- used when obtaining the formal kind of a formal parameter (the result
-- is one of E_[In/Out/In_Out]_Parameter)
-- Parent_Subtype (Node19) [base type only]
-- Defined in E_Record_Type. Set only for derived tagged types, in which
-- case it points to the subtype of the parent type. This is the type
-- that is used as the Etype of the _parent field.
-- Part_Of_Constituents (Elist9)
-- Present in abstract state entities. Contains all constituents that are
-- subject to indicator Part_Of (both aspect and option variants).
-- Postcondition_Proc (Node8)
-- Defined only in procedure entities, saves the entity of the generated
-- postcondition proc if one is present, otherwise is set to Empty. Used
-- to generate the call to this procedure in case the expander inserts
-- implicit return statements.
-- PPC_Wrapper (Node25)
-- Defined in entries and entry families. Set only if pre- or post-
-- conditions are present. The precondition_wrapper body is the original
-- entry call, decorated with the given precondition for the entry.
-- Predicate_Function (synthesized)
-- Defined in all types. Set for types for which (Has_Predicates is True)
-- and for which a predicate procedure has been built that tests that the
-- specified predicates are True. Contains the entity for the function
-- which takes a single argument of the given type, and returns True if
-- the predicate holds and False if it does not.
--
-- Note: the reason this is marked as a synthesized attribute is that the
-- way this is stored is as an element of the Subprograms_For_Type field.
-- Predicate_Function_M (synthesized)
-- Defined in all types. Present only if Predicate_Function is present,
-- and only if the predicate function has Raise_Expression nodes. It
-- is the special version created for membership tests, where if one of
-- these raise expressions is executed, the result is to return False.
-- Primitive_Operations (synthesized)
-- Defined in concurrent types, tagged record types and subtypes, tagged
-- private types and tagged incomplete types. For concurrent types whose
-- Corresponding_Record_Type (CRT) is available, returns the list of
-- Direct_Primitive_Operations of its CRT; otherwise returns No_Elist.
-- For all the other types returns the Direct_Primitive_Operations.
-- Prival (Node17)
-- Defined in private components of protected types. Refers to the entity
-- of the component renaming declaration generated inside protected
-- subprograms, entries or barrier functions.
-- Prival_Link (Node20)
-- Defined in constants and variables which rename private components of
-- protected types. Set to the original private component.
-- Private_Dependents (Elist18)
-- Defined in private (sub)types. Records the subtypes of the private
-- type, derivations from it, and records and arrays with components
-- dependent on the type.
--
-- The subtypes are traversed when installing and deinstalling (the full
-- view of) a private type in order to ensure correct view of the
-- subtypes.
--
-- Used in similar fashion for incomplete types: holds list of subtypes
-- of these incomplete types that have discriminant constraints. The
-- full views of these subtypes are constructed when the full view of
-- the incomplete type is processed.
-- In addition, if the incomplete type is the designated type in an
-- access definition for an access parameter, the operation may be
-- a dispatching primitive operation, which is only known when the full
-- declaration of the type is seen. Subprograms that have such an
-- access parameter are also placed in the list of private_dependents.
-- Private_View (Node22)
-- For each private type, three entities are allocated, the private view,
-- the full view, and the shadow entity. The shadow entity contains a
-- copy of the private view and is used for restoring the proper private
-- view after a region in which the full view is visible (and is copied
-- into the entity normally used for the private view during this period
-- of visibility). The Private_View field is self-referential when the
-- private view lives in its normal entity, but in the copy that is made
-- in the shadow entity, it points to the proper location in which to
-- restore the private view saved in the shadow.
-- Protected_Formal (Node22)
-- Defined in formal parameters (in, in out and out parameters). Used
-- only for formals of protected operations. References corresponding
-- formal parameter in the unprotected version of the operation that
-- is created during expansion.
-- Protected_Body_Subprogram (Node11)
-- Defined in protected operations. References the entity for the
-- subprogram which implements the body of the operation.
-- Protection_Object (Node23)
-- Applies to protected entries, entry families and subprograms. Denotes
-- the entity which is used to rename the _object component of protected
-- types.
-- Reachable (Flag49)
-- Defined in labels. The flag is set over the range of statements in
-- which a goto to that label is legal.
-- Referenced (Flag156)
-- Defined in all entities. Set if the entity is referenced, except for
-- the case of an appearance of a simple variable that is not a renaming
-- as the left side of an assignment in which case Referenced_As_LHS is
-- set instead, or a similar appearance as an out parameter actual, in
-- which case Referenced_As_Out_Parameter is set.
-- Referenced_As_LHS (Flag36):
-- Defined in all entities. This flag is set instead of Referenced if a
-- simple variable that is not a renaming appears as the left side of an
-- assignment. The reason we distinguish this kind of reference is that
-- we have a separate warning for variables that are only assigned and
-- never read.
-- Referenced_As_Out_Parameter (Flag227):
-- Defined in all entities. This flag is set instead of Referenced if a
-- simple variable that is not a renaming appears as an actual for an out
-- formal. The reason we distinguish this kind of reference is that
-- we have a separate warning for variables that are only assigned and
-- never read, and out parameters are a special case.
-- Refinement_Constituents (Elist8)
-- Present in abstract state entities. Contains all the constituents that
-- refine the state, in other words, all the hidden states that appear in
-- the constituent_list of aspect/pragma Refined_State.
-- Register_Exception_Call (Node20)
-- Defined in exception entities. When an exception is declared,
-- a call is expanded to Register_Exception. This field points to
-- the expanded N_Procedure_Call_Statement node for this call. It
-- is used for Import/Export_Exception processing to modify the
-- register call to make appropriate entries in the special tables
-- used for handling these pragmas at runtime.
-- Related_Array_Object (Node25)
-- Defined in array types and subtypes. Used only for the base type
-- and subtype created for an anonymous array object. Set to point
-- to the entity of the corresponding array object. Currently used
-- only for type-related error messages.
-- Related_Expression (Node24)
-- Defined in variables and types. When Set for internally generated
-- entities, it may be used to denote the source expression whose
-- elaboration created the variable declaration. If set, it is used
-- for generating clearer messages from CodePeer. It is used on source
-- entities that are variables in iterator specifications, to provide
-- a link to the container that is the domain of iteration. This allows
-- for better cross-reference information when the loop modifies elements
-- of the container, and suppresses spurious warnings.
--
-- Shouldn't it also be used for the same purpose in errout? It seems
-- odd to have two mechanisms here???
-- Related_Instance (Node15)
-- Defined in the wrapper packages created for subprogram instances.
-- The internal subprogram that implements the instance is inside the
-- wrapper package, but for debugging purposes its external symbol
-- must correspond to the name and scope of the related instance.
-- Related_Type (Node27)
-- Defined in components, constants and variables. Set when there is an
-- associated dispatch table to point to entities containing primary or
-- secondary tags. Not set in the _tag component of record types.
-- Relative_Deadline_Variable (Node26) [implementation base type only]
-- Defined in task type entities. This flag is set if a valid and
-- effective pragma Relative_Deadline applies to the base type. Points
-- to the entity for a variable that is created to hold the value given
-- in a Relative_Deadline pragma for a task type.
-- Renamed_Entity (Node18)
-- Defined in exceptions, packages, subprograms, and generic units. Set
-- for entities that are defined by a renaming declaration. Denotes the
-- renamed entity, or transitively the ultimate renamed entity if
-- there is a chain of renaming declarations. Empty if no renaming.
-- Renamed_In_Spec (Flag231)
-- Defined in package entities. If a package renaming occurs within
-- a package spec, then this flag is set on the renamed package. The
-- purpose is to prevent a warning about unused entities in the renamed
-- package. Such a warning would be inappropriate since clients of the
-- package can see the entities in the package via the renaming.
-- Renamed_Object (Node18)
-- Defined in all objects (constants, variables, components, formal
-- parameters, generic formal parameters, and loop parameters).
-- ??? Defined in discriminants?
-- Set non-Empty if the object was declared by a renaming declaration,
-- in which case it references the tree node for the name of the renamed
-- object. This is only possible for the variable and constant cases.
-- For formal parameters, this field is used in the course of inline
-- expansion, to map the formals of a subprogram into the corresponding
-- actuals. For formals of a task entry, it denotes the local renaming
-- that replaces the actual within the accept statement. The field is
-- Empty otherwise (it is always empty for loop parameters).
-- Renaming_Map (Uint9)
-- Defined in generic subprograms, generic packages, and their
-- instances. Also defined in the instances of the corresponding
-- bodies. Denotes the renaming map (generic entities => instance
-- entities) used to construct the instance by givin an index into
-- the tables used to represent these maps. See Sem_Ch12 for further
-- details. The maps for package instances are also used when the
-- instance is the actual corresponding to a formal package.
-- Requires_Overriding (Flag213)
-- Defined in all subprograms and entries. Set for subprograms that
-- require overriding as defined by RM-2005-3.9.3(6/2). Note that this
-- is True only for implicitly declare subprograms; it is not set on the
-- parent type's subprogram. See also Is_Abstract_Subprogram.
-- Return_Present (Flag54)
-- Defined in function and generic function entities. Set if the
-- function contains a return statement (used for error checking).
-- This flag can also be set in procedure and generic procedure
-- entities (for convenience in setting it), but is only tested
-- for the function case.
-- Return_Applies_To (Node8)
-- Defined in E_Return_Statement. Points to the entity representing
-- the construct to which the return statement applies, as defined in
-- RM-6.5(4/2). Note that a (simple) return statement within an
-- extended_return_statement applies to the extended_return_statement,
-- even though it causes the whole function to return.
-- Returns_By_Ref (Flag90)
-- Defined in function entities, to indicate that the function
-- returns the result by reference, either because its return type is a
-- by-reference-type or because it uses explicitly the secondary stack.
-- Reverse_Bit_Order (Flag164) [base type only]
-- Defined in all record type entities. Set if entity has a Bit_Order
-- aspect (set by an aspect clause or attribute definition clause) that
-- has reversed the order of bits from the default value. When this flag
-- is set, a component clause must specify a set of bits entirely within
-- a single storage unit (Ada 95) or within a single machine scalar (see
-- Ada 2005 AI-133), or must occupy an integral number of storage units.
-- Reverse_Storage_Order (Flag93) [base type only]
-- Defined in all record and array type entities. Set if entity has a
-- Scalar_Storage_Order aspect (set by an aspect clause or attribute
-- definition clause) that has reversed the order of storage elements
-- from the default value. When this flag is set for a record type,
-- the Bit_Order aspect must be set to the same value (either explicitly
-- or as the target default value).
-- RM_Size (Uint13)
-- Defined in all type and subtype entities. Contains the value of
-- type'Size as defined in the RM. See also the Esize field and
-- and the description on "Handling of Type'Size Values". A value
-- of zero in this field for a non-discrete type means that
-- the front end has not yet determined the size value. For the
-- case of a discrete type, this field is always set by the front
-- end and zero is a legitimate value for a type with one value.
-- Root_Type (synthesized)
-- Applies to all type entities. For class-wide types, return the root
-- type of the class covered by the CW type, otherwise returns the
-- ultimate derivation ancestor of the given type. This function
-- preserves the view, i.e. the Root_Type of a partial view is the
-- partial view of the ultimate ancestor, the Root_Type of a full view
-- is the full view of the ultimate ancestor. Note that this function
-- does not correspond exactly to the use of root type in the RM, since
-- in the RM root type applies to a class of types, not to a type.
-- Scalar_Range (Node20)
-- Defined in all scalar types (including modular types, where the
-- bounds are 0 .. modulus - 1). References a node in the tree that
-- contains the bounds for the range. Note that this information
-- could be obtained by rummaging around the tree, but it is more
-- convenient to have it immediately at hand in the entity. The
-- contents of Scalar_Range can either be an N_Subtype_Indication
-- node (with a constraint), or a Range node, but not a simple
-- subtype reference (a subtype is converted into a range).
-- Scale_Value (Uint15)
-- Defined in decimal fixed-point types and subtypes. Contains the scale
-- for the type (i.e. the value of type'Scale = the number of decimal
-- digits after the decimal point).
-- Scope (Node3)
-- Defined in all entities. Points to the entity for the scope (block,
-- loop, subprogram, package etc.) in which the entity is declared.
-- Since this field is in the base part of the entity node, the access
-- routines for this field are in Sinfo. Note that for a child package,
-- the Scope will be the parent package, and for a non-child package,
-- the Scope will be Standard.
-- Scope_Depth (synthesized)
-- Applies to program units, blocks, concurrent types and entries, and
-- also to record types, i.e. to any entity that can appear on the scope
-- stack. Yields the scope depth value, which for those entities other
-- than records is simply the scope depth value, for record entities, it
-- is the Scope_Depth of the record scope.
-- Scope_Depth_Value (Uint22)
-- Defined in program units, blocks, concurrent types, and entries.
-- Indicates the number of scopes that statically enclose the declaration
-- of the unit or type. Library units have a depth of zero. Note that
-- record types can act as scopes but do NOT have this field set (see
-- Scope_Depth above)
-- Scope_Depth_Set (synthesized)
-- Applies to a special predicate function that returns a Boolean value
-- indicating whether or not the Scope_Depth field has been set. It is
-- needed, since returns an invalid value in this case.
-- Sec_Stack_Needed_For_Return (Flag167)
-- Defined in scope entities (blocks, functions, procedures, tasks,
-- entries). Set to True when secondary stack is used to hold the
-- returned value of a function and thus should not be released on
-- scope exit.
-- Shadow_Entities (List14)
-- Defined in package and generic package entities. Points to a list
-- of entities that correspond to private types. For each private type
-- a shadow entity is created that holds a copy of the private view.
-- In regions of the program where the full views of these private
-- entities are visible, the full view is copied into the entity that
-- is normally used to hold the private view, but the shadow entity
-- copy is unchanged. The shadow entities are then used to restore the
-- original private views at the end of the region. This list is a
-- standard format list (i.e. First (Shadow_Entities) is the first
-- entry and subsequent entries are obtained using Next.
-- Shared_Var_Procs_Instance (Node22)
-- Defined in variables. Set non-Empty only if Is_Shared_Passive is
-- set, in which case this is the entity for the associated instance of
-- System.Shared_Storage.Shared_Var_Procs. See Exp_Smem for full details.
-- Size_Check_Code (Node19)
-- Defined in constants and variables. Normally Empty. Set if code is
-- generated to check the size of the object. This field is used to
-- suppress this code if a subsequent address clause is encountered.
-- Size_Clause (synthesized)
-- Applies to all entities. If a size clause is present in the rep
-- item chain for an entity then the attribute definition clause node
-- for the size clause is returned. Otherwise Size_Clause returns Empty
-- if no item is present. Usually this is only meaningful if the flag
-- Has_Size_Clause is set. This is because when the representation item
-- chain is copied for a derived type, it can inherit a size clause that
-- is not applicable to the entity.
-- Size_Depends_On_Discriminant (Flag177)
-- Defined in all entities for types and subtypes. Indicates that the
-- size of the type depends on the value of one or more discriminants.
-- Currently, this flag is only set for arrays which have one or more
-- bounds depending on a discriminant value.
-- Size_Known_At_Compile_Time (Flag92)
-- Defined in all entities for types and subtypes. Indicates that the
-- size of objects of the type is known at compile time. This flag is
-- used to optimize some generated code sequences, and also to enable
-- some error checks (e.g. disallowing component clauses on variable
-- length objects). It is set conservatively (i.e. if it is True, the
-- size is certainly known at compile time, if it is False, then the
-- size may or may not be known at compile time, but the code will
-- assume that it is not known).
-- Small_Value (Ureal21)
-- Defined in fixed point types. Points to the universal real for the
-- Small of the type, either as given in a representation clause, or
-- as computed (as a power of two) by the compiler.
-- SPARK_Aux_Pragma (Node33)
-- Present in package spec and body entities. For a package spec entity
-- it relates to the SPARK mode setting for the private part. This field
-- points to the N_Pragma node that applies to the private part. This is
-- either set with a local SPARK_Mode pragma in the private part or it is
-- inherited from the SPARK mode that applies to the rest of the spec.
-- For a package body, it similarly applies to the SPARK mode setting for
-- the elaboration sequence after the BEGIN. In the case where the pragma
-- is inherited, the SPARK_Aux_Pragma_Inherited flag is set in the
-- package spec or body entity.
-- SPARK_Aux_Pragma_Inherited (Flag266)
-- Present in the entities of subprogram specs and bodies as well as
-- in package specs and bodies. Set if the SPARK_Aux_Pragma field
-- points to a pragma that is inherited, rather than a local one.
-- SPARK_Pragma (Node32)
-- Present in the entities of subprogram specs and bodies as well as in
-- package specs and bodies. Points to the N_Pragma node that applies to
-- the spec or body. This is either set by a local SPARK_Mode pragma or
-- is inherited from the context (from an outer scope for the spec case
-- or from the spec for the body case). In the case where it is inherited
-- the flag SPARK_Pragma_Inherited is set. Empty if no SPARK_Mode pragma
-- is applicable.
-- SPARK_Pragma_Inherited (Flag265)
-- Present in the entities of subprogram specs and bodies as well as in
-- package specs and bodies. Set if the SPARK_Pragma field points to a
-- pragma that is inherited, rather than a local one.
-- Spec_Entity (Node19)
-- Defined in package body entities. Points to corresponding package
-- spec entity. Also defined in subprogram body parameters in the
-- case where there is a separate spec, where this field references
-- the corresponding parameter entities in the spec.
-- SSO_Set_High_By_Default (Flag273) [base type only]
-- Defined for record and array types. Set in the base type if a pragma
-- Default_Scalar_Storage_Order (High_Order_First) was active at the time
-- the record or array was declared and therefore applies to it.
-- SSO_Set_Low_By_Default (Flag272) [base type only]
-- Defined for record and array types. Set in the base type if a pragma
-- Default_Scalar_Storage_Order (High_Order_First) was active at the time
-- the record or array was declared and therefore applies to it.
-- Static_Discrete_Predicate (List25)
-- Defined in discrete types/subtypes with static predicates (with the
-- two flags Has_Predicates and Has_Static_Predicate set). Set if the
-- type/subtype has a static predicate. Points to a list of expression
-- and N_Range nodes that represent the predicate in canonical form. The
-- canonical form has entries sorted in ascending order, with duplicates
-- eliminated, and adjacent ranges coalesced, so that there is always a
-- gap in the values between successive entries. The entries in this list
-- are fully analyzed and typed with the base type of the subtype. Note
-- that all entries are static and have values within the subtype range.
-- Static_Real_Or_String_Predicate (Node25)
-- Defined in real types/subtypes with static predicates (with the two
-- flags Has_Predicates and Has_Static_Predicate set). Set if the type
-- or subtype has a static predicate. Points to the return expression
-- of the predicate function. This is the original expression given as
-- the predicate except that occurrences of the type are replaced by
-- occurrences of the formal parameter of the predicate function (note
-- that the spec of this function including this formal parameter name)
-- is available from the Subprograms_For_Type field (it can be accessed
-- as Predicate_Function (typ). Also, in the case where a predicate is
-- inherited, the expression is of the form:
--
-- expression AND THEN xxxPredicate (typ2 (ent))
--
-- where typ2 is the type from which the predicate is inherited, ent is
-- the entity for the current predicate function, and xxxPredicate is the
-- inherited predicate (from typ2). Finally for a predicate that inherits
-- from another predicate but does not add a predicate of its own, the
-- expression may consist of the above xxxPredicate call on its own.
-- Status_Flag_Or_Transient_Decl (Node15)
-- Defined in variables and constants. Applies to objects that require
-- special treatment by the finalization machinery, such as extended
-- return results, IF and CASE expression results, and objects inside
-- N_Expression_With_Actions nodes. The attribute contains the entity
-- of a flag which specifies particular behavior over a region of code
-- or the declaration of a "hook" object.
-- In which case is it a flag, or a hook object???
-- Static_Elaboration_Desired (Flag77)
-- Defined in library-level packages. Set by the pragma of the same
-- name, to indicate that static initialization must be attempted for
-- all types declared in the package, and that a warning must be emitted
-- for those types to which static initialization is not available.
-- Static_Initialization (Node30)
-- Defined in initialization procedures for types whose objects can be
-- initialized statically. The value of this attribute is a positional
-- aggregate whose components are compile-time static values. Used
-- when available in object declarations to eliminate the call to the
-- initialization procedure, and to minimize elaboration code. Note:
-- This attribute uses the same field as Overridden_Operation, which is
-- irrelevant in init_procs.
-- Storage_Size_Variable (Node15) [implementation base type only]
-- Defined in access types and task type entities. This flag is set
-- if a valid and effective pragma Storage_Size applies to the base
-- type. Points to the entity for a variable that is created to
-- hold the value given in a Storage_Size pragma for an access
-- collection or a task type. Note that in the access type case,
-- this field is defined only in the root type (since derived types
-- share the same storage pool).
-- Stored_Constraint (Elist23)
-- Defined in entities that can have discriminants (concurrent types
-- subtypes, record types and subtypes, private types and subtypes,
-- limited private types and subtypes and incomplete types). Points
-- to an element list containing the expressions for each of the
-- stored discriminants for the record (sub)type.
-- Stores_Attribute_Old_Prefix (Flag270)
-- Defined in constants. Set when the constant has been generated to save
-- the value of attribute 'Old's prefix.
-- Strict_Alignment (Flag145) [implementation base type only]
-- Defined in all type entities. Indicates that some containing part
-- is either aliased or tagged. This prohibits packing the object
-- tighter than its natural size and alignment.
-- String_Literal_Length (Uint16)
-- Defined in string literal subtypes (which are created to correspond
-- to string literals in the program). Contains the length of the string
-- literal.
-- String_Literal_Low_Bound (Node15)
-- Defined in string literal subtypes (which are created to correspond
-- to string literals in the program). Contains an expression whose
-- value represents the low bound of the literal. This is a copy of
-- the low bound of the applicable index constraint if there is one,
-- or a copy of the low bound of the index base type if not.
-- Subprograms_For_Type (Node29)
-- Defined in all type and subprogram entities. This is used to hold
-- a list of subprogram entities for subprograms associated with the
-- type, linked through the Subprograms_For_Type field of the subprogram
-- entity. Basically this is a way of multiplexing the single field to
-- hold more than one entity (since we ran out of space in some type
-- entities). This is currently used for Invariant_Procedure and also
-- for Predicate_Function, and clients will always use the latter two
-- names to access entries in this list.
-- Suppress_Elaboration_Warnings (Flag148)
-- Defined in all entities, can be set only for subprogram entities and
-- for variables. If this flag is set then Sem_Elab will not generate
-- elaboration warnings for the subprogram or variable. Suppression of
-- such warnings is automatic for subprograms for which elaboration
-- checks are suppressed (without the need to set this flag), but the
-- flag is also set for various internal entities (such as init procs)
-- which are known not to generate any possible access before
-- elaboration, and it is set on variables when a warning is given to
-- avoid multiple elaboration warnings for the same variable.
-- Suppress_Initialization (Flag105)
-- Defined in all type and subtype entities. If set for the base type,
-- then the generation of initialization procedures is suppressed for the
-- type. Any other implicit initialiation (e.g. from the use of pragma
-- Initialize_Scalars) is also suppressed if this flag is set either for
-- the subtype in question, or for the base type. Set by use of pragma
-- Suppress_Initialization and also for internal entities where we know
-- that no initialization is required. For example, enumeration image
-- table entities set it.
-- Suppress_Style_Checks (Flag165)
-- Defined in all entities. Suppresses any style checks specifically
-- associated with the given entity if set.
-- Suppress_Value_Tracking_On_Call (Flag217)
-- Defined in all entities. Set in a scope entity if value tracking is to
-- be suppressed on any call within the scope. Used when an access to a
-- local subprogram is computed, to deal with the possibility that this
-- value may be passed around, and if used, may clobber a local variable.
-- Task_Body_Procedure (Node25)
-- Defined in task types and subtypes. Points to the entity for the task
-- task body procedure (as further described in Exp_Ch9, task bodies are
-- expanded into procedures). A convenient function to retrieve this
-- field is Sem_Util.Get_Task_Body_Procedure.
--
-- The last sentence is odd??? Why not have Task_Body_Procedure go to the
-- Underlying_Type of the Root_Type???
-- Thunk_Entity (Node31)
-- Defined in functions and procedures which have been classified as
-- Is_Thunk. Set to the target entity called by the thunk.
-- Treat_As_Volatile (Flag41)
-- Defined in all type entities, and also in constants, components and
-- variables. Set if this entity is to be treated as volatile for code
-- generation purposes. Always set if Is_Volatile is set, but can also
-- be set as a result of situations (such as address overlays) where
-- the front end wishes to force volatile handling to inhibit aliasing
-- optimization which might be legally ok, but is undesirable. Note
-- that the backend always tests this flag rather than Is_Volatile.
-- The front end tests Is_Volatile if it is concerned with legality
-- checks associated with declared volatile variables, but if the test
-- is for the purposes of suppressing optimizations, then the front
-- end should test Treat_As_Volatile rather than Is_Volatile.
--
-- Note: before testing Treat_As_Volatile, consider whether it would
-- be more appropriate to use Exp_Util.Is_Volatile_Reference instead,
-- which catches more cases of volatile references.
-- Type_High_Bound (synthesized)
-- Applies to scalar types. Returns the tree node (Node_Id) that contains
-- the high bound of a scalar type. The returned value is literal for a
-- base type, but may be an expression in the case of scalar type with
-- dynamic bounds. Note that in the case of a fixed point type, the high
-- bound is in units of small, and is an integer.
-- Type_Low_Bound (synthesized)
-- Applies to scalar types. Returns the tree node (Node_Id) that contains
-- the low bound of a scalar type. The returned value is literal for a
-- base type, but may be an expression in the case of scalar type with
-- dynamic bounds. Note that in the case of a fixed point type, the low
-- bound is in units of small, and is an integer.
-- Underlying_Full_View (Node19)
-- Defined in private subtypes that are the completion of other private
-- types, or in private types that are derived from private subtypes. If
-- the full view of a private type T is derived from another private type
-- with discriminants Td, the full view of T is also private, and there
-- is no way to attach to it a further full view that would convey the
-- structure of T to the backend. The Underlying_Full_ View is an
-- attribute of the full view that is a subtype of Td with the same
-- constraint as the declaration for T. The declaration for this subtype
-- is built at the point of the declaration of T, either as completion,
-- or as a subtype declaration where the base type is private and has a
-- private completion. If Td is already constrained, then its full view
-- can serve directly as the full view of T.
-- Underlying_Record_View (Node28)
-- Defined in record types. Set for record types that are extensions of
-- types with unknown discriminants, and also set for internally built
-- underlying record views to reference its original record type. Record
-- types that are extensions of types with unknown discriminants do not
-- have a completion, but they cannot be used without having some
-- discriminated view at hand. This view is a record type with the same
-- structure, whose parent type is the full view of the parent in the
-- original type extension.
-- Underlying_Type (synthesized)
-- Applies to all entities. This is the identity function except in the
-- case where it is applied to an incomplete or private type, in which
-- case it is the underlying type of the type declared by the completion,
-- or Empty if the completion has not yet been encountered and analyzed.
--
-- Note: the reason this attribute applies to all entities, and not just
-- types, is to legitimize code where Underlying_Type is applied to an
-- entity which may or may not be a type, with the intent that if it is a
-- type, its underlying type is taken.
--
-- Note also that the value of this attribute is interesting only after
-- the full view of the parent type has been processed. If the parent
-- type is declared in an enclosing package, the attribute will be non-
-- trivial only after the full view of the type has been analyzed.
-- Universal_Aliasing (Flag216) [implementation base type only]
-- Defined in all type entities. Set to direct the back-end to avoid
-- any optimizations based on type-based alias analysis for this type.
-- Indicates that objects of this type can alias objects of any other
-- types, which guarantees that any objects can be referenced through
-- access types designating this type safely, whatever the actual type
-- of these objects. In other words, the effect is as though access
-- types designating this type were subject to No_Strict_Aliasing.
-- Unset_Reference (Node16)
-- Defined in variables and out parameters. This is normally Empty. It
-- is set to point to an identifier that represents a reference to the
-- entity before any value has been set. Only the first such reference
-- is identified. This field is used to generate a warning message if
-- necessary (see Sem_Warn.Check_Unset_Reference).
-- Used_As_Generic_Actual (Flag222)
-- Defined in all entities, set if the entity is used as an argument to
-- a generic instantiation. Used to tune certain warning messages.
-- Uses_Lock_Free (Flag188)
-- Defined in protected type entities. Set to True when the Lock Free
-- implementation is used for the protected type. This implemenatation is
-- based on atomic transactions and doesn't require anymore the use of
-- Protection object (see System.Tasking.Protected_Objects).
-- Uses_Sec_Stack (Flag95)
-- Defined in scope entities (block, entry, function, loop, procedure,
-- task). Set to True when secondary stack is used in this scope and must
-- be released on exit unless Sec_Stack_Needed_For_Return is set.
-- Warnings_Off (Flag96)
-- Defined in all entities. Set if a pragma Warnings (Off, entity-name)
-- is used to suppress warnings for a given entity. It is also used by
-- the compiler in some situations to kill spurious warnings. Note that
-- clients should generally not test this flag directly, but instead
-- use function Has_Warnings_Off.
-- Warnings_Off_Used (Flag236)
-- Defined in all entities. Can only be set if Warnings_Off is set. If
-- set indicates that a warning was suppressed by the Warnings_Off flag,
-- and Unmodified/Unreferenced would not have suppressed the warning.
-- Warnings_Off_Used_Unmodified (Flag237)
-- Defined in all entities. Can only be set if Warnings_Off is set and
-- Has_Pragma_Unmodified is not set. If set indicates that a warning was
-- suppressed by the Warnings_Off status but that pragma Unmodified
-- would also have suppressed the warning.
-- Warnings_Off_Used_Unreferenced (Flag238)
-- Defined in all entities. Can only be set if Warnings_Off is set and
-- Has_Pragma_Unreferenced is not set. If set indicates that a warning
-- was suppressed by the Warnings_Off status but that pragma Unreferenced
-- would also have suppressed the warning.
-- Was_Hidden (Flag196)
-- Defined in all entities. Used to save the value of the Is_Hidden
-- attribute when the limited-view is installed (Ada 2005: AI-217).
-- Wrapped_Entity (Node27)
-- Defined in functions and procedures which have been classified as
-- Is_Primitive_Wrapper. Set to the entity being wrapper.
---------------------------
-- Renaming and Aliasing --
---------------------------
-- Several entity attributes relate to renaming constructs, and to the use of
-- different names to refer to the same entity. The following is a summary of
-- these constructs and their prefered uses.
-- There are three related attributes:
-- Renamed_Entity
-- Renamed_Object
-- Alias
-- They all overlap because they are supposed to apply to different entity
-- kinds. They are semantically related, and have the following intended uses:
-- a) Renamed_Entity appplies to entities in renaming declarations that rename
-- an entity, so the value of the attribute IS an entity. This applies to
-- generic renamings, package renamings, exception renamings, and subprograms
-- renamings that rename a subprogram (rather than an attribute, an entry, a
-- protected operation, etc).
-- b) Alias applies to overloadable entities, and the value is an overloadable
-- entity. so this is a subset of the previous one. We use the term Alias to
-- cover both renamings and inherited operations, because both cases are
-- handled in the same way when expanding a call. namely the Alias of a given
-- subprogram is the subprogram that will actually be called.
-- Both a) and b) are set transitively, so that in fact it is not necessary to
-- traverse chains of renamings when looking for the original entity: it's
-- there in one step (this is done when analyzing renaming declarations other
-- than object renamings in sem_ch8).
-- c) Renamed_Object applies to constants and variables. Given that the name
-- in an object renaming declaration is not necessarily an entity name, the
-- value of the attribute is the tree for that name, eg AR (1).Comp. The case
-- when that name is in fact an entity is not handled specially. This is why
-- in a few cases we need to use a loop to trace a chain of object renamings
-- where all of them happen to be entities. So:
-- X : integer;
-- Y : integer renames X; -- renamed object is the identifier X
-- Z : integer renames Y; -- renamed object is the identifier Y
-- The front-end does not store explicitly the fact that Z renames X.
--------------------------------------
-- Delayed Freezing and Elaboration --
--------------------------------------
-- The flag Has_Delayed_Freeze indicates that an entity carries an explicit
-- freeze node, which appears later in the expanded tree.
-- a) The flag is used by the front-end to trigger expansion actions
-- which include the generation of that freeze node. Typically this happens at
-- the end of the current compilation unit, or before the first subprogram
-- body is encountered in the current unit. See files freeze and exp_ch13 for
-- details on the actions triggered by a freeze node, which include the
-- construction of initialization procedures and dispatch tables.
-- b) The flag is used by the backend to defer elaboration of the entity until
-- its freeze node is seen. In the absence of an explicit freeze node, an
-- entity is frozen (and elaborated) at the point of declaration.
-- For object declarations, the flag is set when an address clause for the
-- object is encountered. Legality checks on the address expression only
-- take place at the freeze point of the object.
-- Most types have an explicit freeze node, because they cannot be elaborated
-- until all representation and operational items that apply to them have been
-- analyzed. Private types and incomplete types have the flag set as well, as
-- do task and protected types.
-- Implicit base types created for type derivations, as well as classwide
-- types created for all tagged types, have the flag set.
-- If a subprogram has an access parameter whose designated type is incomplete
-- the subprogram has the flag set.
------------------
-- Access Kinds --
------------------
-- The following entity kinds are introduced by the corresponding type
-- definitions:
-- E_Access_Type,
-- E_General_Access_Type,
-- E_Access_Subprogram_Type,
-- E_Anonymous_Access_Subprogram_Type,
-- E_Access_Protected_Subprogram_Type,
-- E_Anonymous_Access_Protected_Subprogram_Type
-- E_Anonymous_Access_Type.
-- E_Access_Subtype is for an access subtype created by a subtype
-- declaration.
-- In addition, we define the kind E_Allocator_Type to label allocators.
-- This is because special resolution rules apply to this construct.
-- Eventually the constructs are labeled with the access type imposed by
-- the context. The backend should never see types with this Ekind.
-- Similarly, the type E_Access_Attribute_Type is used as the initial kind
-- associated with an access attribute. After resolution a specific access
-- type will be established as determined by the context.
-- Finally, the type Any_Access is used to label -null- during type
-- resolution. Any_Access is also replaced by the context type after
-- resolution.
--------------------------------
-- Classification of Entities --
--------------------------------
-- The classification of program entities which follows is a refinement of
-- the list given in RM 3.1(1). E.g., separate entities denote subtypes of
-- different type classes. Ada 95 entities include class wide types,
-- protected types, subprogram types, generalized access types, generic
-- formal derived types and generic formal packages.
-- The order chosen for these kinds allows us to classify related entities
-- so that they are contiguous. As a result, they do not appear in the
-- exact same order as their order of first appearance in the LRM (For
-- example, private types are listed before packages). The contiguity
-- allows us to define useful subtypes (see below) such as type entities,
-- overloaded entities, etc.
-- Each entity (explicitly or implicitly declared) has a kind, which is
-- a value of the following type:
type Entity_Kind is (
E_Void,
-- The initial Ekind value for a newly created entity. Also used as the
-- Ekind for Standard_Void_Type, a type entity in Standard used as a
-- dummy type for the return type of a procedure (the reason we create
-- this type is to share the circuits for performing overload resolution
-- on calls).
-------------
-- Objects --
-------------
E_Component,
-- Components of a record declaration, private declarations of
-- protected objects.
E_Constant,
-- Constants created by an object declaration with a constant keyword
E_Discriminant,
-- A discriminant, created by the use of a discriminant in a type
-- declaration.
E_Loop_Parameter,
-- A loop parameter created by a for loop
E_Variable,
-- Variables created by an object declaration with no constant keyword
------------------------
-- Parameter Entities --
------------------------
-- Parameters are also objects
E_Out_Parameter,
-- An out parameter of a subprogram or entry
E_In_Out_Parameter,
-- An in-out parameter of a subprogram or entry
E_In_Parameter,
-- An in parameter of a subprogram or entry
--------------------------------
-- Generic Parameter Entities --
--------------------------------
-- Generic parameters are also objects
E_Generic_In_Out_Parameter,
-- A generic in out parameter, created by the use of a generic in out
-- parameter in a generic declaration.
E_Generic_In_Parameter,
-- A generic in parameter, created by the use of a generic in
-- parameter in a generic declaration.
-------------------
-- Named Numbers --
-------------------
E_Named_Integer,
-- Named numbers created by a number declaration with an integer value
E_Named_Real,
-- Named numbers created by a number declaration with a real value
-----------------------
-- Enumeration Types --
-----------------------
E_Enumeration_Type,
-- Enumeration types, created by an enumeration type declaration
E_Enumeration_Subtype,
-- Enumeration subtypes, created by an explicit or implicit subtype
-- declaration applied to an enumeration type or subtype.
-------------------
-- Numeric Types --
-------------------
E_Signed_Integer_Type,
-- Signed integer type, used for the anonymous base type of the
-- integer subtype created by an integer type declaration.
E_Signed_Integer_Subtype,
-- Signed integer subtype, created by either an integer subtype or
-- integer type declaration (in the latter case an integer type is
-- created for the base type, and this is the first named subtype).
E_Modular_Integer_Type,
-- Modular integer type, used for the anonymous base type of the
-- integer subtype created by a modular integer type declaration.
E_Modular_Integer_Subtype,
-- Modular integer subtype, created by either an modular subtype
-- or modular type declaration (in the latter case a modular type
-- is created for the base type, and this is the first named subtype).
E_Ordinary_Fixed_Point_Type,
-- Ordinary fixed type, used for the anonymous base type of the
-- fixed subtype created by an ordinary fixed point type declaration.
E_Ordinary_Fixed_Point_Subtype,
-- Ordinary fixed point subtype, created by either an ordinary fixed
-- point subtype or ordinary fixed point type declaration (in the
-- latter case a fixed point type is created for the base type, and
-- this is the first named subtype).
E_Decimal_Fixed_Point_Type,
-- Decimal fixed type, used for the anonymous base type of the decimal
-- fixed subtype created by an ordinary fixed point type declaration.
E_Decimal_Fixed_Point_Subtype,
-- Decimal fixed point subtype, created by either a decimal fixed point
-- subtype or decimal fixed point type declaration (in the latter case
-- a fixed point type is created for the base type, and this is the
-- first named subtype).
E_Floating_Point_Type,
-- Floating point type, used for the anonymous base type of the
-- floating point subtype created by a floating point type declaration.
E_Floating_Point_Subtype,
-- Floating point subtype, created by either a floating point subtype
-- or floating point type declaration (in the latter case a floating
-- point type is created for the base type, and this is the first
-- named subtype).
------------------
-- Access Types --
------------------
E_Access_Type,
-- An access type created by an access type declaration with no all
-- keyword present. Note that the predefined type Any_Access, which
-- has E_Access_Type Ekind, is used to label NULL in the upwards pass
-- of type analysis, to be replaced by the true access type in the
-- downwards resolution pass.
E_Access_Subtype,
-- An access subtype created by a subtype declaration for any access
-- type (whether or not it is a general access type).
E_Access_Attribute_Type,
-- An access type created for an access attribute (such as 'Access,
-- 'Unrestricted_Access and Unchecked_Access)
E_Allocator_Type,
-- A special internal type used to label allocators and references to
-- objects using 'Reference. This is needed because special resolution
-- rules apply to these constructs. On the resolution pass, this type
-- is almost always replaced by the actual access type, but if the
-- context does not provide one, the backend will see Allocator_Type
-- itself (which will already have been frozen).
E_General_Access_Type,
-- An access type created by an access type declaration with the all
-- keyword present.
E_Access_Subprogram_Type,
-- An access to subprogram type, created by an access to subprogram
-- declaration.
E_Anonymous_Access_Subprogram_Type,
-- An anonymous access to subprogram type, created by an access to
-- subprogram declaration, or generated for a current instance of
-- a type name appearing within a component definition that has an
-- anonymous access to subprogram type.
E_Access_Protected_Subprogram_Type,
-- An access to a protected subprogram, created by the corresponding
-- declaration. Values of such a type denote both a protected object
-- and a protected operation within, and have different compile-time
-- and run-time properties than other access to subprograms.
E_Anonymous_Access_Protected_Subprogram_Type,
-- An anonymous access to protected subprogram type, created by an
-- access to subprogram declaration.
E_Anonymous_Access_Type,
-- An anonymous access type created by an access parameter or access
-- discriminant.
---------------------
-- Composite Types --
---------------------
E_Array_Type,
-- An array type created by an array type declaration. Includes all
-- cases of arrays, except for string types.
E_Array_Subtype,
-- An array subtype, created by an explicit array subtype declaration,
-- or the use of an anonymous array subtype.
E_String_Type,
E_String_Subtype,
-- These are obsolete and not used any more, they are retained to ease
-- transition in getting rid of these obsolete entries.
E_String_Literal_Subtype,
-- A special string subtype, used only to describe the type of a string
-- literal (will always be one dimensional, with literal bounds).
E_Class_Wide_Type,
-- A class wide type, created by any tagged type declaration (i.e. if
-- a tagged type is declared, the corresponding class type is always
-- created, using this Ekind value).
E_Class_Wide_Subtype,
-- A subtype of a class wide type, created by a subtype declaration
-- used to declare a subtype of a class type.
E_Record_Type,
-- A record type, created by a record type declaration
E_Record_Subtype,
-- A record subtype, created by a record subtype declaration
E_Record_Type_With_Private,
-- Used for types defined by a private extension declaration, and
-- for tagged private types. Includes the fields for both private
-- types and for record types (with the sole exception of
-- Corresponding_Concurrent_Type which is obviously not needed).
-- This entity is considered to be both a record type and
-- a private type.
E_Record_Subtype_With_Private,
-- A subtype of a type defined by a private extension declaration
E_Private_Type,
-- A private type, created by a private type declaration
-- that has neither the keyword limited nor the keyword tagged.
E_Private_Subtype,
-- A subtype of a private type, created by a subtype declaration used
-- to declare a subtype of a private type.
E_Limited_Private_Type,
-- A limited private type, created by a private type declaration that
-- has the keyword limited, but not the keyword tagged.
E_Limited_Private_Subtype,
-- A subtype of a limited private type, created by a subtype declaration
-- used to declare a subtype of a limited private type.
E_Incomplete_Type,
-- An incomplete type, created by an incomplete type declaration
E_Incomplete_Subtype,
-- An incomplete subtype, created by a subtype declaration where the
-- subtype mark denotes an incomplete type.
E_Task_Type,
-- A task type, created by a task type declaration. An entity with this
-- Ekind is also created to describe the anonymous type of a task that
-- is created by a single task declaration.
E_Task_Subtype,
-- A subtype of a task type, created by a subtype declaration used to
-- declare a subtype of a task type.
E_Protected_Type,
-- A protected type, created by a protected type declaration. An entity
-- with this Ekind is also created to describe the anonymous type of
-- a protected object created by a single protected declaration.
E_Protected_Subtype,
-- A subtype of a protected type, created by a subtype declaration used
-- to declare a subtype of a protected type.
-----------------
-- Other Types --
-----------------
E_Exception_Type,
-- The type of an exception created by an exception declaration
E_Subprogram_Type,
-- This is the designated type of an Access_To_Subprogram. Has type
-- and signature like a subprogram entity, so can appear in calls,
-- which are resolved like regular calls, except that such an entity
-- is not overloadable.
---------------------------
-- Overloadable Entities --
---------------------------
E_Enumeration_Literal,
-- An enumeration literal, created by the use of the literal in an
-- enumeration type definition.
E_Function,
-- A function, created by a function declaration or a function body
-- that acts as its own declaration.
E_Operator,
-- A predefined operator, appearing in Standard, or an implicitly
-- defined concatenation operator created whenever an array is
-- declared. We do not make normal derived operators explicit in
-- the tree, but the concatenation operators are made explicit.
E_Procedure,
-- A procedure, created by a procedure declaration or a procedure
-- body that acts as its own declaration.
E_Entry,
-- An entry, created by an entry declaration in a task or protected
-- object.
E_Abstract_State,
-- A state abstraction. Used to designate entities introduced by aspect
-- or pragma Abstract_State. The entity carries the various properties
-- of the state.
--------------------
-- Other Entities --
--------------------
E_Entry_Family,
-- An entry family, created by an entry family declaration in a
-- task or protected type definition.
E_Block,
-- A block identifier, created by an explicit or implicit label on
-- a block or declare statement.
E_Entry_Index_Parameter,
-- An entry index parameter created by an entry index specification
-- for the body of a protected entry family.
E_Exception,
-- An exception created by an exception declaration. The exception
-- itself uses E_Exception for the Ekind, the implicit type that is
-- created to represent its type uses the Ekind E_Exception_Type.
E_Generic_Function,
-- A generic function. This is the entity for a generic function
-- created by a generic subprogram declaration.
E_Generic_Procedure,
-- A generic function. This is the entity for a generic procedure
-- created by a generic subprogram declaration.
E_Generic_Package,
-- A generic package, this is the entity for a generic package created
-- by a generic package declaration.
E_Label,
-- The defining entity for a label. Note that this is created by the
-- implicit label declaration, not the occurrence of the label itself,
-- which is simply a direct name referring to the label.
E_Loop,
-- A loop identifier, created by an explicit or implicit label on a
-- loop statement.
E_Return_Statement,
-- A dummy entity created for each return statement. Used to hold
-- information about the return statement (what it applies to) and in
-- rules checking. For example, a simple_return_statement that applies
-- to an extended_return_statement cannot have an expression; this
-- requires putting the E_Return_Statement entity for the
-- extended_return_statement on the scope stack.
E_Package,
-- A package, created by a package declaration
E_Package_Body,
-- A package body. This entity serves only limited functions, since
-- most semantic analysis uses the package entity (E_Package). However
-- there are some attributes that are significant for the body entity.
-- For example, collection of exception handlers.
E_Protected_Object,
-- A protected object, created by an object declaration that declares
-- an object of a protected type.
E_Protected_Body,
-- A protected body. This entity serves almost no function, since all
-- semantic analysis uses the protected entity (E_Protected_Type)
E_Task_Body,
-- A task body. This entity serves almost no function, since all
-- semantic analysis uses the protected entity (E_Task_Type).
E_Subprogram_Body
-- A subprogram body. Used when a subprogram has a separate declaration
-- to represent the entity for the body. This entity serves almost no
-- function, since all semantic analysis uses the subprogram entity
-- for the declaration (E_Function or E_Procedure).
);
for Entity_Kind'Size use 8;
-- The data structures in Atree assume this
--------------------------
-- Subtype Declarations --
--------------------------
-- The above entities are arranged so that they can be conveniently grouped
-- into subtype ranges. Note that for each of the xxx_Kind ranges defined
-- below, there is a corresponding Is_xxx (or for types, Is_xxx_Type)
-- predicate which is to be used in preference to direct range tests using
-- the subtype name. However, the subtype names are available for direct
-- use, e.g. as choices in case statements.
subtype Access_Kind is Entity_Kind range
E_Access_Type ..
-- E_Access_Subtype
-- E_Access_Attribute_Type
-- E_Allocator_Type
-- E_General_Access_Type
-- E_Access_Subprogram_Type
-- E_Anonymous_Access_Subprogram_Type
-- E_Access_Protected_Subprogram_Type
-- E_Anonymous_Access_Protected_Subprogram_Type
E_Anonymous_Access_Type;
subtype Access_Subprogram_Kind is Entity_Kind range
E_Access_Subprogram_Type ..
-- E_Anonymous_Access_Subprogram_Type
-- E_Access_Protected_Subprogram_Type
E_Anonymous_Access_Protected_Subprogram_Type;
subtype Access_Protected_Kind is Entity_Kind range
E_Access_Protected_Subprogram_Type ..
E_Anonymous_Access_Protected_Subprogram_Type;
subtype Aggregate_Kind is Entity_Kind range
E_Array_Type ..
-- E_Array_Subtype
-- E_String_Literal_Subtype
-- E_Class_Wide_Type
-- E_Class_Wide_Subtype
-- E_Record_Type
E_Record_Subtype;
subtype Array_Kind is Entity_Kind range
E_Array_Type ..
-- E_Array_Subtype
E_String_Literal_Subtype;
subtype Assignable_Kind is Entity_Kind range
E_Variable ..
-- E_Out_Parameter
E_In_Out_Parameter;
subtype Class_Wide_Kind is Entity_Kind range
E_Class_Wide_Type ..
E_Class_Wide_Subtype;
subtype Composite_Kind is Entity_Kind range
E_Array_Type ..
-- E_Array_Subtype
-- E_String_Literal_Subtype
-- E_Class_Wide_Type
-- E_Class_Wide_Subtype
-- E_Record_Type
-- E_Record_Subtype
-- E_Record_Type_With_Private
-- E_Record_Subtype_With_Private
-- E_Private_Type
-- E_Private_Subtype
-- E_Limited_Private_Type
-- E_Limited_Private_Subtype
-- E_Incomplete_Type
-- E_Incomplete_Subtype
-- E_Task_Type
-- E_Task_Subtype,
-- E_Protected_Type,
E_Protected_Subtype;
subtype Concurrent_Kind is Entity_Kind range
E_Task_Type ..
-- E_Task_Subtype,
-- E_Protected_Type,
E_Protected_Subtype;
subtype Concurrent_Body_Kind is Entity_Kind range
E_Protected_Body ..
E_Task_Body;
subtype Decimal_Fixed_Point_Kind is Entity_Kind range
E_Decimal_Fixed_Point_Type ..
E_Decimal_Fixed_Point_Subtype;
subtype Digits_Kind is Entity_Kind range
E_Decimal_Fixed_Point_Type ..
-- E_Decimal_Fixed_Point_Subtype
-- E_Floating_Point_Type
E_Floating_Point_Subtype;
subtype Discrete_Kind is Entity_Kind range
E_Enumeration_Type ..
-- E_Enumeration_Subtype
-- E_Signed_Integer_Type
-- E_Signed_Integer_Subtype
-- E_Modular_Integer_Type
E_Modular_Integer_Subtype;
subtype Discrete_Or_Fixed_Point_Kind is Entity_Kind range
E_Enumeration_Type ..
-- E_Enumeration_Subtype
-- E_Signed_Integer_Type
-- E_Signed_Integer_Subtype
-- E_Modular_Integer_Type
-- E_Modular_Integer_Subtype
-- E_Ordinary_Fixed_Point_Type
-- E_Ordinary_Fixed_Point_Subtype
-- E_Decimal_Fixed_Point_Type
E_Decimal_Fixed_Point_Subtype;
subtype Elementary_Kind is Entity_Kind range
E_Enumeration_Type ..
-- E_Enumeration_Subtype
-- E_Signed_Integer_Type
-- E_Signed_Integer_Subtype
-- E_Modular_Integer_Type
-- E_Modular_Integer_Subtype
-- E_Ordinary_Fixed_Point_Type
-- E_Ordinary_Fixed_Point_Subtype
-- E_Decimal_Fixed_Point_Type
-- E_Decimal_Fixed_Point_Subtype
-- E_Floating_Point_Type
-- E_Floating_Point_Subtype
-- E_Access_Type
-- E_Access_Subtype
-- E_Access_Attribute_Type
-- E_Allocator_Type
-- E_General_Access_Type
-- E_Access_Subprogram_Type
-- E_Access_Protected_Subprogram_Type
-- E_Anonymous_Access_Subprogram_Type
-- E_Anonymous_Access_Protected_Subprogram_Type
E_Anonymous_Access_Type;
subtype Enumeration_Kind is Entity_Kind range
E_Enumeration_Type ..
E_Enumeration_Subtype;
subtype Entry_Kind is Entity_Kind range
E_Entry ..
E_Entry_Family;
subtype Fixed_Point_Kind is Entity_Kind range
E_Ordinary_Fixed_Point_Type ..
-- E_Ordinary_Fixed_Point_Subtype
-- E_Decimal_Fixed_Point_Type
E_Decimal_Fixed_Point_Subtype;
subtype Float_Kind is Entity_Kind range
E_Floating_Point_Type ..
E_Floating_Point_Subtype;
subtype Formal_Kind is Entity_Kind range
E_Out_Parameter ..
-- E_In_Out_Parameter
E_In_Parameter;
subtype Formal_Object_Kind is Entity_Kind range
E_Generic_In_Out_Parameter ..
E_Generic_In_Parameter;
subtype Generic_Subprogram_Kind is Entity_Kind range
E_Generic_Function ..
E_Generic_Procedure;
subtype Generic_Unit_Kind is Entity_Kind range
E_Generic_Function ..
-- E_Generic_Procedure
E_Generic_Package;
subtype Incomplete_Kind is Entity_Kind range
E_Incomplete_Type ..
E_Incomplete_Subtype;
subtype Incomplete_Or_Private_Kind is Entity_Kind range
E_Record_Type_With_Private ..
-- E_Record_Subtype_With_Private
-- E_Private_Type
-- E_Private_Subtype
-- E_Limited_Private_Type
-- E_Limited_Private_Subtype
-- E_Incomplete_Type
E_Incomplete_Subtype;
subtype Integer_Kind is Entity_Kind range
E_Signed_Integer_Type ..
-- E_Signed_Integer_Subtype
-- E_Modular_Integer_Type
E_Modular_Integer_Subtype;
subtype Modular_Integer_Kind is Entity_Kind range
E_Modular_Integer_Type ..
E_Modular_Integer_Subtype;
subtype Named_Kind is Entity_Kind range
E_Named_Integer ..
E_Named_Real;
subtype Numeric_Kind is Entity_Kind range
E_Signed_Integer_Type ..
-- E_Signed_Integer_Subtype
-- E_Modular_Integer_Type
-- E_Modular_Integer_Subtype
-- E_Ordinary_Fixed_Point_Type
-- E_Ordinary_Fixed_Point_Subtype
-- E_Decimal_Fixed_Point_Type
-- E_Decimal_Fixed_Point_Subtype
-- E_Floating_Point_Type
E_Floating_Point_Subtype;
subtype Object_Kind is Entity_Kind range
E_Component ..
-- E_Constant
-- E_Discriminant
-- E_Loop_Parameter
-- E_Variable
-- E_Out_Parameter
-- E_In_Out_Parameter
-- E_In_Parameter
-- E_Generic_In_Out_Parameter
E_Generic_In_Parameter;
subtype Ordinary_Fixed_Point_Kind is Entity_Kind range
E_Ordinary_Fixed_Point_Type ..
E_Ordinary_Fixed_Point_Subtype;
subtype Overloadable_Kind is Entity_Kind range
E_Enumeration_Literal ..
-- E_Function
-- E_Operator
-- E_Procedure
-- E_Entry
E_Abstract_State;
subtype Private_Kind is Entity_Kind range
E_Record_Type_With_Private ..
-- E_Record_Subtype_With_Private
-- E_Private_Type
-- E_Private_Subtype
-- E_Limited_Private_Type
E_Limited_Private_Subtype;
subtype Protected_Kind is Entity_Kind range
E_Protected_Type ..
E_Protected_Subtype;
subtype Real_Kind is Entity_Kind range
E_Ordinary_Fixed_Point_Type ..
-- E_Ordinary_Fixed_Point_Subtype
-- E_Decimal_Fixed_Point_Type
-- E_Decimal_Fixed_Point_Subtype
-- E_Floating_Point_Type
E_Floating_Point_Subtype;
subtype Record_Kind is Entity_Kind range
E_Class_Wide_Type ..
-- E_Class_Wide_Subtype
-- E_Record_Type
-- E_Record_Subtype
-- E_Record_Type_With_Private
E_Record_Subtype_With_Private;
subtype Scalar_Kind is Entity_Kind range
E_Enumeration_Type ..
-- E_Enumeration_Subtype
-- E_Signed_Integer_Type
-- E_Signed_Integer_Subtype
-- E_Modular_Integer_Type
-- E_Modular_Integer_Subtype
-- E_Ordinary_Fixed_Point_Type
-- E_Ordinary_Fixed_Point_Subtype
-- E_Decimal_Fixed_Point_Type
-- E_Decimal_Fixed_Point_Subtype
-- E_Floating_Point_Type
E_Floating_Point_Subtype;
subtype Subprogram_Kind is Entity_Kind range
E_Function ..
-- E_Operator
E_Procedure;
subtype Signed_Integer_Kind is Entity_Kind range
E_Signed_Integer_Type ..
E_Signed_Integer_Subtype;
subtype Task_Kind is Entity_Kind range
E_Task_Type ..
E_Task_Subtype;
subtype Type_Kind is Entity_Kind range
E_Enumeration_Type ..
-- E_Enumeration_Subtype
-- E_Signed_Integer_Type
-- E_Signed_Integer_Subtype
-- E_Modular_Integer_Type
-- E_Modular_Integer_Subtype
-- E_Ordinary_Fixed_Point_Type
-- E_Ordinary_Fixed_Point_Subtype
-- E_Decimal_Fixed_Point_Type
-- E_Decimal_Fixed_Point_Subtype
-- E_Floating_Point_Type
-- E_Floating_Point_Subtype
-- E_Access_Type
-- E_Access_Subtype
-- E_Access_Attribute_Type
-- E_Allocator_Type,
-- E_General_Access_Type
-- E_Access_Subprogram_Type,
-- E_Access_Protected_Subprogram_Type
-- E_Anonymous_Access_Subprogram_Type
-- E_Anonymous_Access_Protected_Subprogram_Type
-- E_Anonymous_Access_Type
-- E_Array_Type
-- E_Array_Subtype
-- E_String_Literal_Subtype
-- E_Class_Wide_Subtype
-- E_Class_Wide_Type
-- E_Record_Type
-- E_Record_Subtype
-- E_Record_Type_With_Private
-- E_Record_Subtype_With_Private
-- E_Private_Type
-- E_Private_Subtype
-- E_Limited_Private_Type
-- E_Limited_Private_Subtype
-- E_Incomplete_Type
-- E_Incomplete_Subtype
-- E_Task_Type
-- E_Task_Subtype
-- E_Protected_Type
-- E_Protected_Subtype
-- E_Exception_Type
E_Subprogram_Type;
--------------------------------------------------------
-- Description of Defined Attributes for Entity_Kinds --
--------------------------------------------------------
-- For each enumeration value defined in Entity_Kind we list all the
-- attributes defined in Einfo which can legally be applied to an entity
-- of that kind. The implementation of the attribute functions (and for
-- non-synthesized attributes, of the corresponding set procedures) are
-- in the Einfo body.
-- The following attributes are defined in all entities
-- Ekind (Ekind)
-- Chars (Name1)
-- Next_Entity (Node2)
-- Scope (Node3)
-- Homonym (Node4)
-- Etype (Node5)
-- First_Rep_Item (Node6)
-- Freeze_Node (Node7)
-- Address_Taken (Flag104)
-- Can_Never_Be_Null (Flag38)
-- Checks_May_Be_Suppressed (Flag31)
-- Debug_Info_Off (Flag166)
-- Has_Convention_Pragma (Flag119)
-- Has_Delayed_Aspects (Flag200)
-- Has_Delayed_Freeze (Flag18)
-- Has_Fully_Qualified_Name (Flag173)
-- Has_Gigi_Rep_Item (Flag82)
-- Has_Homonym (Flag56)
-- Has_Pragma_Elaborate_Body (Flag150)
-- Has_Pragma_Inline (Flag157)
-- Has_Pragma_Inline_Always (Flag230)
-- Has_Pragma_No_Inline (Flag201)
-- Has_Pragma_Pure (Flag203)
-- Has_Pragma_Pure_Function (Flag179)
-- Has_Pragma_Thread_Local_Storage (Flag169)
-- Has_Pragma_Unmodified (Flag233)
-- Has_Pragma_Unreferenced (Flag180)
-- Has_Private_Declaration (Flag155)
-- Has_Qualified_Name (Flag161)
-- Has_Stream_Size_Clause (Flag184)
-- Has_Unknown_Discriminants (Flag72)
-- Has_Xref_Entry (Flag182)
-- In_Private_Part (Flag45)
-- Is_Ada_2005_Only (Flag185)
-- Is_Ada_2012_Only (Flag199)
-- Is_Bit_Packed_Array (Flag122) (base type only)
-- Is_Aliased (Flag15)
-- Is_Character_Type (Flag63)
-- Is_Child_Unit (Flag73)
-- Is_Compilation_Unit (Flag149)
-- Is_Completely_Hidden (Flag103)
-- Is_Descendent_Of_Address (Flag223)
-- Is_Discrim_SO_Function (Flag176)
-- Is_Discriminant_Check_Function (Flag264)
-- Is_Dispatch_Table_Entity (Flag234)
-- Is_Dispatching_Operation (Flag6)
-- Is_Entry_Formal (Flag52)
-- Is_Exported (Flag99)
-- Is_First_Subtype (Flag70)
-- Is_Formal_Subprogram (Flag111)
-- Is_Generic_Instance (Flag130)
-- Is_Generic_Type (Flag13)
-- Is_Hidden (Flag57)
-- Is_Hidden_Open_Scope (Flag171)
-- Is_Immediately_Visible (Flag7)
-- Is_Implementation_Defined (Flag254)
-- Is_Imported (Flag24)
-- Is_Inlined (Flag11)
-- Is_Internal (Flag17)
-- Is_Itype (Flag91)
-- Is_Known_Non_Null (Flag37)
-- Is_Known_Null (Flag204)
-- Is_Known_Valid (Flag170)
-- Is_Limited_Composite (Flag106)
-- Is_Limited_Record (Flag25)
-- Is_Obsolescent (Flag153)
-- Is_Package_Body_Entity (Flag160)
-- Is_Packed_Array_Impl_Type (Flag138)
-- Is_Potentially_Use_Visible (Flag9)
-- Is_Preelaborated (Flag59)
-- Is_Primitive_Wrapper (Flag195)
-- Is_Public (Flag10)
-- Is_Pure (Flag44)
-- Is_Remote_Call_Interface (Flag62)
-- Is_Remote_Types (Flag61)
-- Is_Renaming_Of_Object (Flag112)
-- Is_Shared_Passive (Flag60)
-- Is_Statically_Allocated (Flag28)
-- Is_Tagged_Type (Flag55)
-- Is_Thunk (Flag225)
-- Is_Trivial_Subprogram (Flag235)
-- Is_Unchecked_Union (Flag117)
-- Is_Visible_Formal (Flag206)
-- Is_VMS_Exception (Flag133)
-- Kill_Elaboration_Checks (Flag32)
-- Kill_Range_Checks (Flag33)
-- Low_Bound_Tested (Flag205)
-- Materialize_Entity (Flag168)
-- Needs_Debug_Info (Flag147)
-- Never_Set_In_Source (Flag115)
-- No_Return (Flag113)
-- Overlays_Constant (Flag243)
-- Referenced (Flag156)
-- Referenced_As_LHS (Flag36)
-- Referenced_As_Out_Parameter (Flag227)
-- Suppress_Elaboration_Warnings (Flag148)
-- Suppress_Style_Checks (Flag165)
-- Suppress_Value_Tracking_On_Call (Flag217)
-- Used_As_Generic_Actual (Flag222)
-- Warnings_Off (Flag96)
-- Warnings_Off_Used (Flag236)
-- Warnings_Off_Used_Unmodified (Flag237)
-- Warnings_Off_Used_Unreferenced (Flag238)
-- Was_Hidden (Flag196)
-- Declaration_Node (synth)
-- Has_Foreign_Convention (synth)
-- Is_Dynamic_Scope (synth)
-- Is_Standard_Character_Type (synth)
-- Underlying_Type (synth)
-- all classification attributes (synth)
-- The following list of access functions applies to all entities for
-- types and subtypes. References to this list appear subsequently as
-- as "(plus type attributes)" for each appropriate Entity_Kind.
-- Associated_Node_For_Itype (Node8)
-- Class_Wide_Type (Node9)
-- Full_View (Node11)
-- Esize (Uint12)
-- RM_Size (Uint13)
-- Alignment (Uint14)
-- Related_Expression (Node24)
-- Current_Use_Clause (Node27)
-- Subprograms_For_Type (Node29)
-- Derived_Type_Link (Node31)
-- Linker_Section_Pragma (Node33)
-- Depends_On_Private (Flag14)
-- Discard_Names (Flag88)
-- Finalize_Storage_Only (Flag158) (base type only)
-- From_Limited_With (Flag159)
-- Has_Aliased_Components (Flag135) (base type only)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86) (base type only)
-- Has_Completion_In_Body (Flag71)
-- Has_Complex_Representation (Flag140) (base type only)
-- Has_Constrained_Partial_View (Flag187)
-- Has_Controlled_Component (Flag43) (base type only)
-- Has_Default_Aspect (Flag39) (base type only)
-- Has_Delayed_Rep_Aspects (Flag261)
-- Has_Discriminants (Flag5)
-- Has_Dynamic_Predicate_Aspect (Flag258)
-- Has_Independent_Components (Flag34) (base type only)
-- Has_Inheritable_Invariants (Flag248)
-- Has_Invariants (Flag232)
-- Has_Non_Standard_Rep (Flag75) (base type only)
-- Has_Object_Size_Clause (Flag172)
-- Has_Pragma_Preelab_Init (Flag221)
-- Has_Pragma_Unreferenced_Objects (Flag212)
-- Has_Predicates (Flag250)
-- Has_Primitive_Operations (Flag120) (base type only)
-- Has_Protected (Flag271) (base type only)
-- Has_Size_Clause (Flag29)
-- Has_Specified_Layout (Flag100) (base type only)
-- Has_Specified_Stream_Input (Flag190)
-- Has_Specified_Stream_Output (Flag191)
-- Has_Specified_Stream_Read (Flag192)
-- Has_Specified_Stream_Write (Flag193)
-- Has_Static_Predicate (Flag269)
-- Has_Static_Predicate_Aspect (Flag259)
-- Has_Task (Flag30) (base type only)
-- Has_Unchecked_Union (Flag123) (base type only)
-- Has_Volatile_Components (Flag87) (base type only)
-- In_Use (Flag8)
-- Is_Abstract_Type (Flag146)
-- Is_Asynchronous (Flag81)
-- Is_Atomic (Flag85)
-- Is_Constr_Subt_For_U_Nominal (Flag80)
-- Is_Constr_Subt_For_UN_Aliased (Flag141)
-- Is_Controlled (Flag42) (base type only)
-- Is_Eliminated (Flag124)
-- Is_Frozen (Flag4)
-- Is_Generic_Actual_Type (Flag94)
-- Is_RACW_Stub_Type (Flag244)
-- Is_Non_Static_Subtype (Flag109)
-- Is_Packed (Flag51) (base type only)
-- Is_Private_Composite (Flag107)
-- Is_Unsigned_Type (Flag144)
-- Is_Volatile (Flag16)
-- Itype_Printed (Flag202) (itypes only)
-- Known_To_Have_Preelab_Init (Flag207)
-- May_Inherit_Delayed_Rep_Aspects (Flag262)
-- Must_Be_On_Byte_Boundary (Flag183)
-- Must_Have_Preelab_Init (Flag208)
-- Optimize_Alignment_Space (Flag241)
-- Optimize_Alignment_Time (Flag242)
-- Size_Depends_On_Discriminant (Flag177)
-- Size_Known_At_Compile_Time (Flag92)
-- Strict_Alignment (Flag145) (base type only)
-- Suppress_Initialization (Flag105)
-- Treat_As_Volatile (Flag41)
-- Universal_Aliasing (Flag216) (impl base type only)
-- Alignment_Clause (synth)
-- Base_Type (synth)
-- Implementation_Base_Type (synth)
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
-- Predicate_Function (synth)
-- Predicate_Function_M (synth)
-- Root_Type (synth)
-- Size_Clause (synth)
------------------------------------------
-- Applicable attributes by entity kind --
------------------------------------------
-- E_Abstract_State
-- Refinement_Constituents (Elist8)
-- Part_Of_Constituents (Elist9)
-- Encapsulating_State (Node10)
-- Body_References (Elist16)
-- Non_Limited_View (Node17)
-- From_Limited_With (Flag159)
-- Has_Visible_Refinement (Flag263)
-- Has_Non_Null_Refinement (synth)
-- Has_Null_Refinement (synth)
-- Is_External_State (synth)
-- Is_Null_State (synth)
-- E_Access_Protected_Subprogram_Type
-- Equivalent_Type (Node18)
-- Directly_Designated_Type (Node20)
-- Needs_No_Actuals (Flag22)
-- Can_Use_Internal_Rep (Flag229)
-- (plus type attributes)
-- E_Access_Subprogram_Type
-- Equivalent_Type (Node18) (remote types only)
-- Directly_Designated_Type (Node20)
-- Interface_Name (Node21) (JGNAT usage only)
-- Needs_No_Actuals (Flag22)
-- Original_Access_Type (Node26)
-- Can_Use_Internal_Rep (Flag229)
-- (plus type attributes)
-- E_Access_Type
-- E_Access_Subtype
-- Storage_Size_Variable (Node15) (base type only)
-- Master_Id (Node17)
-- Directly_Designated_Type (Node20)
-- Associated_Storage_Pool (Node22) (base type only)
-- Finalization_Master (Node23) (base type only)
-- Has_Pragma_Controlled (Flag27) (base type only)
-- Has_Storage_Size_Clause (Flag23) (base type only)
-- Is_Access_Constant (Flag69)
-- Is_Local_Anonymous_Access (Flag194)
-- Is_Pure_Unit_Access_Type (Flag189)
-- No_Pool_Assigned (Flag131) (base type only)
-- No_Strict_Aliasing (Flag136) (base type only)
-- (plus type attributes)
-- E_Access_Attribute_Type
-- Directly_Designated_Type (Node20)
-- (plus type attributes)
-- E_Allocator_Type
-- Directly_Designated_Type (Node20)
-- (plus type attributes)
-- E_Anonymous_Access_Subprogram_Type
-- E_Anonymous_Access_Protected_Subprogram_Type
-- Storage_Size_Variable (Node15) ??? is this needed ???
-- Directly_Designated_Type (Node20)
-- Can_Use_Internal_Rep (Flag229)
-- (plus type attributes)
-- E_Anonymous_Access_Type
-- Storage_Size_Variable (Node15) ??? is this needed ???
-- Directly_Designated_Type (Node20)
-- Finalization_Master (Node23)
-- (plus type attributes)
-- E_Array_Type
-- E_Array_Subtype
-- First_Index (Node17)
-- Default_Aspect_Component_Value (Node19) (base type only)
-- Component_Type (Node20) (base type only)
-- Original_Array_Type (Node21)
-- Component_Size (Uint22) (base type only)
-- Packed_Array_Impl_Type (Node23)
-- Related_Array_Object (Node25)
-- Component_Alignment (special) (base type only)
-- Has_Component_Size_Clause (Flag68) (base type only)
-- Has_Pragma_Pack (Flag121) (impl base type only)
-- Is_Constrained (Flag12)
-- Reverse_Storage_Order (Flag93) (base type only)
-- SSO_Set_High_By_Default (Flag273) (base type only)
-- SSO_Set_Low_By_Default (Flag272) (base type only)
-- Next_Index (synth)
-- Number_Dimensions (synth)
-- (plus type attributes)
-- E_Block
-- Block_Node (Node11)
-- First_Entity (Node17)
-- Last_Entity (Node20)
-- Scope_Depth_Value (Uint22)
-- Entry_Cancel_Parameter (Node23)
-- Delay_Cleanups (Flag114)
-- Discard_Names (Flag88)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
-- Sec_Stack_Needed_For_Return (Flag167)
-- Uses_Sec_Stack (Flag95)
-- Scope_Depth (synth)
-- E_Class_Wide_Type
-- E_Class_Wide_Subtype
-- Direct_Primitive_Operations (Elist10)
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Equivalent_Type (Node18) (always Empty for type)
-- Last_Entity (Node20)
-- SSO_Set_High_By_Default (Flag273) (base type only)
-- SSO_Set_Low_By_Default (Flag272) (base type only)
-- First_Component (synth)
-- First_Component_Or_Discriminant (synth)
-- (plus type attributes)
-- E_Component
-- Normalized_First_Bit (Uint8)
-- Current_Value (Node9) (always Empty)
-- Normalized_Position_Max (Uint10)
-- Component_Bit_Offset (Uint11)
-- Esize (Uint12)
-- Component_Clause (Node13)
-- Normalized_Position (Uint14)
-- DT_Entry_Count (Uint15)
-- Entry_Formal (Node16)
-- Prival (Node17)
-- Renamed_Object (Node18) (always Empty)
-- Discriminant_Checking_Func (Node20)
-- Interface_Name (Node21) (JGNAT usage only)
-- Original_Record_Component (Node22)
-- DT_Offset_To_Top_Func (Node25)
-- Related_Type (Node27)
-- Has_Biased_Representation (Flag139)
-- Has_Per_Object_Constraint (Flag154)
-- Is_Atomic (Flag85)
-- Is_Independent (Flag268)
-- Is_Tag (Flag78)
-- Is_Volatile (Flag16)
-- Treat_As_Volatile (Flag41)
-- Is_Return_Object (Flag209)
-- Next_Component (synth)
-- Next_Component_Or_Discriminant (synth)
-- E_Constant
-- E_Loop_Parameter
-- Current_Value (Node9) (always Empty)
-- Discriminal_Link (Node10)
-- Full_View (Node11)
-- Esize (Uint12)
-- Extra_Accessibility (Node13) (constants only)
-- Alignment (Uint14)
-- Status_Flag_Or_Transient_Decl (Node15) (constants only)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
-- Size_Check_Code (Node19) (constants only)
-- Prival_Link (Node20) (privals only)
-- Interface_Name (Node21) (constants only)
-- Related_Type (Node27) (constants only)
-- Initialization_Statements (Node28)
-- BIP_Initialization_Call (Node29)
-- Last_Aggregate_Assignment (Node30)
-- Linker_Section_Pragma (Node33)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
-- Has_Completion (Flag26) (constants only)
-- Has_Thunks (Flag228) (constants only)
-- Has_Size_Clause (Flag29)
-- Has_Up_Level_Access (Flag215)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
-- Is_Processed_Transient (Flag252) (constants only)
-- Is_Return_Object (Flag209)
-- Is_True_Constant (Flag163)
-- Is_Volatile (Flag16)
-- Stores_Attribute_Old_Prefix (Flag270) (constants only)
-- Optimize_Alignment_Space (Flag241) (constants only)
-- Optimize_Alignment_Time (Flag242) (constants only)
-- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
-- Size_Clause (synth)
-- E_Decimal_Fixed_Point_Type
-- E_Decimal_Fixed_Subtype
-- Scale_Value (Uint15)
-- Digits_Value (Uint17)
-- Scalar_Range (Node20)
-- Delta_Value (Ureal18)
-- Small_Value (Ureal21)
-- Static_Real_Or_String_Predicate (Node25)
-- Has_Machine_Radix_Clause (Flag83)
-- Machine_Radix_10 (Flag84)
-- Aft_Value (synth)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
-- (plus type attributes)
-- E_Discriminant
-- Normalized_First_Bit (Uint8)
-- Current_Value (Node9) (always Empty)
-- Normalized_Position_Max (Uint10)
-- Component_Bit_Offset (Uint11)
-- Esize (Uint12)
-- Component_Clause (Node13)
-- Normalized_Position (Uint14)
-- Discriminant_Number (Uint15)
-- Discriminal (Node17)
-- Renamed_Object (Node18) (always Empty)
-- Corresponding_Discriminant (Node19)
-- Discriminant_Default_Value (Node20)
-- Interface_Name (Node21) (JGNAT usage only)
-- Original_Record_Component (Node22)
-- CR_Discriminant (Node23)
-- Is_Return_Object (Flag209)
-- Next_Component_Or_Discriminant (synth)
-- Next_Discriminant (synth)
-- Next_Stored_Discriminant (synth)
-- E_Entry
-- E_Entry_Family
-- Protected_Body_Subprogram (Node11)
-- Barrier_Function (Node12)
-- Entry_Parameters_Type (Node15)
-- First_Entity (Node17)
-- Alias (Node18) (for entry only. Empty)
-- Last_Entity (Node20)
-- Accept_Address (Elist21)
-- Scope_Depth_Value (Uint22)
-- Protection_Object (Node23) (protected kind)
-- PPC_Wrapper (Node25)
-- Extra_Formals (Node28)
-- Contract (Node34)
-- Default_Expressions_Processed (Flag108)
-- Entry_Accepted (Flag152)
-- Is_AST_Entry (Flag132) (for entry only)
-- Needs_No_Actuals (Flag22)
-- Sec_Stack_Needed_For_Return (Flag167)
-- Uses_Sec_Stack (Flag95)
-- Address_Clause (synth)
-- Entry_Index_Type (synth)
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
-- Last_Formal (synth)
-- Number_Formals (synth)
-- Scope_Depth (synth)
-- E_Entry_Index_Parameter
-- Entry_Index_Constant (Node18)
-- E_Enumeration_Literal
-- Enumeration_Pos (Uint11)
-- Enumeration_Rep (Uint12)
-- Alias (Node18)
-- Enumeration_Rep_Expr (Node22)
-- Next_Literal (synth)
-- E_Enumeration_Type
-- E_Enumeration_Subtype
-- Lit_Indexes (Node15) (root type only)
-- Lit_Strings (Node16) (root type only)
-- First_Literal (Node17)
-- Default_Aspect_Value (Node19) (base type only)
-- Scalar_Range (Node20)
-- Enum_Pos_To_Rep (Node23) (type only)
-- Static_Discrete_Predicate (List25)
-- Has_Biased_Representation (Flag139)
-- Has_Contiguous_Rep (Flag181)
-- Has_Enumeration_Rep_Clause (Flag66)
-- Has_Pragma_Ordered (Flag198) (base type only)
-- Nonzero_Is_True (Flag162) (base type only)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
-- (plus type attributes)
-- E_Exception
-- Esize (Uint12)
-- Alignment (Uint14)
-- Renamed_Entity (Node18)
-- Register_Exception_Call (Node20)
-- Interface_Name (Node21)
-- Exception_Code (Uint22)
-- Discard_Names (Flag88)
-- Is_VMS_Exception (Flag133)
-- Is_Raised (Flag224)
-- E_Exception_Type
-- Equivalent_Type (Node18)
-- (plus type attributes)
-- E_Floating_Point_Type
-- E_Floating_Point_Subtype
-- Digits_Value (Uint17)
-- Float_Rep (Uint10) (Float_Rep_Kind)
-- Default_Aspect_Value (Node19) (base type only)
-- Scalar_Range (Node20)
-- Static_Real_Or_String_Predicate (Node25)
-- Machine_Emax_Value (synth)
-- Machine_Emin_Value (synth)
-- Machine_Mantissa_Value (synth)
-- Machine_Radix_Value (synth)
-- Model_Emin_Value (synth)
-- Model_Epsilon_Value (synth)
-- Model_Mantissa_Value (synth)
-- Model_Small_Value (synth)
-- Safe_Emax_Value (synth)
-- Safe_First_Value (synth)
-- Safe_Last_Value (synth)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
-- Vax_Float (synth)
-- (plus type attributes)
-- E_Function
-- E_Generic_Function
-- Mechanism (Uint8) (Mechanism_Type)
-- Renaming_Map (Uint9)
-- Handler_Records (List10) (non-generic case only)
-- Protected_Body_Subprogram (Node11)
-- Next_Inlined_Subprogram (Node12)
-- Elaboration_Entity (Node13) (not implicit /=)
-- First_Optional_Parameter (Node14) (non-generic case only)
-- DT_Position (Uint15)
-- DTC_Entity (Node16)
-- First_Entity (Node17)
-- Alias (Node18) (non-generic case only)
-- Renamed_Entity (Node18) (generic case only)
-- Extra_Accessibility_Of_Result (Node19) (non-generic case only)
-- Last_Entity (Node20)
-- Interface_Name (Node21)
-- Scope_Depth_Value (Uint22)
-- Generic_Renamings (Elist23) (for an instance)
-- Inner_Instances (Elist23) (generic case only)
-- Protection_Object (Node23) (for concurrent kind)
-- Interface_Alias (Node25)
-- Overridden_Operation (Node26)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Extra_Formals (Node28)
-- Subprograms_For_Type (Node29)
-- Corresponding_Equality (Node30) (implicit /= only)
-- Thunk_Entity (Node31) (thunk case only)
-- SPARK_Pragma (Node32)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
-- Default_Expressions_Processed (Flag108)
-- Delay_Cleanups (Flag114)
-- Delay_Subprogram_Descriptors (Flag50)
-- Discard_Names (Flag88)
-- Has_Anonymous_Master (Flag253)
-- Has_Completion (Flag26)
-- Has_Controlling_Result (Flag98)
-- Has_Invariants (Flag232)
-- Has_Master_Entity (Flag21)
-- Has_Missing_Return (Flag142)
-- Has_Nested_Block_With_Handler (Flag101)
-- Has_Out_Or_In_Out_Parameter (Flag110)
-- Has_Postconditions (Flag240)
-- Has_Recursive_Call (Flag143)
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Is_Called (Flag102) (non-generic case only)
-- Is_Constructor (Flag76)
-- Is_Discrim_SO_Function (Flag176)
-- Is_Discriminant_Check_Function (Flag264)
-- Is_Eliminated (Flag124)
-- Is_Instantiated (Flag126) (generic case only)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Invariant_Procedure (Flag257) (non-generic case only)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Predicate_Function (Flag255) (non-generic case only)
-- Is_Predicate_Function_M (Flag256) (non-generic case only)
-- Is_Primitive (Flag218)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Private_Primitive (Flag245) (non-generic case only)
-- Is_Pure (Flag44)
-- Is_Visible_Lib_Unit (Flag116)
-- Needs_No_Actuals (Flag22)
-- Requires_Overriding (Flag213) (non-generic case only)
-- Return_Present (Flag54)
-- Returns_By_Ref (Flag90)
-- Sec_Stack_Needed_For_Return (Flag167)
-- SPARK_Pragma_Inherited (Flag265)
-- Uses_Sec_Stack (Flag95)
-- Address_Clause (synth)
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
-- Is_Ghost_Entity (synth) (non-generic case only)
-- Is_Ghost_Subprogram (synth) (non-generic case only)
-- Last_Formal (synth)
-- Number_Formals (synth)
-- Scope_Depth (synth)
-- E_General_Access_Type
-- Storage_Size_Variable (Node15) (base type only)
-- Master_Id (Node17)
-- Directly_Designated_Type (Node20)
-- Associated_Storage_Pool (Node22) (root type only)
-- Finalization_Master (Node23) (root type only)
-- (plus type attributes)
-- E_Generic_In_Parameter
-- E_Generic_In_Out_Parameter
-- Current_Value (Node9) (always Empty)
-- Entry_Component (Node11)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18) (always Empty)
-- Default_Value (Node20)
-- Protected_Formal (Node22)
-- Is_Controlling_Formal (Flag97)
-- Is_Return_Object (Flag209)
-- Parameter_Mode (synth)
-- E_Incomplete_Type
-- E_Incomplete_Subtype
-- Direct_Primitive_Operations (Elist10)
-- Non_Limited_View (Node17)
-- Private_Dependents (Elist18)
-- Discriminant_Constraint (Elist21)
-- Stored_Constraint (Elist23)
-- (plus type attributes)
-- E_In_Parameter
-- E_In_Out_Parameter
-- E_Out_Parameter
-- Mechanism (Uint8) (Mechanism_Type)
-- Current_Value (Node9)
-- Discriminal_Link (Node10) (discriminals only)
-- Entry_Component (Node11)
-- Esize (Uint12)
-- Extra_Accessibility (Node13)
-- Alignment (Uint14)
-- Extra_Formal (Node15)
-- Unset_Reference (Node16)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
-- Spec_Entity (Node19)
-- Default_Value (Node20)
-- Default_Expr_Function (Node21)
-- Protected_Formal (Node22)
-- Extra_Constrained (Node23)
-- Last_Assignment (Node26) (OUT, IN-OUT only)
-- Has_Initial_Value (Flag219)
-- Is_Controlling_Formal (Flag97)
-- Is_Only_Out_Parameter (Flag226)
-- Is_Optional_Parameter (Flag134)
-- Low_Bound_Tested (Flag205)
-- Is_Return_Object (Flag209)
-- Parameter_Mode (synth)
-- E_Label
-- Enclosing_Scope (Node18)
-- Reachable (Flag49)
-- E_Limited_Private_Type
-- E_Limited_Private_Subtype
-- First_Entity (Node17)
-- Private_Dependents (Elist18)
-- Underlying_Full_View (Node19)
-- Last_Entity (Node20)
-- Discriminant_Constraint (Elist21)
-- Private_View (Node22)
-- Stored_Constraint (Elist23)
-- Has_Completion (Flag26)
-- (plus type attributes)
-- E_Loop
-- First_Exit_Statement (Node8)
-- Has_Exit (Flag47)
-- Has_Loop_Entry_Attributes (Flag260)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
-- Uses_Sec_Stack (Flag95)
-- E_Modular_Integer_Type
-- E_Modular_Integer_Subtype
-- Modulus (Uint17) (base type only)
-- Default_Aspect_Value (Node19) (base type only)
-- Original_Array_Type (Node21)
-- Scalar_Range (Node20)
-- Static_Discrete_Predicate (List25)
-- Non_Binary_Modulus (Flag58) (base type only)
-- Has_Biased_Representation (Flag139)
-- Has_Shift_Operator (Flag267) (base type only)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
-- (plus type attributes)
-- E_Named_Integer
-- E_Named_Real
-- E_Operator
-- First_Entity (Node17)
-- Alias (Node18)
-- Extra_Accessibility_Of_Result (Node19)
-- Last_Entity (Node20)
-- Overridden_Operation (Node26)
-- Subprograms_For_Type (Node29)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Has_Invariants (Flag232)
-- Has_Postconditions (Flag240)
-- Is_Machine_Code_Subprogram (Flag137)
-- Is_Pure (Flag44)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Primitive (Flag218)
-- Default_Expressions_Processed (Flag108)
-- Aren't there more flags and fields? seems like this list should be
-- more similar to the E_Function list, which is much longer ???
-- E_Ordinary_Fixed_Point_Type
-- E_Ordinary_Fixed_Point_Subtype
-- Delta_Value (Ureal18)
-- Default_Aspect_Value (Node19) (base type only)
-- Scalar_Range (Node20)
-- Static_Real_Or_String_Predicate (Node25)
-- Small_Value (Ureal21)
-- Has_Small_Clause (Flag67)
-- Aft_Value (synth)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
-- (plus type attributes)
-- E_Package
-- E_Generic_Package
-- Dependent_Instances (Elist8) (for an instance)
-- Renaming_Map (Uint9)
-- Handler_Records (List10) (non-generic case only)
-- Generic_Homonym (Node11) (generic case only)
-- Associated_Formal_Package (Node12)
-- Elaboration_Entity (Node13)
-- Shadow_Entities (List14)
-- Related_Instance (Node15) (non-generic case only)
-- First_Private_Entity (Node16)
-- First_Entity (Node17)
-- Renamed_Entity (Node18)
-- Body_Entity (Node19)
-- Last_Entity (Node20)
-- Interface_Name (Node21)
-- Scope_Depth_Value (Uint22)
-- Generic_Renamings (Elist23) (for an instance)
-- Inner_Instances (Elist23) (generic case only)
-- Limited_View (Node23) (non-generic/instance)
-- Abstract_States (Elist25)
-- Package_Instantiation (Node26)
-- Current_Use_Clause (Node27)
-- Finalizer (Node28) (non-generic case only)
-- SPARK_Aux_Pragma (Node33)
-- SPARK_Pragma (Node32)
-- Contract (Node34)
-- Delay_Subprogram_Descriptors (Flag50)
-- Body_Needed_For_SAL (Flag40)
-- Discard_Names (Flag88)
-- Elaboration_Entity_Required (Flag174)
-- Elaborate_Body_Desirable (Flag210) (non-generic case only)
-- From_Limited_With (Flag159)
-- Has_All_Calls_Remote (Flag79)
-- Has_Anonymous_Master (Flag253)
-- Has_Completion (Flag26)
-- Has_Forward_Instantiation (Flag175)
-- Has_Master_Entity (Flag21)
-- Has_RACW (Flag214) (non-generic case only)
-- In_Package_Body (Flag48)
-- In_Use (Flag8)
-- Is_Instantiated (Flag126)
-- Is_Private_Descendant (Flag53)
-- Is_Visible_Lib_Unit (Flag116)
-- Renamed_In_Spec (Flag231) (non-generic case only)
-- SPARK_Aux_Pragma_Inherited (Flag266)
-- SPARK_Pragma_Inherited (Flag265)
-- Static_Elaboration_Desired (Flag77) (non-generic case only)
-- Has_Null_Abstract_State (synth)
-- Is_Wrapper_Package (synth) (non-generic case only)
-- Scope_Depth (synth)
-- E_Package_Body
-- Handler_Records (List10) (non-generic case only)
-- Related_Instance (Node15) (non-generic case only)
-- First_Entity (Node17)
-- Spec_Entity (Node19)
-- Last_Entity (Node20)
-- Scope_Depth_Value (Uint22)
-- Finalizer (Node28) (non-generic case only)
-- SPARK_Aux_Pragma (Node33)
-- SPARK_Pragma (Node32)
-- Contract (Node34)
-- Delay_Subprogram_Descriptors (Flag50)
-- Has_Anonymous_Master (Flag253)
-- SPARK_Aux_Pragma_Inherited (Flag266)
-- SPARK_Pragma_Inherited (Flag265)
-- Scope_Depth (synth)
-- E_Private_Type
-- E_Private_Subtype
-- Direct_Primitive_Operations (Elist10)
-- First_Entity (Node17)
-- Private_Dependents (Elist18)
-- Underlying_Full_View (Node19)
-- Last_Entity (Node20)
-- Discriminant_Constraint (Elist21)
-- Private_View (Node22)
-- Stored_Constraint (Elist23)
-- Has_Completion (Flag26)
-- Is_Controlled (Flag42) (base type only)
-- Is_For_Access_Subtype (Flag118) (subtype only)
-- (plus type attributes)
-- E_Procedure
-- E_Generic_Procedure
-- Postcondition_Proc (Node8) (non-generic case only)
-- Renaming_Map (Uint9)
-- Handler_Records (List10) (non-generic case only)
-- Protected_Body_Subprogram (Node11)
-- Next_Inlined_Subprogram (Node12)
-- Elaboration_Entity (Node13)
-- First_Optional_Parameter (Node14) (non-generic case only)
-- DT_Position (Uint15)
-- DTC_Entity (Node16)
-- First_Entity (Node17)
-- Alias (Node18) (non-generic case only)
-- Renamed_Entity (Node18) (generic case only)
-- Last_Entity (Node20)
-- Interface_Name (Node21)
-- Scope_Depth_Value (Uint22)
-- Generic_Renamings (Elist23) (for an instance)
-- Inner_Instances (Elist23) (generic case only)
-- Protection_Object (Node23) (for concurrent kind)
-- Interface_Alias (Node25)
-- Overridden_Operation (Node26) (never for init proc)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Extra_Formals (Node28)
-- Static_Initialization (Node30) (init_proc only)
-- Thunk_Entity (Node31) (thunk case only)
-- SPARK_Pragma (Node32)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Body_Needed_For_SAL (Flag40)
-- Delay_Cleanups (Flag114)
-- Discard_Names (Flag88)
-- Elaboration_Entity_Required (Flag174)
-- Default_Expressions_Processed (Flag108)
-- Delay_Cleanups (Flag114)
-- Delay_Subprogram_Descriptors (Flag50)
-- Discard_Names (Flag88)
-- Has_Anonymous_Master (Flag253)
-- Has_Completion (Flag26)
-- Has_Invariants (Flag232)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
-- Has_Postconditions (Flag240)
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Is_Asynchronous (Flag81)
-- Is_Called (Flag102) (non-generic case only)
-- Is_Constructor (Flag76)
-- Is_Eliminated (Flag124)
-- Is_Instantiated (Flag126) (generic case only)
-- Is_Interrupt_Handler (Flag89)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Invariant_Procedure (Flag257) (non-generic case only)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Null_Init_Proc (Flag178)
-- Is_Predicate_Function (Flag255) (non-generic case only)
-- Is_Predicate_Function_M (Flag256) (non-generic case only)
-- Is_Primitive (Flag218)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Private_Primitive (Flag245) (non-generic case only)
-- Is_Pure (Flag44)
-- Is_Valued_Procedure (Flag127)
-- Is_Visible_Lib_Unit (Flag116)
-- Needs_No_Actuals (Flag22)
-- No_Return (Flag113)
-- Requires_Overriding (Flag213) (non-generic case only)
-- Sec_Stack_Needed_For_Return (Flag167)
-- SPARK_Pragma_Inherited (Flag265)
-- Address_Clause (synth)
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
-- Is_Finalizer (synth)
-- Is_Ghost_Entity (synth) (non-generic case only)
-- Is_Ghost_Subprogram (synth) (non-generic case only)
-- Last_Formal (synth)
-- Number_Formals (synth)
-- E_Protected_Body
-- (any others??? First/Last Entity, Scope_Depth???)
-- E_Protected_Object
-- E_Protected_Type
-- E_Protected_Subtype
-- Direct_Primitive_Operations (Elist10)
-- Entry_Bodies_Array (Node15)
-- First_Private_Entity (Node16)
-- First_Entity (Node17)
-- Corresponding_Record_Type (Node18)
-- Last_Entity (Node20)
-- Discriminant_Constraint (Elist21)
-- Scope_Depth_Value (Uint22)
-- Scope_Depth (synth)
-- Stored_Constraint (Elist23)
-- Has_Interrupt_Handler (synth)
-- Sec_Stack_Needed_For_Return (Flag167) ???
-- Uses_Lock_Free (Flag188)
-- Uses_Sec_Stack (Flag95) ???
-- Has_Entries (synth)
-- Number_Entries (synth)
-- E_Record_Type
-- E_Record_Subtype
-- Direct_Primitive_Operations (Elist10)
-- Access_Disp_Table (Elist16) (base type only)
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Corresponding_Concurrent_Type (Node18)
-- Parent_Subtype (Node19) (base type only)
-- Last_Entity (Node20)
-- Discriminant_Constraint (Elist21)
-- Corresponding_Remote_Type (Node22)
-- Stored_Constraint (Elist23)
-- Interfaces (Elist25)
-- Dispatch_Table_Wrappers (Elist26) (base type only)
-- Underlying_Record_View (Node28) (base type only)
-- Component_Alignment (special) (base type only)
-- C_Pass_By_Copy (Flag125) (base type only)
-- Has_Dispatch_Table (Flag220) (base tagged type only)
-- Has_Pragma_Pack (Flag121) (impl base type only)
-- Has_Private_Ancestor (Flag151)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_Static_Discriminants (Flag211) (subtype only)
-- Is_Class_Wide_Equivalent_Type (Flag35)
-- Is_Concurrent_Record_Type (Flag20)
-- Is_Constrained (Flag12)
-- Is_Controlled (Flag42) (base type only)
-- Is_Interface (Flag186)
-- Is_Limited_Interface (Flag197)
-- OK_To_Reorder_Components (Flag239) (base type only)
-- Reverse_Bit_Order (Flag164) (base type only)
-- Reverse_Storage_Order (Flag93) (base type only)
-- SSO_Set_High_By_Default (Flag273) (base type only)
-- SSO_Set_Low_By_Default (Flag272) (base type only)
-- First_Component (synth)
-- First_Component_Or_Discriminant (synth)
-- (plus type attributes)
-- E_Record_Type_With_Private
-- E_Record_Subtype_With_Private
-- Direct_Primitive_Operations (Elist10)
-- First_Entity (Node17)
-- Private_Dependents (Elist18)
-- Underlying_Full_View (Node19)
-- Last_Entity (Node20)
-- Discriminant_Constraint (Elist21)
-- Private_View (Node22)
-- Stored_Constraint (Elist23)
-- Interfaces (Elist25)
-- Has_Completion (Flag26)
-- Has_Private_Ancestor (Flag151)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Is_Concurrent_Record_Type (Flag20)
-- Is_Constrained (Flag12)
-- Is_Controlled (Flag42) (base type only)
-- Is_Interface (Flag186)
-- Is_Limited_Interface (Flag197)
-- OK_To_Reorder_Components (Flag239) (base type only)
-- Reverse_Bit_Order (Flag164) (base type only)
-- Reverse_Storage_Order (Flag93) (base type only)
-- SSO_Set_High_By_Default (Flag273) (base type only)
-- SSO_Set_Low_By_Default (Flag272) (base type only)
-- First_Component (synth)
-- First_Component_Or_Discriminant (synth)
-- (plus type attributes)
-- E_Return_Statement
-- Return_Applies_To (Node8)
-- E_Signed_Integer_Type
-- E_Signed_Integer_Subtype
-- Default_Aspect_Value (Node19) (base type only)
-- Scalar_Range (Node20)
-- Static_Discrete_Predicate (List25)
-- Has_Biased_Representation (Flag139)
-- Has_Shift_Operator (Flag267) (base type only)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
-- (plus type attributes)
-- E_String_Literal_Subtype
-- String_Literal_Low_Bound (Node15)
-- String_Literal_Length (Uint16)
-- First_Index (Node17) (always Empty)
-- Packed_Array_Impl_Type (Node23)
-- (plus type attributes)
-- E_Subprogram_Body
-- Mechanism (Uint8)
-- First_Entity (Node17)
-- Corresponding_Protected_Entry (Node18)
-- Last_Entity (Node20)
-- Scope_Depth_Value (Uint22)
-- Extra_Formals (Node28)
-- SPARK_Pragma (Node32)
-- SPARK_Pragma_Inherited (Flag265)
-- Contract (Node34)
-- Scope_Depth (synth)
-- E_Subprogram_Type
-- Extra_Accessibility_Of_Result (Node19)
-- Directly_Designated_Type (Node20)
-- Extra_Formals (Node28)
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
-- Last_Formal (synth)
-- Number_Formals (synth)
-- (plus type attributes)
-- E_Task_Body
-- (any others??? First/Last Entity, Scope_Depth???)
-- E_Task_Type
-- E_Task_Subtype
-- Direct_Primitive_Operations (Elist10)
-- Storage_Size_Variable (Node15) (base type only)
-- First_Private_Entity (Node16)
-- First_Entity (Node17)
-- Corresponding_Record_Type (Node18)
-- Last_Entity (Node20)
-- Discriminant_Constraint (Elist21)
-- Scope_Depth_Value (Uint22)
-- Scope_Depth (synth)
-- Stored_Constraint (Elist23)
-- Task_Body_Procedure (Node25)
-- Delay_Cleanups (Flag114)
-- Has_Master_Entity (Flag21)
-- Has_Storage_Size_Clause (Flag23) (base type only)
-- Uses_Sec_Stack (Flag95) ???
-- Sec_Stack_Needed_For_Return (Flag167) ???
-- Has_Entries (synth)
-- Number_Entries (synth)
-- Relative_Deadline_Variable (Node26) (base type only)
-- (plus type attributes)
-- E_Variable
-- Hiding_Loop_Variable (Node8)
-- Current_Value (Node9)
-- Encapsulating_State (Node10)
-- Esize (Uint12)
-- Extra_Accessibility (Node13)
-- Alignment (Uint14)
-- Status_Flag_Or_Transient_Decl (Node15) (transient object only)
-- Unset_Reference (Node16)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
-- Size_Check_Code (Node19)
-- Prival_Link (Node20)
-- Interface_Name (Node21)
-- Shared_Var_Procs_Instance (Node22)
-- Extra_Constrained (Node23)
-- Related_Expression (Node24)
-- Debug_Renaming_Link (Node25)
-- Last_Assignment (Node26)
-- Related_Type (Node27)
-- Initialization_Statements (Node28)
-- BIP_Initialization_Call (Node29)
-- Last_Aggregate_Assignment (Node30)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
-- Has_Initial_Value (Flag219)
-- Has_Size_Clause (Flag29)
-- Has_Up_Level_Access (Flag215)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
-- Is_Processed_Transient (Flag252)
-- Is_Safe_To_Reevaluate (Flag249)
-- Is_Shared_Passive (Flag60)
-- Is_True_Constant (Flag163)
-- Is_Volatile (Flag16)
-- Is_Return_Object (Flag209)
-- OK_To_Rename (Flag247)
-- Optimize_Alignment_Space (Flag241)
-- Optimize_Alignment_Time (Flag242)
-- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
-- Is_Ghost_Entity (synth)
-- Size_Clause (synth)
-- E_Void
-- Since E_Void is the initial Ekind value of an entity when it is first
-- created, one might expect that no attributes would be defined on such
-- an entity until its Ekind field is set. However, in practice, there
-- are many instances in which fields of an E_Void entity are set in the
-- code prior to setting the Ekind field. This is not well documented or
-- well controlled, and needs cleaning up later. Meanwhile, the access
-- procedures in the body of Einfo permit many, but not all, attributes
-- to be applied to an E_Void entity, precisely so that this kind of
-- pre-setting of attributes works. This is really a hole in the dynamic
-- type checking, since there is no assurance that the eventual Ekind
-- value will be appropriate for the attributes set, and the consequence
-- is that the dynamic type checking in the Einfo body is unnecessarily
-- weak. To be looked at systematically some time ???
---------------------------------
-- Component_Alignment Control --
---------------------------------
-- There are four types of alignment possible for array and record
-- types, and a field in the type entities contains a value of the
-- following type indicating which alignment choice applies. For full
-- details of the meaning of these alignment types, see description
-- of the Component_Alignment pragma
type Component_Alignment_Kind is (
Calign_Default, -- default alignment
Calign_Component_Size, -- natural alignment for component size
Calign_Component_Size_4, -- natural for size <= 4, 4 for size >= 4
Calign_Storage_Unit); -- all components byte aligned
-----------------------------------
-- Floating Point Representation --
-----------------------------------
type Float_Rep_Kind is (
IEEE_Binary, -- IEEE 754p conform binary format
VAX_Native, -- VAX D, F, G or H format
AAMP); -- AAMP format
---------------
-- Iterators --
---------------
-- In addition to attributes that are stored as plain data, other
-- attributes are procedural, and require some small amount of
-- computation. Of course, from the point of view of a user of this
-- package, the distinction is not visible (even the field information
-- provided below should be disregarded, as it is subject to change
-- without notice). A number of attributes appear as lists: lists of
-- formals, lists of actuals, of discriminants, etc. For these, pairs
-- of functions are defined, which take the form:
-- function First_Thing (E : Enclosing_Construct) return Thing;
-- function Next_Thing (T : Thing) return Thing;
-- The end of iteration is always signaled by a value of Empty, so that
-- loops over these chains invariably have the form:
-- This : Thing;
-- ...
-- This := First_Thing (E);
-- while Present (This) loop
-- Do_Something_With (This);
-- ...
-- This := Next_Thing (This);
-- end loop;
-----------------------------------
-- Handling of Check Suppression --
-----------------------------------
-- There are three ways that checks can be suppressed:
-- 1. At the command line level
-- 2. At the scope level.
-- 3. At the entity level.
-- See spec of Sem in sem.ads for details of the data structures used
-- to keep track of these various methods for suppressing checks.
-------------------------------
-- Handling of Discriminants --
-------------------------------
-- During semantic processing, discriminants are separate entities which
-- reflect the semantic properties and allowed usage of discriminants in
-- the language.
-- In the case of discriminants used as bounds, the references are handled
-- directly, since special processing is needed in any case. However, there
-- are two circumstances in which discriminants are referenced in a quite
-- general manner, like any other variables:
-- In initialization expressions for records. Note that the expressions
-- used in Priority, Storage_Size, Task_Info and Relative_Deadline
-- pragmas are effectively in this category, since these pragmas are
-- converted to initialized record fields in the Corresponding_Record_
-- Type.
-- In task and protected bodies, where the discriminant values may be
-- referenced freely within these bodies. Discriminants can also appear
-- in bounds of entry families and in defaults of operations.
-- In both these cases, the discriminants must be treated essentially as
-- objects. The following approach is used to simplify and minimize the
-- special processing that is required.
-- When a record type with discriminants is analyzed, semantic processing
-- creates the entities for the discriminants. It also creates additional
-- sets of entities called discriminals, one for each of the discriminants,
-- and the Discriminal field of the discriminant entity points to this
-- additional entity, which is initially created as an uninitialized
-- (E_Void) entity.
-- During expansion of expressions, any discriminant reference is replaced
-- by a reference to the corresponding discriminal. When the initialization
-- procedure for the record is created (there will always be one, since
-- discriminants are present, see Exp_Ch3 for further details), the
-- discriminals are used as the entities for the formal parameters of
-- this initialization procedure. The references to these discriminants
-- have already been replaced by references to these discriminals, which
-- are now the formal parameters corresponding to the required objects.
-- In the case of a task or protected body, the semantics similarly creates
-- a set of discriminals for the discriminants of the task or protected
-- type. When the procedure is created for the task body, the parameter
-- passed in is a reference to the task value type, which contains the
-- required discriminant values. The expander creates a set of declarations
-- of the form:
-- discr_nameD : constant discr_type renames _task.discr_name;
-- where discr_nameD is the discriminal entity referenced by the task
-- discriminant, and _task is the task value passed in as the parameter.
-- Again, any references to discriminants in the task body have been
-- replaced by the discriminal reference, which is now an object that
-- contains the required value.
-- This approach for tasks means that two sets of discriminals are needed
-- for a task type, one for the initialization procedure, and one for the
-- task body. This works out nicely, since the semantics allocates one set
-- for the task itself, and one set for the corresponding record.
-- The one bit of trickiness arises in making sure that the right set of
-- discriminals is used at the right time. First the task definition is
-- processed. Any references to discriminants here are replaced by the
-- corresponding *task* discriminals (the record type doesn't even exist
-- yet, since it is constructed as part of the expansion of the task
-- declaration, which happens after the semantic processing of the task
-- definition). The discriminants to be used for the corresponding record
-- are created at the same time as the other discriminals, and held in the
-- CR_Discriminant field of the discriminant. A use of the discriminant in
-- a bound for an entry family is replaced with the CR_Discriminant because
-- it controls the bound of the entry queue array which is a component of
-- the corresponding record.
-- Just before the record initialization routine is constructed, the
-- expander exchanges the task and record discriminals. This has two
-- effects. First the generation of the record initialization routine
-- uses the discriminals that are now on the record, which is the set
-- that used to be on the task, which is what we want.
-- Second, a new set of (so far unused) discriminals is now on the task
-- discriminants, and it is this set that will be used for expanding the
-- task body, and also for the discriminal declarations at the start of
-- the task body.
---------------------------------------------------
-- Handling of private data in protected objects --
---------------------------------------------------
-- Private components in protected types pose problems similar to those
-- of discriminants. Private data is visible and can be directly referenced
-- from protected bodies. However, when protected entries and subprograms
-- are expanded into corresponding bodies and barrier functions, private
-- components lose their original context and visibility.
-- To remedy this side effect of expansion, private components are expanded
-- into renamings called "privals", by analogy with "discriminals".
-- private_comp : comp_type renames _object.private_comp;
-- Prival declarations are inserted during the analysis of subprogram and
-- entry bodies to ensure proper visibility for any subsequent expansion.
-- _Object is the formal parameter of the generated corresponding body or
-- a local renaming which denotes the protected object obtained from entry
-- parameter _O. Privals receive minimal decoration upon creation and are
-- categorized as either E_Variable for the general case or E_Constant when
-- they appear in functions.
-- Along with the local declarations, each private component carries a
-- placeholder which references the prival entity in the current body. This
-- form of indirection is used to resolve name clashes of privals and other
-- locally visible entities such as parameters, local objects, entry family
-- indexes or identifiers used in the barrier condition.
-- When analyzing the statements of a protected subprogram or entry, any
-- reference to a private component must resolve to the locally declared
-- prival through normal visibility. In case of name conflicts (the cases
-- above), the prival is marked as hidden and acts as a weakly declared
-- entity. As a result, the reference points to the correct entity. When a
-- private component is denoted by an expanded name (prot_type.comp for
-- example), the expansion mechanism uses the placeholder of the component
-- to correct the Entity and Etype of the reference.
-------------------
-- Type Synonyms --
-------------------
-- The following type synonyms are used to tidy up the function and
-- procedure declarations that follow, and also to make it possible to meet
-- the requirement for the XEINFO utility that all function specs must fit
-- on a single source line.
subtype B is Boolean;
subtype C is Component_Alignment_Kind;
subtype E is Entity_Id;
subtype F is Float_Rep_Kind;
subtype M is Mechanism_Type;
subtype N is Node_Id;
subtype U is Uint;
subtype R is Ureal;
subtype L is Elist_Id;
subtype S is List_Id;
--------------------------------
-- Attribute Access Functions --
--------------------------------
-- All attributes are manipulated through a procedural interface. This
-- section contains the functions used to obtain attribute values which
-- correspond to values in fields or flags in the entity itself.
function Abstract_States (Id : E) return L;
function Accept_Address (Id : E) return L;
function Access_Disp_Table (Id : E) return L;
function Actual_Subtype (Id : E) return E;
function Address_Taken (Id : E) return B;
function Alias (Id : E) return E;
function Alignment (Id : E) return U;
function Associated_Formal_Package (Id : E) return E;
function Associated_Node_For_Itype (Id : E) return N;
function Associated_Storage_Pool (Id : E) return E;
function Barrier_Function (Id : E) return N;
function Block_Node (Id : E) return N;
function Body_Entity (Id : E) return E;
function Body_Needed_For_SAL (Id : E) return B;
function Body_References (Id : E) return L;
function BIP_Initialization_Call (Id : E) return N;
function CR_Discriminant (Id : E) return E;
function C_Pass_By_Copy (Id : E) return B;
function Can_Never_Be_Null (Id : E) return B;
function Can_Use_Internal_Rep (Id : E) return B;
function Checks_May_Be_Suppressed (Id : E) return B;
function Class_Wide_Type (Id : E) return E;
function Cloned_Subtype (Id : E) return E;
function Component_Alignment (Id : E) return C;
function Component_Bit_Offset (Id : E) return U;
function Component_Clause (Id : E) return N;
function Component_Size (Id : E) return U;
function Component_Type (Id : E) return E;
function Contract (Id : E) return N;
function Corresponding_Concurrent_Type (Id : E) return E;
function Corresponding_Discriminant (Id : E) return E;
function Corresponding_Equality (Id : E) return E;
function Corresponding_Protected_Entry (Id : E) return E;
function Corresponding_Record_Type (Id : E) return E;
function Corresponding_Remote_Type (Id : E) return E;
function Current_Use_Clause (Id : E) return E;
function Current_Value (Id : E) return N;
function DTC_Entity (Id : E) return E;
function DT_Entry_Count (Id : E) return U;
function DT_Offset_To_Top_Func (Id : E) return E;
function DT_Position (Id : E) return U;
function Debug_Info_Off (Id : E) return B;
function Debug_Renaming_Link (Id : E) return E;
function Default_Aspect_Component_Value (Id : E) return N;
function Default_Aspect_Value (Id : E) return N;
function Default_Expr_Function (Id : E) return E;
function Default_Expressions_Processed (Id : E) return B;
function Default_Value (Id : E) return N;
function Delay_Cleanups (Id : E) return B;
function Delay_Subprogram_Descriptors (Id : E) return B;
function Delta_Value (Id : E) return R;
function Dependent_Instances (Id : E) return L;
function Depends_On_Private (Id : E) return B;
function Derived_Type_Link (Id : E) return E;
function Digits_Value (Id : E) return U;
function Direct_Primitive_Operations (Id : E) return L;
function Directly_Designated_Type (Id : E) return E;
function Discard_Names (Id : E) return B;
function Discriminal (Id : E) return E;
function Discriminal_Link (Id : E) return E;
function Discriminant_Checking_Func (Id : E) return E;
function Discriminant_Constraint (Id : E) return L;
function Discriminant_Default_Value (Id : E) return N;
function Discriminant_Number (Id : E) return U;
function Dispatch_Table_Wrappers (Id : E) return L;
function Elaborate_Body_Desirable (Id : E) return B;
function Elaboration_Entity (Id : E) return E;
function Elaboration_Entity_Required (Id : E) return B;
function Encapsulating_State (Id : E) return E;
function Enclosing_Scope (Id : E) return E;
function Entry_Accepted (Id : E) return B;
function Entry_Bodies_Array (Id : E) return E;
function Entry_Cancel_Parameter (Id : E) return E;
function Entry_Component (Id : E) return E;
function Entry_Formal (Id : E) return E;
function Entry_Index_Constant (Id : E) return E;
function Entry_Index_Type (Id : E) return E;
function Entry_Parameters_Type (Id : E) return E;
function Enum_Pos_To_Rep (Id : E) return E;
function Enumeration_Pos (Id : E) return U;
function Enumeration_Rep (Id : E) return U;
function Enumeration_Rep_Expr (Id : E) return N;
function Equivalent_Type (Id : E) return E;
function Esize (Id : E) return U;
function Exception_Code (Id : E) return U;
function Extra_Accessibility (Id : E) return E;
function Extra_Accessibility_Of_Result (Id : E) return E;
function Extra_Constrained (Id : E) return E;
function Extra_Formal (Id : E) return E;
function Extra_Formals (Id : E) return E;
function Finalization_Master (Id : E) return E;
function Finalize_Storage_Only (Id : E) return B;
function Finalizer (Id : E) return E;
function First_Entity (Id : E) return E;
function First_Exit_Statement (Id : E) return N;
function First_Index (Id : E) return N;
function First_Literal (Id : E) return E;
function First_Optional_Parameter (Id : E) return E;
function First_Private_Entity (Id : E) return E;
function First_Rep_Item (Id : E) return N;
function Float_Rep (Id : E) return F;
function Freeze_Node (Id : E) return N;
function From_Limited_With (Id : E) return B;
function Full_View (Id : E) return E;
function Generic_Homonym (Id : E) return E;
function Generic_Renamings (Id : E) return L;
function Handler_Records (Id : E) return S;
function Has_Aliased_Components (Id : E) return B;
function Has_Alignment_Clause (Id : E) return B;
function Has_All_Calls_Remote (Id : E) return B;
function Has_Anonymous_Master (Id : E) return B;
function Has_Atomic_Components (Id : E) return B;
function Has_Biased_Representation (Id : E) return B;
function Has_Completion (Id : E) return B;
function Has_Completion_In_Body (Id : E) return B;
function Has_Complex_Representation (Id : E) return B;
function Has_Component_Size_Clause (Id : E) return B;
function Has_Constrained_Partial_View (Id : E) return B;
function Has_Contiguous_Rep (Id : E) return B;
function Has_Controlled_Component (Id : E) return B;
function Has_Controlling_Result (Id : E) return B;
function Has_Convention_Pragma (Id : E) return B;
function Has_Default_Aspect (Id : E) return B;
function Has_Delayed_Aspects (Id : E) return B;
function Has_Delayed_Freeze (Id : E) return B;
function Has_Delayed_Rep_Aspects (Id : E) return B;
function Has_Discriminants (Id : E) return B;
function Has_Dispatch_Table (Id : E) return B;
function Has_Dynamic_Predicate_Aspect (Id : E) return B;
function Has_Enumeration_Rep_Clause (Id : E) return B;
function Has_Exit (Id : E) return B;
function Has_Forward_Instantiation (Id : E) return B;
function Has_Fully_Qualified_Name (Id : E) return B;
function Has_Gigi_Rep_Item (Id : E) return B;
function Has_Homonym (Id : E) return B;
function Has_Implicit_Dereference (Id : E) return B;
function Has_Independent_Components (Id : E) return B;
function Has_Inheritable_Invariants (Id : E) return B;
function Has_Initial_Value (Id : E) return B;
function Has_Interrupt_Handler (Id : E) return B;
function Has_Invariants (Id : E) return B;
function Has_Loop_Entry_Attributes (Id : E) return B;
function Has_Machine_Radix_Clause (Id : E) return B;
function Has_Master_Entity (Id : E) return B;
function Has_Missing_Return (Id : E) return B;
function Has_Nested_Block_With_Handler (Id : E) return B;
function Has_Non_Standard_Rep (Id : E) return B;
function Has_Object_Size_Clause (Id : E) return B;
function Has_Out_Or_In_Out_Parameter (Id : E) return B;
function Has_Per_Object_Constraint (Id : E) return B;
function Has_Postconditions (Id : E) return B;
function Has_Pragma_Controlled (Id : E) return B;
function Has_Pragma_Elaborate_Body (Id : E) return B;
function Has_Pragma_Inline (Id : E) return B;
function Has_Pragma_Inline_Always (Id : E) return B;
function Has_Pragma_No_Inline (Id : E) return B;
function Has_Pragma_Ordered (Id : E) return B;
function Has_Pragma_Pack (Id : E) return B;
function Has_Pragma_Preelab_Init (Id : E) return B;
function Has_Pragma_Pure (Id : E) return B;
function Has_Pragma_Pure_Function (Id : E) return B;
function Has_Pragma_Thread_Local_Storage (Id : E) return B;
function Has_Pragma_Unmodified (Id : E) return B;
function Has_Pragma_Unreferenced (Id : E) return B;
function Has_Pragma_Unreferenced_Objects (Id : E) return B;
function Has_Predicates (Id : E) return B;
function Has_Primitive_Operations (Id : E) return B;
function Has_Private_Ancestor (Id : E) return B;
function Has_Private_Declaration (Id : E) return B;
function Has_Protected (Id : E) return B;
function Has_Qualified_Name (Id : E) return B;
function Has_RACW (Id : E) return B;
function Has_Record_Rep_Clause (Id : E) return B;
function Has_Recursive_Call (Id : E) return B;
function Has_Shift_Operator (Id : E) return B;
function Has_Size_Clause (Id : E) return B;
function Has_Small_Clause (Id : E) return B;
function Has_Specified_Layout (Id : E) return B;
function Has_Specified_Stream_Input (Id : E) return B;
function Has_Specified_Stream_Output (Id : E) return B;
function Has_Specified_Stream_Read (Id : E) return B;
function Has_Specified_Stream_Write (Id : E) return B;
function Has_Static_Discriminants (Id : E) return B;
function Has_Static_Predicate (Id : E) return B;
function Has_Static_Predicate_Aspect (Id : E) return B;
function Has_Storage_Size_Clause (Id : E) return B;
function Has_Stream_Size_Clause (Id : E) return B;
function Has_Task (Id : E) return B;
function Has_Thunks (Id : E) return B;
function Has_Unchecked_Union (Id : E) return B;
function Has_Unknown_Discriminants (Id : E) return B;
function Has_Up_Level_Access (Id : E) return B;
function Has_Visible_Refinement (Id : E) return B;
function Has_Volatile_Components (Id : E) return B;
function Has_Xref_Entry (Id : E) return B;
function Hiding_Loop_Variable (Id : E) return E;
function Homonym (Id : E) return E;
function Import_Pragma (Id : E) return E;
function In_Package_Body (Id : E) return B;
function In_Private_Part (Id : E) return B;
function In_Use (Id : E) return B;
function Initialization_Statements (Id : E) return N;
function Inner_Instances (Id : E) return L;
function Interface_Alias (Id : E) return E;
function Interface_Name (Id : E) return N;
function Interfaces (Id : E) return L;
function Is_AST_Entry (Id : E) return B;
function Is_Abstract_Subprogram (Id : E) return B;
function Is_Abstract_Type (Id : E) return B;
function Is_Access_Constant (Id : E) return B;
function Is_Ada_2005_Only (Id : E) return B;
function Is_Ada_2012_Only (Id : E) return B;
function Is_Aliased (Id : E) return B;
function Is_Asynchronous (Id : E) return B;
function Is_Atomic (Id : E) return B;
function Is_Bit_Packed_Array (Id : E) return B;
function Is_CPP_Class (Id : E) return B;
function Is_Called (Id : E) return B;
function Is_Character_Type (Id : E) return B;
function Is_Child_Unit (Id : E) return B;
function Is_Class_Wide_Equivalent_Type (Id : E) return B;
function Is_Compilation_Unit (Id : E) return B;
function Is_Completely_Hidden (Id : E) return B;
function Is_Constr_Subt_For_UN_Aliased (Id : E) return B;
function Is_Constr_Subt_For_U_Nominal (Id : E) return B;
function Is_Constrained (Id : E) return B;
function Is_Constructor (Id : E) return B;
function Is_Controlled (Id : E) return B;
function Is_Controlling_Formal (Id : E) return B;
function Is_Descendent_Of_Address (Id : E) return B;
function Is_Discrim_SO_Function (Id : E) return B;
function Is_Discriminant_Check_Function (Id : E) return B;
function Is_Dispatch_Table_Entity (Id : E) return B;
function Is_Dispatching_Operation (Id : E) return B;
function Is_Eliminated (Id : E) return B;
function Is_Entry_Formal (Id : E) return B;
function Is_Exported (Id : E) return B;
function Is_First_Subtype (Id : E) return B;
function Is_For_Access_Subtype (Id : E) return B;
function Is_Frozen (Id : E) return B;
function Is_Generic_Instance (Id : E) return B;
function Is_Hidden (Id : E) return B;
function Is_Hidden_Open_Scope (Id : E) return B;
function Is_Immediately_Visible (Id : E) return B;
function Is_Implementation_Defined (Id : E) return B;
function Is_Imported (Id : E) return B;
function Is_Independent (Id : E) return B;
function Is_Inlined (Id : E) return B;
function Is_Instantiated (Id : E) return B;
function Is_Interface (Id : E) return B;
function Is_Internal (Id : E) return B;
function Is_Interrupt_Handler (Id : E) return B;
function Is_Intrinsic_Subprogram (Id : E) return B;
function Is_Invariant_Procedure (Id : E) return B;
function Is_Itype (Id : E) return B;
function Is_Known_Non_Null (Id : E) return B;
function Is_Known_Null (Id : E) return B;
function Is_Known_Valid (Id : E) return B;
function Is_Limited_Composite (Id : E) return B;
function Is_Limited_Interface (Id : E) return B;
function Is_Local_Anonymous_Access (Id : E) return B;
function Is_Machine_Code_Subprogram (Id : E) return B;
function Is_Non_Static_Subtype (Id : E) return B;
function Is_Null_Init_Proc (Id : E) return B;
function Is_Obsolescent (Id : E) return B;
function Is_Only_Out_Parameter (Id : E) return B;
function Is_Optional_Parameter (Id : E) return B;
function Is_Package_Body_Entity (Id : E) return B;
function Is_Packed (Id : E) return B;
function Is_Packed_Array_Impl_Type (Id : E) return B;
function Is_Potentially_Use_Visible (Id : E) return B;
function Is_Predicate_Function (Id : E) return B;
function Is_Predicate_Function_M (Id : E) return B;
function Is_Preelaborated (Id : E) return B;
function Is_Primitive (Id : E) return B;
function Is_Primitive_Wrapper (Id : E) return B;
function Is_Private_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B;
function Is_Private_Primitive (Id : E) return B;
function Is_Processed_Transient (Id : E) return B;
function Is_Public (Id : E) return B;
function Is_Pure (Id : E) return B;
function Is_Pure_Unit_Access_Type (Id : E) return B;
function Is_RACW_Stub_Type (Id : E) return B;
function Is_Raised (Id : E) return B;
function Is_Remote_Call_Interface (Id : E) return B;
function Is_Remote_Types (Id : E) return B;
function Is_Renaming_Of_Object (Id : E) return B;
function Is_Return_Object (Id : E) return B;
function Is_Safe_To_Reevaluate (Id : E) return B;
function Is_Shared_Passive (Id : E) return B;
function Is_Statically_Allocated (Id : E) return B;
function Is_Tag (Id : E) return B;
function Is_Tagged_Type (Id : E) return B;
function Is_Thunk (Id : E) return B;
function Is_Trivial_Subprogram (Id : E) return B;
function Is_True_Constant (Id : E) return B;
function Is_Unchecked_Union (Id : E) return B;
function Is_Underlying_Record_View (Id : E) return B;
function Is_Unsigned_Type (Id : E) return B;
function Is_VMS_Exception (Id : E) return B;
function Is_Valued_Procedure (Id : E) return B;
function Is_Visible_Formal (Id : E) return B;
function Is_Visible_Lib_Unit (Id : E) return B;
function Is_Volatile (Id : E) return B;
function Itype_Printed (Id : E) return B;
function Kill_Elaboration_Checks (Id : E) return B;
function Kill_Range_Checks (Id : E) return B;
function Known_To_Have_Preelab_Init (Id : E) return B;
function Last_Aggregate_Assignment (Id : E) return N;
function Last_Assignment (Id : E) return N;
function Last_Entity (Id : E) return E;
function Limited_View (Id : E) return E;
function Linker_Section_Pragma (Id : E) return N;
function Lit_Indexes (Id : E) return E;
function Lit_Strings (Id : E) return E;
function Low_Bound_Tested (Id : E) return B;
function Machine_Radix_10 (Id : E) return B;
function Master_Id (Id : E) return E;
function Materialize_Entity (Id : E) return B;
function May_Inherit_Delayed_Rep_Aspects (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 Must_Have_Preelab_Init (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;
function Next_Inlined_Subprogram (Id : E) return E;
function No_Pool_Assigned (Id : E) return B;
function No_Return (Id : E) return B;
function No_Strict_Aliasing (Id : E) return B;
function Non_Binary_Modulus (Id : E) return B;
function Non_Limited_View (Id : E) return E;
function Nonzero_Is_True (Id : E) return B;
function Normalized_First_Bit (Id : E) return U;
function Normalized_Position (Id : E) return U;
function Normalized_Position_Max (Id : E) return U;
function OK_To_Rename (Id : E) return B;
function OK_To_Reorder_Components (Id : E) return B;
function Optimize_Alignment_Space (Id : E) return B;
function Optimize_Alignment_Time (Id : E) return B;
function Original_Access_Type (Id : E) return E;
function Original_Array_Type (Id : E) return E;
function Original_Record_Component (Id : E) return E;
function Overlays_Constant (Id : E) return B;
function Overridden_Operation (Id : E) return E;
function PPC_Wrapper (Id : E) return E;
function Package_Instantiation (Id : E) return N;
function Packed_Array_Impl_Type (Id : E) return E;
function Parent_Subtype (Id : E) return E;
function Part_Of_Constituents (Id : E) return L;
function Postcondition_Proc (Id : E) return E;
function Prival (Id : E) return E;
function Prival_Link (Id : E) return E;
function Private_Dependents (Id : E) return L;
function Private_View (Id : E) return N;
function Protected_Body_Subprogram (Id : E) return E;
function Protected_Formal (Id : E) return E;
function Protection_Object (Id : E) return E;
function RM_Size (Id : E) return U;
function Reachable (Id : E) return B;
function Referenced (Id : E) return B;
function Referenced_As_LHS (Id : E) return B;
function Referenced_As_Out_Parameter (Id : E) return B;
function Refinement_Constituents (Id : E) return L;
function Register_Exception_Call (Id : E) return N;
function Related_Array_Object (Id : E) return E;
function Related_Expression (Id : E) return N;
function Related_Instance (Id : E) return E;
function Related_Type (Id : E) return E;
function Relative_Deadline_Variable (Id : E) return E;
function Renamed_Entity (Id : E) return N;
function Renamed_In_Spec (Id : E) return B;
function Renamed_Object (Id : E) return N;
function Renaming_Map (Id : E) return U;
function Requires_Overriding (Id : E) return B;
function Return_Applies_To (Id : E) return N;
function Return_Present (Id : E) return B;
function Returns_By_Ref (Id : E) return B;
function Reverse_Bit_Order (Id : E) return B;
function Reverse_Storage_Order (Id : E) return B;
function Scalar_Range (Id : E) return N;
function Scale_Value (Id : E) return U;
function Scope_Depth_Value (Id : E) return U;
function Sec_Stack_Needed_For_Return (Id : E) return B;
function Shadow_Entities (Id : E) return S;
function Shared_Var_Procs_Instance (Id : E) return E;
function Size_Check_Code (Id : E) return N;
function Size_Depends_On_Discriminant (Id : E) return B;
function Size_Known_At_Compile_Time (Id : E) return B;
function Small_Value (Id : E) return R;
function SPARK_Aux_Pragma (Id : E) return N;
function SPARK_Aux_Pragma_Inherited (Id : E) return B;
function SPARK_Pragma (Id : E) return N;
function SPARK_Pragma_Inherited (Id : E) return B;
function Spec_Entity (Id : E) return E;
function SSO_Set_High_By_Default (Id : E) return B;
function SSO_Set_Low_By_Default (Id : E) return B;
function Static_Elaboration_Desired (Id : E) return B;
function Static_Initialization (Id : E) return N;
function Static_Discrete_Predicate (Id : E) return S;
function Static_Real_Or_String_Predicate (Id : E) return N;
function Status_Flag_Or_Transient_Decl (Id : E) return E;
function Storage_Size_Variable (Id : E) return E;
function Stored_Constraint (Id : E) return L;
function Stores_Attribute_Old_Prefix (Id : E) return B;
function Strict_Alignment (Id : E) return B;
function String_Literal_Length (Id : E) return U;
function String_Literal_Low_Bound (Id : E) return N;
function Subprograms_For_Type (Id : E) return E;
function Suppress_Elaboration_Warnings (Id : E) return B;
function Suppress_Initialization (Id : E) return B;
function Suppress_Style_Checks (Id : E) return B;
function Suppress_Value_Tracking_On_Call (Id : E) return B;
function Task_Body_Procedure (Id : E) return N;
function Thunk_Entity (Id : E) return E;
function Treat_As_Volatile (Id : E) return B;
function Underlying_Full_View (Id : E) return E;
function Underlying_Record_View (Id : E) return E;
function Universal_Aliasing (Id : E) return B;
function Unset_Reference (Id : E) return N;
function Used_As_Generic_Actual (Id : E) return B;
function Uses_Lock_Free (Id : E) return B;
function Uses_Sec_Stack (Id : E) return B;
function Vax_Float (Id : E) return B;
function Warnings_Off (Id : E) return B;
function Warnings_Off_Used (Id : E) return B;
function Warnings_Off_Used_Unmodified (Id : E) return B;
function Warnings_Off_Used_Unreferenced (Id : E) return B;
function Was_Hidden (Id : E) return B;
function Wrapped_Entity (Id : E) return E;
-------------------------------
-- Classification Attributes --
-------------------------------
-- These functions provide a convenient functional notation for testing
-- whether an Ekind value belongs to a specified kind, for example the
-- function Is_Elementary_Type tests if its argument is in Elementary_Kind.
-- In some cases, the test is of an entity attribute (e.g. in the case of
-- Is_Generic_Type where the Ekind does not provide the needed information)
function Is_Access_Type (Id : E) return B;
function Is_Access_Protected_Subprogram_Type (Id : E) return B;
function Is_Access_Subprogram_Type (Id : E) return B;
function Is_Aggregate_Type (Id : E) return B;
function Is_Array_Type (Id : E) return B;
function Is_Assignable (Id : E) return B;
function Is_Class_Wide_Type (Id : E) return B;
function Is_Composite_Type (Id : E) return B;
function Is_Concurrent_Body (Id : E) return B;
function Is_Concurrent_Record_Type (Id : E) return B;
function Is_Concurrent_Type (Id : E) return B;
function Is_Decimal_Fixed_Point_Type (Id : E) return B;
function Is_Digits_Type (Id : E) return B;
function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B;
function Is_Discrete_Type (Id : E) return B;
function Is_Elementary_Type (Id : E) return B;
function Is_Entry (Id : E) return B;
function Is_Enumeration_Type (Id : E) return B;
function Is_Fixed_Point_Type (Id : E) return B;
function Is_Floating_Point_Type (Id : E) return B;
function Is_Formal (Id : E) return B;
function Is_Formal_Object (Id : E) return B;
function Is_Formal_Subprogram (Id : E) return B;
function Is_Generic_Actual_Type (Id : E) return B;
function Is_Generic_Unit (Id : E) return B;
function Is_Generic_Type (Id : E) return B;
function Is_Generic_Subprogram (Id : E) return B;
function Is_Incomplete_Or_Private_Type (Id : E) return B;
function Is_Incomplete_Type (Id : E) return B;
function Is_Integer_Type (Id : E) return B;
function Is_Limited_Record (Id : E) return B;
function Is_Modular_Integer_Type (Id : E) return B;
function Is_Named_Number (Id : E) return B;
function Is_Numeric_Type (Id : E) return B;
function Is_Object (Id : E) return B;
function Is_Ordinary_Fixed_Point_Type (Id : E) return B;
function Is_Overloadable (Id : E) return B;
function Is_Private_Type (Id : E) return B;
function Is_Protected_Type (Id : E) return B;
function Is_Real_Type (Id : E) return B;
function Is_Record_Type (Id : E) return B;
function Is_Scalar_Type (Id : E) return B;
function Is_Signed_Integer_Type (Id : E) return B;
function Is_Subprogram (Id : E) return B;
function Is_Task_Type (Id : E) return B;
function Is_Type (Id : E) return B;
-------------------------------------
-- Synthesized Attribute Functions --
-------------------------------------
-- The functions in this section synthesize attributes from the tree,
-- so they do not correspond to defined fields in the entity itself.
function Address_Clause (Id : E) return N;
function Aft_Value (Id : E) return U;
function Alignment_Clause (Id : E) return N;
function Base_Type (Id : E) return E;
function Declaration_Node (Id : E) return N;
function Designated_Type (Id : E) return E;
function First_Component (Id : E) return E;
function First_Component_Or_Discriminant (Id : E) return E;
function First_Formal (Id : E) return E;
function First_Formal_With_Extras (Id : E) return E;
function Has_Attach_Handler (Id : E) return B;
function Has_Entries (Id : E) return B;
function Has_Foreign_Convention (Id : E) return B;
function Has_Non_Null_Refinement (Id : E) return B;
function Has_Null_Abstract_State (Id : E) return B;
function Has_Null_Refinement (Id : E) return B;
function Implementation_Base_Type (Id : E) return E;
function Is_Base_Type (Id : E) return B;
function Is_Boolean_Type (Id : E) return B;
function Is_Constant_Object (Id : E) return B;
function Is_Discriminal (Id : E) return B;
function Is_Dynamic_Scope (Id : E) return B;
function Is_External_State (Id : E) return B;
function Is_Finalizer (Id : E) return B;
function Is_Ghost_Entity (Id : E) return B;
function Is_Ghost_Subprogram (Id : E) return B;
function Is_Null_State (Id : E) return B;
function Is_Package_Or_Generic_Package (Id : E) return B;
function Is_Packed_Array (Id : E) return B;
function Is_Prival (Id : E) return B;
function Is_Protected_Component (Id : E) return B;
function Is_Protected_Interface (Id : E) return B;
function Is_Protected_Record_Type (Id : E) return B;
function Is_Standard_Character_Type (Id : E) return B;
function Is_String_Type (Id : E) return B;
function Is_Synchronized_Interface (Id : E) return B;
function Is_Task_Interface (Id : E) return B;
function Is_Task_Record_Type (Id : E) return B;
function Is_Wrapper_Package (Id : E) return B;
function Last_Formal (Id : E) return E;
function Machine_Emax_Value (Id : E) return U;
function Machine_Emin_Value (Id : E) return U;
function Machine_Mantissa_Value (Id : E) return U;
function Machine_Radix_Value (Id : E) return U;
function Model_Emin_Value (Id : E) return U;
function Model_Epsilon_Value (Id : E) return R;
function Model_Mantissa_Value (Id : E) return U;
function Model_Small_Value (Id : E) return R;
function Next_Component (Id : E) return E;
function Next_Component_Or_Discriminant (Id : E) return E;
function Next_Discriminant (Id : E) return E;
function Next_Formal (Id : E) return E;
function Next_Formal_With_Extras (Id : E) return E;
function Next_Literal (Id : E) return E;
function Next_Stored_Discriminant (Id : E) return E;
function Number_Dimensions (Id : E) return Pos;
function Number_Entries (Id : E) return Nat;
function Number_Formals (Id : E) return Pos;
function Parameter_Mode (Id : E) return Formal_Kind;
function Primitive_Operations (Id : E) return L;
function Root_Type (Id : E) return E;
function Safe_Emax_Value (Id : E) return U;
function Safe_First_Value (Id : E) return R;
function Safe_Last_Value (Id : E) return R;
function Scope_Depth_Set (Id : E) return B;
function Size_Clause (Id : E) return N;
function Stream_Size_Clause (Id : E) return N;
function Type_High_Bound (Id : E) return N;
function Type_Low_Bound (Id : E) return N;
function Underlying_Type (Id : E) return E;
----------------------------------------------
-- Type Representation Attribute Predicates --
----------------------------------------------
-- These predicates test the setting of the indicated attribute. If the
-- value has been set, then Known is True, and Unknown is False. If no
-- value is set, then Known is False and Unknown is True. The Known_Static
-- predicate is true only if the value is set (Known) and is set to a
-- compile time known value. Note that in the case of Alignment and
-- Normalized_First_Bit, dynamic values are not possible, so we do not
-- need a separate Known_Static calls in these cases. The not set (unknown)
-- values are as follows:
-- Alignment Uint_0 or No_Uint
-- Component_Size Uint_0 or No_Uint
-- Component_Bit_Offset No_Uint
-- Digits_Value Uint_0 or No_Uint
-- Esize Uint_0 or No_Uint
-- Normalized_First_Bit No_Uint
-- Normalized_Position No_Uint
-- Normalized_Position_Max No_Uint
-- RM_Size Uint_0 or No_Uint
-- It would be cleaner to use No_Uint in all these cases, but historically
-- we chose to use Uint_0 at first, and the change over will take time ???
-- This is particularly true for the RM_Size field, where a value of zero
-- is legitimate. We deal with this by a considering that the value is
-- always known static for discrete types (and no other types can have
-- an RM_Size value of zero).
-- In two cases, Known_Static_Esize and Known_Static_RM_Size, there is one
-- more consideration, which is that we always return False for generic
-- types. Within a template, the size can look known, because of the fake
-- size values we put in template types, but they are not really known and
-- anyone testing if they are known within the template should get False as
-- a result to prevent incorrect assumptions.
function Known_Alignment (E : Entity_Id) return B;
function Known_Component_Bit_Offset (E : Entity_Id) return B;
function Known_Component_Size (E : Entity_Id) return B;
function Known_Esize (E : Entity_Id) return B;
function Known_Normalized_First_Bit (E : Entity_Id) return B;
function Known_Normalized_Position (E : Entity_Id) return B;
function Known_Normalized_Position_Max (E : Entity_Id) return B;
function Known_RM_Size (E : Entity_Id) return B;
function Known_Static_Component_Bit_Offset (E : Entity_Id) return B;
function Known_Static_Component_Size (E : Entity_Id) return B;
function Known_Static_Esize (E : Entity_Id) return B;
function Known_Static_Normalized_First_Bit (E : Entity_Id) return B;
function Known_Static_Normalized_Position (E : Entity_Id) return B;
function Known_Static_Normalized_Position_Max (E : Entity_Id) return B;
function Known_Static_RM_Size (E : Entity_Id) return B;
function Unknown_Alignment (E : Entity_Id) return B;
function Unknown_Component_Bit_Offset (E : Entity_Id) return B;
function Unknown_Component_Size (E : Entity_Id) return B;
function Unknown_Esize (E : Entity_Id) return B;
function Unknown_Normalized_First_Bit (E : Entity_Id) return B;
function Unknown_Normalized_Position (E : Entity_Id) return B;
function Unknown_Normalized_Position_Max (E : Entity_Id) return B;
function Unknown_RM_Size (E : Entity_Id) return B;
------------------------------
-- Attribute Set Procedures --
------------------------------
procedure Set_Abstract_States (Id : E; V : L);
procedure Set_Accept_Address (Id : E; V : L);
procedure Set_Access_Disp_Table (Id : E; V : L);
procedure Set_Actual_Subtype (Id : E; V : E);
procedure Set_Address_Taken (Id : E; V : B := True);
procedure Set_Alias (Id : E; V : E);
procedure Set_Alignment (Id : E; V : U);
procedure Set_Associated_Formal_Package (Id : E; V : E);
procedure Set_Associated_Node_For_Itype (Id : E; V : N);
procedure Set_Associated_Storage_Pool (Id : E; V : E);
procedure Set_Barrier_Function (Id : E; V : N);
procedure Set_Block_Node (Id : E; V : N);
procedure Set_Body_Entity (Id : E; V : E);
procedure Set_Body_Needed_For_SAL (Id : E; V : B := True);
procedure Set_Body_References (Id : E; V : L);
procedure Set_BIP_Initialization_Call (Id : E; V : N);
procedure Set_CR_Discriminant (Id : E; V : E);
procedure Set_C_Pass_By_Copy (Id : E; V : B := True);
procedure Set_Can_Never_Be_Null (Id : E; V : B := True);
procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True);
procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True);
procedure Set_Class_Wide_Type (Id : E; V : E);
procedure Set_Cloned_Subtype (Id : E; V : E);
procedure Set_Component_Alignment (Id : E; V : C);
procedure Set_Component_Bit_Offset (Id : E; V : U);
procedure Set_Component_Clause (Id : E; V : N);
procedure Set_Component_Size (Id : E; V : U);
procedure Set_Component_Type (Id : E; V : E);
procedure Set_Contract (Id : E; V : N);
procedure Set_Corresponding_Concurrent_Type (Id : E; V : E);
procedure Set_Corresponding_Discriminant (Id : E; V : E);
procedure Set_Corresponding_Equality (Id : E; V : E);
procedure Set_Corresponding_Protected_Entry (Id : E; V : E);
procedure Set_Corresponding_Record_Type (Id : E; V : E);
procedure Set_Corresponding_Remote_Type (Id : E; V : E);
procedure Set_Current_Use_Clause (Id : E; V : E);
procedure Set_Current_Value (Id : E; V : N);
procedure Set_DTC_Entity (Id : E; V : E);
procedure Set_DT_Entry_Count (Id : E; V : U);
procedure Set_DT_Offset_To_Top_Func (Id : E; V : E);
procedure Set_DT_Position (Id : E; V : U);
procedure Set_Debug_Info_Off (Id : E; V : B := True);
procedure Set_Debug_Renaming_Link (Id : E; V : E);
procedure Set_Default_Aspect_Component_Value (Id : E; V : N);
procedure Set_Default_Aspect_Value (Id : E; V : N);
procedure Set_Default_Expr_Function (Id : E; V : E);
procedure Set_Default_Expressions_Processed (Id : E; V : B := True);
procedure Set_Default_Value (Id : E; V : N);
procedure Set_Delay_Cleanups (Id : E; V : B := True);
procedure Set_Delay_Subprogram_Descriptors (Id : E; V : B := True);
procedure Set_Delta_Value (Id : E; V : R);
procedure Set_Dependent_Instances (Id : E; V : L);
procedure Set_Depends_On_Private (Id : E; V : B := True);
procedure Set_Derived_Type_Link (Id : E; V : E);
procedure Set_Digits_Value (Id : E; V : U);
procedure Set_Direct_Primitive_Operations (Id : E; V : L);
procedure Set_Directly_Designated_Type (Id : E; V : E);
procedure Set_Discard_Names (Id : E; V : B := True);
procedure Set_Discriminal (Id : E; V : E);
procedure Set_Discriminal_Link (Id : E; V : E);
procedure Set_Discriminant_Checking_Func (Id : E; V : E);
procedure Set_Discriminant_Constraint (Id : E; V : L);
procedure Set_Discriminant_Default_Value (Id : E; V : N);
procedure Set_Discriminant_Number (Id : E; V : U);
procedure Set_Dispatch_Table_Wrappers (Id : E; V : L);
procedure Set_Elaborate_Body_Desirable (Id : E; V : B := True);
procedure Set_Elaboration_Entity (Id : E; V : E);
procedure Set_Elaboration_Entity_Required (Id : E; V : B := True);
procedure Set_Encapsulating_State (Id : E; V : E);
procedure Set_Enclosing_Scope (Id : E; V : E);
procedure Set_Entry_Accepted (Id : E; V : B := True);
procedure Set_Entry_Bodies_Array (Id : E; V : E);
procedure Set_Entry_Cancel_Parameter (Id : E; V : E);
procedure Set_Entry_Component (Id : E; V : E);
procedure Set_Entry_Formal (Id : E; V : E);
procedure Set_Entry_Index_Constant (Id : E; V : E);
procedure Set_Entry_Parameters_Type (Id : E; V : E);
procedure Set_Enum_Pos_To_Rep (Id : E; V : E);
procedure Set_Enumeration_Pos (Id : E; V : U);
procedure Set_Enumeration_Rep (Id : E; V : U);
procedure Set_Enumeration_Rep_Expr (Id : E; V : N);
procedure Set_Equivalent_Type (Id : E; V : E);
procedure Set_Esize (Id : E; V : U);
procedure Set_Exception_Code (Id : E; V : U);
procedure Set_Extra_Accessibility (Id : E; V : E);
procedure Set_Extra_Accessibility_Of_Result (Id : E; V : E);
procedure Set_Extra_Constrained (Id : E; V : E);
procedure Set_Extra_Formal (Id : E; V : E);
procedure Set_Extra_Formals (Id : E; V : E);
procedure Set_Finalization_Master (Id : E; V : E);
procedure Set_Finalize_Storage_Only (Id : E; V : B := True);
procedure Set_Finalizer (Id : E; V : E);
procedure Set_First_Entity (Id : E; V : E);
procedure Set_First_Exit_Statement (Id : E; V : N);
procedure Set_First_Index (Id : E; V : N);
procedure Set_First_Literal (Id : E; V : E);
procedure Set_First_Optional_Parameter (Id : E; V : E);
procedure Set_First_Private_Entity (Id : E; V : E);
procedure Set_First_Rep_Item (Id : E; V : N);
procedure Set_Float_Rep (Id : E; V : F);
procedure Set_Freeze_Node (Id : E; V : N);
procedure Set_From_Limited_With (Id : E; V : B := True);
procedure Set_Full_View (Id : E; V : E);
procedure Set_Generic_Homonym (Id : E; V : E);
procedure Set_Generic_Renamings (Id : E; V : L);
procedure Set_Handler_Records (Id : E; V : S);
procedure Set_Has_Aliased_Components (Id : E; V : B := True);
procedure Set_Has_Alignment_Clause (Id : E; V : B := True);
procedure Set_Has_All_Calls_Remote (Id : E; V : B := True);
procedure Set_Has_Anonymous_Master (Id : E; V : B := True);
procedure Set_Has_Atomic_Components (Id : E; V : B := True);
procedure Set_Has_Biased_Representation (Id : E; V : B := True);
procedure Set_Has_Completion (Id : E; V : B := True);
procedure Set_Has_Completion_In_Body (Id : E; V : B := True);
procedure Set_Has_Complex_Representation (Id : E; V : B := True);
procedure Set_Has_Component_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Constrained_Partial_View (Id : E; V : B := True);
procedure Set_Has_Contiguous_Rep (Id : E; V : B := True);
procedure Set_Has_Controlled_Component (Id : E; V : B := True);
procedure Set_Has_Controlling_Result (Id : E; V : B := True);
procedure Set_Has_Convention_Pragma (Id : E; V : B := True);
procedure Set_Has_Default_Aspect (Id : E; V : B := True);
procedure Set_Has_Delayed_Aspects (Id : E; V : B := True);
procedure Set_Has_Delayed_Freeze (Id : E; V : B := True);
procedure Set_Has_Delayed_Rep_Aspects (Id : E; V : B := True);
procedure Set_Has_Discriminants (Id : E; V : B := True);
procedure Set_Has_Dispatch_Table (Id : E; V : B := True);
procedure Set_Has_Dynamic_Predicate_Aspect (Id : E; V : B := True);
procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True);
procedure Set_Has_Exit (Id : E; V : B := True);
procedure Set_Has_Forward_Instantiation (Id : E; V : B := True);
procedure Set_Has_Fully_Qualified_Name (Id : E; V : B := True);
procedure Set_Has_Gigi_Rep_Item (Id : E; V : B := True);
procedure Set_Has_Homonym (Id : E; V : B := True);
procedure Set_Has_Implicit_Dereference (Id : E; V : B := True);
procedure Set_Has_Independent_Components (Id : E; V : B := True);
procedure Set_Has_Inheritable_Invariants (Id : E; V : B := True);
procedure Set_Has_Initial_Value (Id : E; V : B := True);
procedure Set_Has_Invariants (Id : E; V : B := True);
procedure Set_Has_Loop_Entry_Attributes (Id : E; V : B := True);
procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True);
procedure Set_Has_Master_Entity (Id : E; V : B := True);
procedure Set_Has_Missing_Return (Id : E; V : B := True);
procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True);
procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True);
procedure Set_Has_Object_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True);
procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True);
procedure Set_Has_Postconditions (Id : E; V : B := True);
procedure Set_Has_Pragma_Controlled (Id : E; V : B := True);
procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True);
procedure Set_Has_Pragma_Inline (Id : E; V : B := True);
procedure Set_Has_Pragma_Inline_Always (Id : E; V : B := True);
procedure Set_Has_Pragma_No_Inline (Id : E; V : B := True);
procedure Set_Has_Pragma_Ordered (Id : E; V : B := True);
procedure Set_Has_Pragma_Pack (Id : E; V : B := True);
procedure Set_Has_Pragma_Preelab_Init (Id : E; V : B := True);
procedure Set_Has_Pragma_Pure (Id : E; V : B := True);
procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True);
procedure Set_Has_Pragma_Thread_Local_Storage (Id : E; V : B := True);
procedure Set_Has_Pragma_Unmodified (Id : E; V : B := True);
procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True);
procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True);
procedure Set_Has_Predicates (Id : E; V : B := True);
procedure Set_Has_Primitive_Operations (Id : E; V : B := True);
procedure Set_Has_Private_Ancestor (Id : E; V : B := True);
procedure Set_Has_Private_Declaration (Id : E; V : B := True);
procedure Set_Has_Protected (Id : E; V : B := True);
procedure Set_Has_Qualified_Name (Id : E; V : B := True);
procedure Set_Has_RACW (Id : E; V : B := True);
procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True);
procedure Set_Has_Recursive_Call (Id : E; V : B := True);
procedure Set_Has_Shift_Operator (Id : E; V : B := True);
procedure Set_Has_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Small_Clause (Id : E; V : B := True);
procedure Set_Has_Specified_Layout (Id : E; V : B := True);
procedure Set_Has_Specified_Stream_Input (Id : E; V : B := True);
procedure Set_Has_Specified_Stream_Output (Id : E; V : B := True);
procedure Set_Has_Specified_Stream_Read (Id : E; V : B := True);
procedure Set_Has_Specified_Stream_Write (Id : E; V : B := True);
procedure Set_Has_Static_Discriminants (Id : E; V : B := True);
procedure Set_Has_Static_Predicate (Id : E; V : B := True);
procedure Set_Has_Static_Predicate_Aspect (Id : E; V : B := True);
procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Task (Id : E; V : B := True);
procedure Set_Has_Thunks (Id : E; V : B := True);
procedure Set_Has_Unchecked_Union (Id : E; V : B := True);
procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True);
procedure Set_Has_Up_Level_Access (Id : E; V : B := True);
procedure Set_Has_Visible_Refinement (Id : E; V : B := True);
procedure Set_Has_Volatile_Components (Id : E; V : B := True);
procedure Set_Has_Xref_Entry (Id : E; V : B := True);
procedure Set_Hiding_Loop_Variable (Id : E; V : E);
procedure Set_Homonym (Id : E; V : E);
procedure Set_Import_Pragma (Id : E; V : E);
procedure Set_In_Package_Body (Id : E; V : B := True);
procedure Set_In_Private_Part (Id : E; V : B := True);
procedure Set_In_Use (Id : E; V : B := True);
procedure Set_Initialization_Statements (Id : E; V : N);
procedure Set_Inner_Instances (Id : E; V : L);
procedure Set_Interface_Alias (Id : E; V : E);
procedure Set_Interface_Name (Id : E; V : N);
procedure Set_Interfaces (Id : E; V : L);
procedure Set_Is_AST_Entry (Id : E; V : B := True);
procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True);
procedure Set_Is_Abstract_Type (Id : E; V : B := True);
procedure Set_Is_Access_Constant (Id : E; V : B := True);
procedure Set_Is_Ada_2005_Only (Id : E; V : B := True);
procedure Set_Is_Ada_2012_Only (Id : E; V : B := True);
procedure Set_Is_Aliased (Id : E; V : B := True);
procedure Set_Is_Asynchronous (Id : E; V : B := True);
procedure Set_Is_Atomic (Id : E; V : B := True);
procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True);
procedure Set_Is_CPP_Class (Id : E; V : B := True);
procedure Set_Is_Called (Id : E; V : B := True);
procedure Set_Is_Character_Type (Id : E; V : B := True);
procedure Set_Is_Child_Unit (Id : E; V : B := True);
procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True);
procedure Set_Is_Compilation_Unit (Id : E; V : B := True);
procedure Set_Is_Completely_Hidden (Id : E; V : B := True);
procedure Set_Is_Concurrent_Record_Type (Id : E; V : B := True);
procedure Set_Is_Constr_Subt_For_UN_Aliased (Id : E; V : B := True);
procedure Set_Is_Constr_Subt_For_U_Nominal (Id : E; V : B := True);
procedure Set_Is_Constrained (Id : E; V : B := True);
procedure Set_Is_Constructor (Id : E; V : B := True);
procedure Set_Is_Controlled (Id : E; V : B := True);
procedure Set_Is_Controlling_Formal (Id : E; V : B := True);
procedure Set_Is_Descendent_Of_Address (Id : E; V : B := True);
procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True);
procedure Set_Is_Discriminant_Check_Function (Id : E; V : B := True);
procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True);
procedure Set_Is_Dispatching_Operation (Id : E; V : B := True);
procedure Set_Is_Eliminated (Id : E; V : B := True);
procedure Set_Is_Entry_Formal (Id : E; V : B := True);
procedure Set_Is_Exported (Id : E; V : B := True);
procedure Set_Is_First_Subtype (Id : E; V : B := True);
procedure Set_Is_For_Access_Subtype (Id : E; V : B := True);
procedure Set_Is_Formal_Subprogram (Id : E; V : B := True);
procedure Set_Is_Frozen (Id : E; V : B := True);
procedure Set_Is_Generic_Actual_Type (Id : E; V : B := True);
procedure Set_Is_Generic_Instance (Id : E; V : B := True);
procedure Set_Is_Generic_Type (Id : E; V : B := True);
procedure Set_Is_Hidden (Id : E; V : B := True);
procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True);
procedure Set_Is_Immediately_Visible (Id : E; V : B := True);
procedure Set_Is_Implementation_Defined (Id : E; V : B := True);
procedure Set_Is_Imported (Id : E; V : B := True);
procedure Set_Is_Independent (Id : E; V : B := True);
procedure Set_Is_Inlined (Id : E; V : B := True);
procedure Set_Is_Instantiated (Id : E; V : B := True);
procedure Set_Is_Interface (Id : E; V : B := True);
procedure Set_Is_Internal (Id : E; V : B := True);
procedure Set_Is_Interrupt_Handler (Id : E; V : B := True);
procedure Set_Is_Intrinsic_Subprogram (Id : E; V : B := True);
procedure Set_Is_Invariant_Procedure (Id : E; V : B := True);
procedure Set_Is_Itype (Id : E; V : B := True);
procedure Set_Is_Known_Non_Null (Id : E; V : B := True);
procedure Set_Is_Known_Null (Id : E; V : B := True);
procedure Set_Is_Known_Valid (Id : E; V : B := True);
procedure Set_Is_Limited_Composite (Id : E; V : B := True);
procedure Set_Is_Limited_Interface (Id : E; V : B := True);
procedure Set_Is_Limited_Record (Id : E; V : B := True);
procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True);
procedure Set_Is_Machine_Code_Subprogram (Id : E; V : B := True);
procedure Set_Is_Non_Static_Subtype (Id : E; V : B := True);
procedure Set_Is_Null_Init_Proc (Id : E; V : B := True);
procedure Set_Is_Obsolescent (Id : E; V : B := True);
procedure Set_Is_Only_Out_Parameter (Id : E; V : B := True);
procedure Set_Is_Optional_Parameter (Id : E; V : B := True);
procedure Set_Is_Package_Body_Entity (Id : E; V : B := True);
procedure Set_Is_Packed (Id : E; V : B := True);
procedure Set_Is_Packed_Array_Impl_Type (Id : E; V : B := True);
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True);
procedure Set_Is_Predicate_Function (Id : E; V : B := True);
procedure Set_Is_Predicate_Function_M (Id : E; V : B := True);
procedure Set_Is_Preelaborated (Id : E; V : B := True);
procedure Set_Is_Primitive (Id : E; V : B := True);
procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True);
procedure Set_Is_Private_Composite (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (Id : E; V : B := True);
procedure Set_Is_Private_Primitive (Id : E; V : B := True);
procedure Set_Is_Processed_Transient (Id : E; V : B := True);
procedure Set_Is_Public (Id : E; V : B := True);
procedure Set_Is_Pure (Id : E; V : B := True);
procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True);
procedure Set_Is_RACW_Stub_Type (Id : E; V : B := True);
procedure Set_Is_Raised (Id : E; V : B := True);
procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True);
procedure Set_Is_Remote_Types (Id : E; V : B := True);
procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True);
procedure Set_Is_Return_Object (Id : E; V : B := True);
procedure Set_Is_Safe_To_Reevaluate (Id : E; V : B := True);
procedure Set_Is_Shared_Passive (Id : E; V : B := True);
procedure Set_Is_Statically_Allocated (Id : E; V : B := True);
procedure Set_Is_Tag (Id : E; V : B := True);
procedure Set_Is_Tagged_Type (Id : E; V : B := True);
procedure Set_Is_Thunk (Id : E; V : B := True);
procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True);
procedure Set_Is_True_Constant (Id : E; V : B := True);
procedure Set_Is_Unchecked_Union (Id : E; V : B := True);
procedure Set_Is_Underlying_Record_View (Id : E; V : B := True);
procedure Set_Is_Unsigned_Type (Id : E; V : B := True);
procedure Set_Is_VMS_Exception (Id : E; V : B := True);
procedure Set_Is_Valued_Procedure (Id : E; V : B := True);
procedure Set_Is_Visible_Formal (Id : E; V : B := True);
procedure Set_Is_Visible_Lib_Unit (Id : E; V : B := True);
procedure Set_Is_Volatile (Id : E; V : B := True);
procedure Set_Itype_Printed (Id : E; V : B := True);
procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True);
procedure Set_Kill_Range_Checks (Id : E; V : B := True);
procedure Set_Known_To_Have_Preelab_Init (Id : E; V : B := True);
procedure Set_Last_Aggregate_Assignment (Id : E; V : N);
procedure Set_Last_Assignment (Id : E; V : N);
procedure Set_Last_Entity (Id : E; V : E);
procedure Set_Limited_View (Id : E; V : E);
procedure Set_Linker_Section_Pragma (Id : E; V : N);
procedure Set_Lit_Indexes (Id : E; V : E);
procedure Set_Lit_Strings (Id : E; V : E);
procedure Set_Low_Bound_Tested (Id : E; V : B := True);
procedure Set_Machine_Radix_10 (Id : E; V : B := True);
procedure Set_Master_Id (Id : E; V : E);
procedure Set_Materialize_Entity (Id : E; V : B := True);
procedure Set_May_Inherit_Delayed_Rep_Aspects (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_Must_Have_Preelab_Init (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);
procedure Set_Next_Inlined_Subprogram (Id : E; V : E);
procedure Set_No_Pool_Assigned (Id : E; V : B := True);
procedure Set_No_Return (Id : E; V : B := True);
procedure Set_No_Strict_Aliasing (Id : E; V : B := True);
procedure Set_Non_Binary_Modulus (Id : E; V : B := True);
procedure Set_Non_Limited_View (Id : E; V : E);
procedure Set_Nonzero_Is_True (Id : E; V : B := True);
procedure Set_Normalized_First_Bit (Id : E; V : U);
procedure Set_Normalized_Position (Id : E; V : U);
procedure Set_Normalized_Position_Max (Id : E; V : U);
procedure Set_OK_To_Rename (Id : E; V : B := True);
procedure Set_OK_To_Reorder_Components (Id : E; V : B := True);
procedure Set_Optimize_Alignment_Space (Id : E; V : B := True);
procedure Set_Optimize_Alignment_Time (Id : E; V : B := True);
procedure Set_Original_Access_Type (Id : E; V : E);
procedure Set_Original_Array_Type (Id : E; V : E);
procedure Set_Original_Record_Component (Id : E; V : E);
procedure Set_Overlays_Constant (Id : E; V : B := True);
procedure Set_Overridden_Operation (Id : E; V : E);
procedure Set_PPC_Wrapper (Id : E; V : E);
procedure Set_Package_Instantiation (Id : E; V : N);
procedure Set_Packed_Array_Impl_Type (Id : E; V : E);
procedure Set_Parent_Subtype (Id : E; V : E);
procedure Set_Part_Of_Constituents (Id : E; V : L);
procedure Set_Postcondition_Proc (Id : E; V : E);
procedure Set_Prival (Id : E; V : E);
procedure Set_Prival_Link (Id : E; V : E);
procedure Set_Private_Dependents (Id : E; V : L);
procedure Set_Private_View (Id : E; V : N);
procedure Set_Protected_Body_Subprogram (Id : E; V : E);
procedure Set_Protected_Formal (Id : E; V : E);
procedure Set_Protection_Object (Id : E; V : E);
procedure Set_RM_Size (Id : E; V : U);
procedure Set_Reachable (Id : E; V : B := True);
procedure Set_Referenced (Id : E; V : B := True);
procedure Set_Referenced_As_LHS (Id : E; V : B := True);
procedure Set_Referenced_As_Out_Parameter (Id : E; V : B := True);
procedure Set_Refinement_Constituents (Id : E; V : L);
procedure Set_Register_Exception_Call (Id : E; V : N);
procedure Set_Related_Array_Object (Id : E; V : E);
procedure Set_Related_Expression (Id : E; V : N);
procedure Set_Related_Instance (Id : E; V : E);
procedure Set_Related_Type (Id : E; V : E);
procedure Set_Relative_Deadline_Variable (Id : E; V : E);
procedure Set_Renamed_Entity (Id : E; V : N);
procedure Set_Renamed_In_Spec (Id : E; V : B := True);
procedure Set_Renamed_Object (Id : E; V : N);
procedure Set_Renaming_Map (Id : E; V : U);
procedure Set_Requires_Overriding (Id : E; V : B := True);
procedure Set_Return_Applies_To (Id : E; V : N);
procedure Set_Return_Present (Id : E; V : B := True);
procedure Set_Returns_By_Ref (Id : E; V : B := True);
procedure Set_Reverse_Bit_Order (Id : E; V : B := True);
procedure Set_Reverse_Storage_Order (Id : E; V : B := True);
procedure Set_Scalar_Range (Id : E; V : N);
procedure Set_Scale_Value (Id : E; V : U);
procedure Set_Scope_Depth_Value (Id : E; V : U);
procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True);
procedure Set_Shadow_Entities (Id : E; V : S);
procedure Set_Shared_Var_Procs_Instance (Id : E; V : E);
procedure Set_Size_Check_Code (Id : E; V : N);
procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True);
procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True);
procedure Set_Small_Value (Id : E; V : R);
procedure Set_SPARK_Aux_Pragma (Id : E; V : N);
procedure Set_SPARK_Aux_Pragma_Inherited (Id : E; V : B := True);
procedure Set_SPARK_Pragma (Id : E; V : N);
procedure Set_SPARK_Pragma_Inherited (Id : E; V : B := True);
procedure Set_Spec_Entity (Id : E; V : E);
procedure Set_SSO_Set_High_By_Default (Id : E; V : B := True);
procedure Set_SSO_Set_Low_By_Default (Id : E; V : B := True);
procedure Set_Static_Elaboration_Desired (Id : E; V : B);
procedure Set_Static_Initialization (Id : E; V : N);
procedure Set_Static_Discrete_Predicate (Id : E; V : S);
procedure Set_Static_Real_Or_String_Predicate (Id : E; V : N);
procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E);
procedure Set_Storage_Size_Variable (Id : E; V : E);
procedure Set_Stored_Constraint (Id : E; V : L);
procedure Set_Stores_Attribute_Old_Prefix (Id : E; V : B := True);
procedure Set_Strict_Alignment (Id : E; V : B := True);
procedure Set_String_Literal_Length (Id : E; V : U);
procedure Set_String_Literal_Low_Bound (Id : E; V : N);
procedure Set_Subprograms_For_Type (Id : E; V : E);
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True);
procedure Set_Suppress_Initialization (Id : E; V : B := True);
procedure Set_Suppress_Style_Checks (Id : E; V : B := True);
procedure Set_Suppress_Value_Tracking_On_Call (Id : E; V : B := True);
procedure Set_Task_Body_Procedure (Id : E; V : N);
procedure Set_Thunk_Entity (Id : E; V : E);
procedure Set_Treat_As_Volatile (Id : E; V : B := True);
procedure Set_Underlying_Full_View (Id : E; V : E);
procedure Set_Underlying_Record_View (Id : E; V : E);
procedure Set_Universal_Aliasing (Id : E; V : B := True);
procedure Set_Unset_Reference (Id : E; V : N);
procedure Set_Used_As_Generic_Actual (Id : E; V : B := True);
procedure Set_Uses_Lock_Free (Id : E; V : B := True);
procedure Set_Uses_Sec_Stack (Id : E; V : B := True);
procedure Set_Warnings_Off (Id : E; V : B := True);
procedure Set_Warnings_Off_Used (Id : E; V : B := True);
procedure Set_Warnings_Off_Used_Unmodified (Id : E; V : B := True);
procedure Set_Warnings_Off_Used_Unreferenced (Id : E; V : B := True);
procedure Set_Was_Hidden (Id : E; V : B := True);
procedure Set_Wrapped_Entity (Id : E; V : E);
---------------------------------------------------
-- Access to Subprograms in Subprograms_For_Type --
---------------------------------------------------
function Invariant_Procedure (Id : E) return N;
function Predicate_Function (Id : E) return N;
function Predicate_Function_M (Id : E) return N;
procedure Set_Invariant_Procedure (Id : E; V : E);
procedure Set_Predicate_Function (Id : E; V : E);
procedure Set_Predicate_Function_M (Id : E; V : E);
-----------------------------------
-- Field Initialization Routines --
-----------------------------------
-- These routines are overloadings of some of the above Set procedures
-- where the argument is normally a Uint. The overloadings take an Int
-- parameter instead, and appropriately convert it. There are also
-- versions that implicitly initialize to the appropriate "not set"
-- value. The not set (unknown) values are as follows:
-- Alignment Uint_0
-- Component_Size Uint_0
-- Component_Bit_Offset No_Uint
-- Digits_Value Uint_0
-- Esize Uint_0
-- Normalized_First_Bit No_Uint
-- Normalized_Position No_Uint
-- Normalized_Position_Max No_Uint
-- RM_Size Uint_0
-- It would be cleaner to use No_Uint in all these cases, but historically
-- we chose to use Uint_0 at first, and the change over will take time ???
-- This is particularly true for the RM_Size field, where a value of zero
-- is legitimate and causes some special tests around the code.
-- Contrary to the corresponding Set procedures above, these routines
-- do NOT check the entity kind of their argument, instead they set the
-- underlying Uint fields directly (this allows them to be used for
-- entities whose Ekind has not been set yet).
procedure Init_Alignment (Id : E; V : Int);
procedure Init_Component_Size (Id : E; V : Int);
procedure Init_Component_Bit_Offset (Id : E; V : Int);
procedure Init_Digits_Value (Id : E; V : Int);
procedure Init_Esize (Id : E; V : Int);
procedure Init_Normalized_First_Bit (Id : E; V : Int);
procedure Init_Normalized_Position (Id : E; V : Int);
procedure Init_Normalized_Position_Max (Id : E; V : Int);
procedure Init_RM_Size (Id : E; V : Int);
procedure Init_Alignment (Id : E);
procedure Init_Component_Size (Id : E);
procedure Init_Component_Bit_Offset (Id : E);
procedure Init_Digits_Value (Id : E);
procedure Init_Esize (Id : E);
procedure Init_Normalized_First_Bit (Id : E);
procedure Init_Normalized_Position (Id : E);
procedure Init_Normalized_Position_Max (Id : E);
procedure Init_RM_Size (Id : E);
procedure Init_Size_Align (Id : E);
-- This procedure initializes both size fields and the alignment
-- field to all be Unknown.
procedure Init_Object_Size_Align (Id : E);
-- Same as Init_Size_Align except RM_Size field (which is only for types)
-- is unaffected.
procedure Init_Size (Id : E; V : Int);
-- Initialize both the Esize and RM_Size fields of E to V
procedure Init_Component_Location (Id : E);
-- Initializes all fields describing the location of a component
-- (Normalized_Position, Component_Bit_Offset, Normalized_First_Bit,
-- Normalized_Position_Max, Esize) to all be Unknown.
---------------
-- Iterators --
---------------
-- The call to Next_xxx (obj) is equivalent to obj := Next_xxx (obj)
-- We define the set of Proc_Next_xxx routines simply for the purposes
-- of inlining them without necessarily inlining the function.
procedure Proc_Next_Component (N : in out Node_Id);
procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id);
procedure Proc_Next_Discriminant (N : in out Node_Id);
procedure Proc_Next_Formal (N : in out Node_Id);
procedure Proc_Next_Formal_With_Extras (N : in out Node_Id);
procedure Proc_Next_Index (N : in out Node_Id);
procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id);
procedure Proc_Next_Literal (N : in out Node_Id);
procedure Proc_Next_Stored_Discriminant (N : in out Node_Id);
pragma Inline (Proc_Next_Component);
pragma Inline (Proc_Next_Component_Or_Discriminant);
pragma Inline (Proc_Next_Discriminant);
pragma Inline (Proc_Next_Formal);
pragma Inline (Proc_Next_Formal_With_Extras);
pragma Inline (Proc_Next_Index);
pragma Inline (Proc_Next_Inlined_Subprogram);
pragma Inline (Proc_Next_Literal);
pragma Inline (Proc_Next_Stored_Discriminant);
procedure Next_Component (N : in out Node_Id)
renames Proc_Next_Component;
procedure Next_Component_Or_Discriminant (N : in out Node_Id)
renames Proc_Next_Component_Or_Discriminant;
procedure Next_Discriminant (N : in out Node_Id)
renames Proc_Next_Discriminant;
procedure Next_Formal (N : in out Node_Id)
renames Proc_Next_Formal;
procedure Next_Formal_With_Extras (N : in out Node_Id)
renames Proc_Next_Formal_With_Extras;
procedure Next_Index (N : in out Node_Id)
renames Proc_Next_Index;
procedure Next_Inlined_Subprogram (N : in out Node_Id)
renames Proc_Next_Inlined_Subprogram;
procedure Next_Literal (N : in out Node_Id)
renames Proc_Next_Literal;
procedure Next_Stored_Discriminant (N : in out Node_Id)
renames Proc_Next_Stored_Discriminant;
---------------------------
-- Testing Warning Flags --
---------------------------
-- These routines are to be used rather than testing flags Warnings_Off,
-- Has_Pragma_Unmodified, Has_Pragma_Unreferenced. They deal with setting
-- the flags Warnings_Off_Used[_Unmodified|Unreferenced] for later access.
function Has_Warnings_Off (E : Entity_Id) return Boolean;
-- If Warnings_Off is set on E, then returns True and also sets the flag
-- Warnings_Off_Used on E. If Warnings_Off is not set on E, returns False
-- and has no side effect.
function Has_Unmodified (E : Entity_Id) return Boolean;
-- If flag Has_Pragma_Unmodified is set on E, returns True with no side
-- effects. Otherwise if Warnings_Off is set on E, returns True and also
-- sets the flag Warnings_Off_Used_Unmodified on E. If neither of the flags
-- Warnings_Off nor Has_Pragma_Unmodified is set, returns False with no
-- side effects.
function Has_Unreferenced (E : Entity_Id) return Boolean;
-- If flag Has_Pragma_Unreferenced is set on E, returns True with no side
-- effects. Otherwise if Warnings_Off is set on E, returns True and also
-- sets the flag Warnings_Off_Used_Unreferenced on E. If neither of the
-- flags Warnings_Off nor Has_Pragma_Unreferenced is set, returns False
-- with no side effects.
----------------------------------------------
-- Subprograms for Accessing Rep Item Chain --
----------------------------------------------
-- The First_Rep_Item field of every entity points to a linked list (linked
-- through Next_Rep_Item) of representation pragmas, attribute definition
-- clauses, representation clauses, and aspect specifications that apply to
-- the item. Note that in the case of types, it is assumed that any such
-- rep items for a base type also apply to all subtypes. This is achieved
-- by having the chain for subtypes link onto the chain for the base type,
-- so that new entries for the subtype are added at the start of the chain.
--
-- Note: aspect specification nodes are linked only when evaluation of the
-- expression is deferred to the freeze point. For further details see
-- Sem_Ch13.Analyze_Aspect_Specifications.
function Get_Attribute_Definition_Clause
(E : Entity_Id;
Id : Attribute_Id) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for an instance of an
-- attribute definition clause with the given attribute Id. If found, the
-- value returned is the N_Attribute_Definition_Clause node, otherwise
-- Empty is returned.
function Get_Pragma (E : Entity_Id; Id : Pragma_Id) return Node_Id;
-- Searches the Rep_Item chain of entity E, for an instance of a pragma
-- with the given pragma Id. If found, the value returned is the N_Pragma
-- node, otherwise Empty is returned. The following contract pragmas that
-- appear in N_Contract nodes are also handled by this routine:
-- Abstract_State
-- Async_Readers
-- Async_Writers
-- Contract_Cases
-- Depends
-- Effective_Reads
-- Effective_Writes
-- Global
-- Initial_Condition
-- Initializes
-- Part_Of
-- Precondition
-- Postcondition
-- Refined_Depends
-- Refined_Global
-- Refined_Post
-- Refined_State
-- Test_Case
function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for a record
-- representation clause, and if found, returns it. Returns Empty
-- if no such clause is found.
function Present_In_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean;
-- Return True if N is present in the Rep_Item chain for a given entity E
procedure Record_Rep_Item (E : Entity_Id; N : Node_Id);
-- N is the node for a representation pragma, representation clause, an
-- attribute definition clause, or an aspect specification that applies to
-- entity E. This procedure links the node N onto the Rep_Item chain for
-- entity E. Note that it is an error to call this procedure with E being
-- overloadable, and N being a pragma that applies to multiple overloadable
-- entities (Convention, Interface, Inline, Inline_Always, Import, Export,
-- External). This is not allowed even in the case where the entity is not
-- overloaded, since we can't rely on it being present in the overloaded
-- case, it is not useful to have it present in the non-overloaded case.
-------------------------------
-- Miscellaneous Subprograms --
-------------------------------
procedure Append_Entity (Id : Entity_Id; V : Entity_Id);
-- Add an entity to the list of entities declared in the scope V
function Get_Full_View (T : Entity_Id) return Entity_Id;
-- If T is an incomplete type and the full declaration has been seen, or
-- is the name of a class_wide type whose root is incomplete, return the
-- corresponding full declaration, else return T itself.
function Is_Entity_Name (N : Node_Id) return Boolean;
-- Test if the node N is the name of an entity (i.e. is an identifier,
-- expanded name, or an attribute reference that returns an entity).
function Next_Index (Id : Node_Id) return Node_Id;
-- Given an index from a previous call to First_Index or Next_Index,
-- returns a node representing the occurrence of the next index subtype,
-- or Empty if there are no more index subtypes.
function Scope_Depth (Id : Entity_Id) return Uint;
-- Returns the scope depth value of the Id, unless the Id is a record
-- type, in which case it returns the scope depth of the record scope.
function Subtype_Kind (K : Entity_Kind) return Entity_Kind;
-- Given an entity_kind K this function returns the entity_kind
-- corresponding to subtype kind of the type represented by K. For
-- example if K is E_Signed_Integer_Type then E_Signed_Integer_Subtype
-- is returned. If K is already a subtype kind it itself is returned. An
-- internal error is generated if no such correspondence exists for K.
----------------------------------
-- Debugging Output Subprograms --
----------------------------------
procedure Write_Entity_Flags (Id : Entity_Id; Prefix : String);
-- Writes a series of entries giving a line for each flag that is
-- set to True. Each line is prefixed by the given string
procedure Write_Entity_Info (Id : Entity_Id; Prefix : String);
-- A debugging procedure to write out information about an entity
procedure Write_Field6_Name (Id : Entity_Id);
procedure Write_Field7_Name (Id : Entity_Id);
procedure Write_Field8_Name (Id : Entity_Id);
procedure Write_Field9_Name (Id : Entity_Id);
procedure Write_Field10_Name (Id : Entity_Id);
procedure Write_Field11_Name (Id : Entity_Id);
procedure Write_Field12_Name (Id : Entity_Id);
procedure Write_Field13_Name (Id : Entity_Id);
procedure Write_Field14_Name (Id : Entity_Id);
procedure Write_Field15_Name (Id : Entity_Id);
procedure Write_Field16_Name (Id : Entity_Id);
procedure Write_Field17_Name (Id : Entity_Id);
procedure Write_Field18_Name (Id : Entity_Id);
procedure Write_Field19_Name (Id : Entity_Id);
procedure Write_Field20_Name (Id : Entity_Id);
procedure Write_Field21_Name (Id : Entity_Id);
procedure Write_Field22_Name (Id : Entity_Id);
procedure Write_Field23_Name (Id : Entity_Id);
procedure Write_Field24_Name (Id : Entity_Id);
procedure Write_Field25_Name (Id : Entity_Id);
procedure Write_Field26_Name (Id : Entity_Id);
procedure Write_Field27_Name (Id : Entity_Id);
procedure Write_Field28_Name (Id : Entity_Id);
procedure Write_Field29_Name (Id : Entity_Id);
procedure Write_Field30_Name (Id : Entity_Id);
procedure Write_Field31_Name (Id : Entity_Id);
procedure Write_Field32_Name (Id : Entity_Id);
procedure Write_Field33_Name (Id : Entity_Id);
procedure Write_Field34_Name (Id : Entity_Id);
procedure Write_Field35_Name (Id : Entity_Id);
-- These routines are used in Treepr to output a nice symbolic name for
-- the given field, depending on the Ekind. No blanks or end of lines are
-- output, just the characters of the field name.
--------------------
-- Inline Pragmas --
--------------------
-- Note that these inline pragmas are referenced by the XEINFO utility
-- program in preparing the corresponding C header, and only those
-- subprograms meeting the requirements documented in the section on
-- XEINFO may be referenced in this section.
pragma Inline (Abstract_States);
pragma Inline (Accept_Address);
pragma Inline (Access_Disp_Table);
pragma Inline (Actual_Subtype);
pragma Inline (Address_Taken);
pragma Inline (Alias);
pragma Inline (Alignment);
pragma Inline (Associated_Formal_Package);
pragma Inline (Associated_Node_For_Itype);
pragma Inline (Associated_Storage_Pool);
pragma Inline (Barrier_Function);
pragma Inline (Block_Node);
pragma Inline (Body_Entity);
pragma Inline (Body_Needed_For_SAL);
pragma Inline (Body_References);
pragma Inline (BIP_Initialization_Call);
pragma Inline (CR_Discriminant);
pragma Inline (C_Pass_By_Copy);
pragma Inline (Can_Never_Be_Null);
pragma Inline (Can_Use_Internal_Rep);
pragma Inline (Checks_May_Be_Suppressed);
pragma Inline (Class_Wide_Type);
pragma Inline (Cloned_Subtype);
pragma Inline (Component_Bit_Offset);
pragma Inline (Component_Clause);
pragma Inline (Component_Size);
pragma Inline (Component_Type);
pragma Inline (Contract);
pragma Inline (Corresponding_Concurrent_Type);
pragma Inline (Corresponding_Discriminant);
pragma Inline (Corresponding_Equality);
pragma Inline (Corresponding_Protected_Entry);
pragma Inline (Corresponding_Record_Type);
pragma Inline (Corresponding_Remote_Type);
pragma Inline (Current_Use_Clause);
pragma Inline (Current_Value);
pragma Inline (DTC_Entity);
pragma Inline (DT_Entry_Count);
pragma Inline (DT_Offset_To_Top_Func);
pragma Inline (DT_Position);
pragma Inline (Debug_Info_Off);
pragma Inline (Debug_Renaming_Link);
pragma Inline (Default_Aspect_Component_Value);
pragma Inline (Default_Aspect_Value);
pragma Inline (Default_Expr_Function);
pragma Inline (Default_Expressions_Processed);
pragma Inline (Default_Value);
pragma Inline (Delay_Cleanups);
pragma Inline (Delay_Subprogram_Descriptors);
pragma Inline (Delta_Value);
pragma Inline (Dependent_Instances);
pragma Inline (Depends_On_Private);
pragma Inline (Derived_Type_Link);
pragma Inline (Digits_Value);
pragma Inline (Direct_Primitive_Operations);
pragma Inline (Directly_Designated_Type);
pragma Inline (Discard_Names);
pragma Inline (Discriminal);
pragma Inline (Discriminal_Link);
pragma Inline (Discriminant_Checking_Func);
pragma Inline (Discriminant_Constraint);
pragma Inline (Discriminant_Default_Value);
pragma Inline (Discriminant_Number);
pragma Inline (Dispatch_Table_Wrappers);
pragma Inline (Elaborate_Body_Desirable);
pragma Inline (Elaboration_Entity);
pragma Inline (Elaboration_Entity_Required);
pragma Inline (Encapsulating_State);
pragma Inline (Enclosing_Scope);
pragma Inline (Entry_Accepted);
pragma Inline (Entry_Bodies_Array);
pragma Inline (Entry_Cancel_Parameter);
pragma Inline (Entry_Component);
pragma Inline (Entry_Formal);
pragma Inline (Entry_Index_Constant);
pragma Inline (Entry_Index_Type);
pragma Inline (Entry_Parameters_Type);
pragma Inline (Enum_Pos_To_Rep);
pragma Inline (Enumeration_Pos);
pragma Inline (Enumeration_Rep);
pragma Inline (Enumeration_Rep_Expr);
pragma Inline (Equivalent_Type);
pragma Inline (Esize);
pragma Inline (Exception_Code);
pragma Inline (Extra_Accessibility);
pragma Inline (Extra_Accessibility_Of_Result);
pragma Inline (Extra_Constrained);
pragma Inline (Extra_Formal);
pragma Inline (Extra_Formals);
pragma Inline (Finalization_Master);
pragma Inline (Finalizer);
pragma Inline (First_Entity);
pragma Inline (First_Exit_Statement);
pragma Inline (First_Index);
pragma Inline (First_Literal);
pragma Inline (First_Optional_Parameter);
pragma Inline (First_Private_Entity);
pragma Inline (First_Rep_Item);
pragma Inline (Freeze_Node);
pragma Inline (From_Limited_With);
pragma Inline (Full_View);
pragma Inline (Generic_Homonym);
pragma Inline (Generic_Renamings);
pragma Inline (Handler_Records);
pragma Inline (Has_Aliased_Components);
pragma Inline (Has_Alignment_Clause);
pragma Inline (Has_All_Calls_Remote);
pragma Inline (Has_Anonymous_Master);
pragma Inline (Has_Atomic_Components);
pragma Inline (Has_Biased_Representation);
pragma Inline (Has_Completion);
pragma Inline (Has_Completion_In_Body);
pragma Inline (Has_Complex_Representation);
pragma Inline (Has_Component_Size_Clause);
pragma Inline (Has_Constrained_Partial_View);
pragma Inline (Has_Contiguous_Rep);
pragma Inline (Has_Controlled_Component);
pragma Inline (Has_Controlling_Result);
pragma Inline (Has_Convention_Pragma);
pragma Inline (Has_Default_Aspect);
pragma Inline (Has_Delayed_Aspects);
pragma Inline (Has_Delayed_Freeze);
pragma Inline (Has_Delayed_Rep_Aspects);
pragma Inline (Has_Discriminants);
pragma Inline (Has_Dispatch_Table);
pragma Inline (Has_Dynamic_Predicate_Aspect);
pragma Inline (Has_Enumeration_Rep_Clause);
pragma Inline (Has_Exit);
pragma Inline (Has_Forward_Instantiation);
pragma Inline (Has_Fully_Qualified_Name);
pragma Inline (Has_Gigi_Rep_Item);
pragma Inline (Has_Homonym);
pragma Inline (Has_Implicit_Dereference);
pragma Inline (Has_Independent_Components);
pragma Inline (Has_Inheritable_Invariants);
pragma Inline (Has_Initial_Value);
pragma Inline (Has_Invariants);
pragma Inline (Has_Loop_Entry_Attributes);
pragma Inline (Has_Machine_Radix_Clause);
pragma Inline (Has_Master_Entity);
pragma Inline (Has_Missing_Return);
pragma Inline (Has_Nested_Block_With_Handler);
pragma Inline (Has_Non_Standard_Rep);
pragma Inline (Has_Object_Size_Clause);
pragma Inline (Has_Out_Or_In_Out_Parameter);
pragma Inline (Has_Per_Object_Constraint);
pragma Inline (Has_Postconditions);
pragma Inline (Has_Pragma_Controlled);
pragma Inline (Has_Pragma_Elaborate_Body);
pragma Inline (Has_Pragma_Inline);
pragma Inline (Has_Pragma_Inline_Always);
pragma Inline (Has_Pragma_No_Inline);
pragma Inline (Has_Pragma_Ordered);
pragma Inline (Has_Pragma_Pack);
pragma Inline (Has_Pragma_Preelab_Init);
pragma Inline (Has_Pragma_Pure);
pragma Inline (Has_Pragma_Pure_Function);
pragma Inline (Has_Pragma_Thread_Local_Storage);
pragma Inline (Has_Pragma_Unmodified);
pragma Inline (Has_Pragma_Unreferenced);
pragma Inline (Has_Pragma_Unreferenced_Objects);
pragma Inline (Has_Predicates);
pragma Inline (Has_Primitive_Operations);
pragma Inline (Has_Private_Ancestor);
pragma Inline (Has_Private_Declaration);
pragma Inline (Has_Protected);
pragma Inline (Has_Qualified_Name);
pragma Inline (Has_RACW);
pragma Inline (Has_Record_Rep_Clause);
pragma Inline (Has_Recursive_Call);
pragma Inline (Has_Shift_Operator);
pragma Inline (Has_Size_Clause);
pragma Inline (Has_Small_Clause);
pragma Inline (Has_Specified_Layout);
pragma Inline (Has_Specified_Stream_Input);
pragma Inline (Has_Specified_Stream_Output);
pragma Inline (Has_Specified_Stream_Read);
pragma Inline (Has_Specified_Stream_Write);
pragma Inline (Has_Static_Discriminants);
pragma Inline (Has_Static_Predicate);
pragma Inline (Has_Static_Predicate_Aspect);
pragma Inline (Has_Storage_Size_Clause);
pragma Inline (Has_Stream_Size_Clause);
pragma Inline (Has_Task);
pragma Inline (Has_Thunks);
pragma Inline (Has_Unchecked_Union);
pragma Inline (Has_Unknown_Discriminants);
pragma Inline (Has_Up_Level_Access);
pragma Inline (Has_Visible_Refinement);
pragma Inline (Has_Volatile_Components);
pragma Inline (Has_Xref_Entry);
pragma Inline (Hiding_Loop_Variable);
pragma Inline (Homonym);
pragma Inline (Import_Pragma);
pragma Inline (In_Package_Body);
pragma Inline (In_Private_Part);
pragma Inline (In_Use);
pragma Inline (Inner_Instances);
pragma Inline (Interface_Alias);
pragma Inline (Interface_Name);
pragma Inline (Interfaces);
pragma Inline (Is_AST_Entry);
pragma Inline (Is_Abstract_Subprogram);
pragma Inline (Is_Abstract_Type);
pragma Inline (Is_Access_Constant);
pragma Inline (Is_Access_Protected_Subprogram_Type);
pragma Inline (Is_Access_Subprogram_Type);
pragma Inline (Is_Access_Type);
pragma Inline (Is_Ada_2005_Only);
pragma Inline (Is_Ada_2012_Only);
pragma Inline (Is_Aggregate_Type);
pragma Inline (Is_Aliased);
pragma Inline (Is_Array_Type);
pragma Inline (Is_Assignable);
pragma Inline (Is_Asynchronous);
pragma Inline (Is_Atomic);
pragma Inline (Is_Bit_Packed_Array);
pragma Inline (Is_CPP_Class);
pragma Inline (Is_Called);
pragma Inline (Is_Character_Type);
pragma Inline (Is_Child_Unit);
pragma Inline (Is_Class_Wide_Equivalent_Type);
pragma Inline (Is_Class_Wide_Type);
pragma Inline (Is_Compilation_Unit);
pragma Inline (Is_Completely_Hidden);
pragma Inline (Is_Composite_Type);
pragma Inline (Is_Concurrent_Body);
pragma Inline (Is_Concurrent_Record_Type);
pragma Inline (Is_Concurrent_Type);
pragma Inline (Is_Constr_Subt_For_UN_Aliased);
pragma Inline (Is_Constr_Subt_For_U_Nominal);
pragma Inline (Is_Constrained);
pragma Inline (Is_Constructor);
pragma Inline (Is_Controlled);
pragma Inline (Is_Controlling_Formal);
pragma Inline (Is_Decimal_Fixed_Point_Type);
pragma Inline (Is_Descendent_Of_Address);
pragma Inline (Is_Digits_Type);
pragma Inline (Is_Discrete_Or_Fixed_Point_Type);
pragma Inline (Is_Discrete_Type);
pragma Inline (Is_Discrim_SO_Function);
pragma Inline (Is_Discriminant_Check_Function);
pragma Inline (Is_Dispatch_Table_Entity);
pragma Inline (Is_Dispatching_Operation);
pragma Inline (Is_Elementary_Type);
pragma Inline (Is_Eliminated);
pragma Inline (Is_Entry);
pragma Inline (Is_Entry_Formal);
pragma Inline (Is_Enumeration_Type);
pragma Inline (Is_Exported);
pragma Inline (Is_First_Subtype);
pragma Inline (Is_Fixed_Point_Type);
pragma Inline (Is_Floating_Point_Type);
pragma Inline (Is_For_Access_Subtype);
pragma Inline (Is_Formal);
pragma Inline (Is_Formal_Object);
pragma Inline (Is_Formal_Subprogram);
pragma Inline (Is_Frozen);
pragma Inline (Is_Generic_Actual_Type);
pragma Inline (Is_Generic_Instance);
pragma Inline (Is_Generic_Subprogram);
pragma Inline (Is_Generic_Type);
pragma Inline (Is_Generic_Unit);
pragma Inline (Is_Hidden);
pragma Inline (Is_Hidden_Open_Scope);
pragma Inline (Is_Immediately_Visible);
pragma Inline (Is_Implementation_Defined);
pragma Inline (Is_Imported);
pragma Inline (Is_Incomplete_Or_Private_Type);
pragma Inline (Is_Incomplete_Type);
pragma Inline (Is_Independent);
pragma Inline (Is_Inlined);
pragma Inline (Is_Instantiated);
pragma Inline (Is_Integer_Type);
pragma Inline (Is_Interface);
pragma Inline (Is_Internal);
pragma Inline (Is_Interrupt_Handler);
pragma Inline (Is_Intrinsic_Subprogram);
pragma Inline (Is_Invariant_Procedure);
pragma Inline (Is_Itype);
pragma Inline (Is_Known_Non_Null);
pragma Inline (Is_Known_Null);
pragma Inline (Is_Known_Valid);
pragma Inline (Is_Limited_Composite);
pragma Inline (Is_Limited_Interface);
pragma Inline (Is_Limited_Record);
pragma Inline (Is_Local_Anonymous_Access);
pragma Inline (Is_Machine_Code_Subprogram);
pragma Inline (Is_Modular_Integer_Type);
pragma Inline (Is_Named_Number);
pragma Inline (Is_Non_Static_Subtype);
pragma Inline (Is_Null_Init_Proc);
pragma Inline (Is_Numeric_Type);
pragma Inline (Is_Object);
pragma Inline (Is_Obsolescent);
pragma Inline (Is_Only_Out_Parameter);
pragma Inline (Is_Optional_Parameter);
pragma Inline (Is_Ordinary_Fixed_Point_Type);
pragma Inline (Is_Overloadable);
pragma Inline (Is_Package_Body_Entity);
pragma Inline (Is_Packed);
pragma Inline (Is_Packed_Array_Impl_Type);
pragma Inline (Is_Potentially_Use_Visible);
pragma Inline (Is_Predicate_Function);
pragma Inline (Is_Predicate_Function_M);
pragma Inline (Is_Preelaborated);
pragma Inline (Is_Primitive);
pragma Inline (Is_Primitive_Wrapper);
pragma Inline (Is_Private_Composite);
pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Primitive);
pragma Inline (Is_Private_Type);
pragma Inline (Is_Processed_Transient);
pragma Inline (Is_Protected_Type);
pragma Inline (Is_Public);
pragma Inline (Is_Pure);
pragma Inline (Is_Pure_Unit_Access_Type);
pragma Inline (Is_RACW_Stub_Type);
pragma Inline (Is_Raised);
pragma Inline (Is_Real_Type);
pragma Inline (Is_Record_Type);
pragma Inline (Is_Remote_Call_Interface);
pragma Inline (Is_Remote_Types);
pragma Inline (Is_Renaming_Of_Object);
pragma Inline (Is_Return_Object);
pragma Inline (Is_Safe_To_Reevaluate);
pragma Inline (Is_Scalar_Type);
pragma Inline (Is_Shared_Passive);
pragma Inline (Is_Signed_Integer_Type);
pragma Inline (Is_Statically_Allocated);
pragma Inline (Is_Subprogram);
pragma Inline (Is_Tag);
pragma Inline (Is_Tagged_Type);
pragma Inline (Is_Task_Type);
pragma Inline (Is_Thunk);
pragma Inline (Is_Trivial_Subprogram);
pragma Inline (Is_True_Constant);
pragma Inline (Is_Type);
pragma Inline (Is_Unchecked_Union);
pragma Inline (Is_Underlying_Record_View);
pragma Inline (Is_Unsigned_Type);
pragma Inline (Is_VMS_Exception);
pragma Inline (Is_Valued_Procedure);
pragma Inline (Is_Visible_Formal);
pragma Inline (Is_Visible_Lib_Unit);
pragma Inline (Itype_Printed);
pragma Inline (Kill_Elaboration_Checks);
pragma Inline (Kill_Range_Checks);
pragma Inline (Known_To_Have_Preelab_Init);
pragma Inline (Last_Aggregate_Assignment);
pragma Inline (Last_Assignment);
pragma Inline (Last_Entity);
pragma Inline (Limited_View);
pragma Inline (Linker_Section_Pragma);
pragma Inline (Lit_Indexes);
pragma Inline (Lit_Strings);
pragma Inline (Low_Bound_Tested);
pragma Inline (Machine_Radix_10);
pragma Inline (Master_Id);
pragma Inline (Materialize_Entity);
pragma Inline (May_Inherit_Delayed_Rep_Aspects);
pragma Inline (Mechanism);
pragma Inline (Modulus);
pragma Inline (Must_Be_On_Byte_Boundary);
pragma Inline (Must_Have_Preelab_Init);
pragma Inline (Needs_Debug_Info);
pragma Inline (Needs_No_Actuals);
pragma Inline (Never_Set_In_Source);
pragma Inline (Next_Index);
pragma Inline (Next_Inlined_Subprogram);
pragma Inline (Next_Literal);
pragma Inline (No_Pool_Assigned);
pragma Inline (No_Return);
pragma Inline (No_Strict_Aliasing);
pragma Inline (Non_Binary_Modulus);
pragma Inline (Non_Limited_View);
pragma Inline (Nonzero_Is_True);
pragma Inline (Normalized_First_Bit);
pragma Inline (Normalized_Position);
pragma Inline (Normalized_Position_Max);
pragma Inline (OK_To_Rename);
pragma Inline (OK_To_Reorder_Components);
pragma Inline (Optimize_Alignment_Space);
pragma Inline (Optimize_Alignment_Time);
pragma Inline (Original_Access_Type);
pragma Inline (Original_Array_Type);
pragma Inline (Original_Record_Component);
pragma Inline (Overlays_Constant);
pragma Inline (Overridden_Operation);
pragma Inline (PPC_Wrapper);
pragma Inline (Package_Instantiation);
pragma Inline (Packed_Array_Impl_Type);
pragma Inline (Parameter_Mode);
pragma Inline (Parent_Subtype);
pragma Inline (Part_Of_Constituents);
pragma Inline (Postcondition_Proc);
pragma Inline (Prival);
pragma Inline (Prival_Link);
pragma Inline (Private_Dependents);
pragma Inline (Private_View);
pragma Inline (Protected_Body_Subprogram);
pragma Inline (Protected_Formal);
pragma Inline (Protection_Object);
pragma Inline (RM_Size);
pragma Inline (Reachable);
pragma Inline (Referenced);
pragma Inline (Referenced_As_LHS);
pragma Inline (Referenced_As_Out_Parameter);
pragma Inline (Refinement_Constituents);
pragma Inline (Register_Exception_Call);
pragma Inline (Related_Array_Object);
pragma Inline (Related_Expression);
pragma Inline (Related_Instance);
pragma Inline (Related_Type);
pragma Inline (Relative_Deadline_Variable);
pragma Inline (Renamed_Entity);
pragma Inline (Renamed_In_Spec);
pragma Inline (Renamed_Object);
pragma Inline (Renaming_Map);
pragma Inline (Requires_Overriding);
pragma Inline (Return_Applies_To);
pragma Inline (Return_Present);
pragma Inline (Returns_By_Ref);
pragma Inline (Reverse_Bit_Order);
pragma Inline (Reverse_Storage_Order);
pragma Inline (Scalar_Range);
pragma Inline (Scale_Value);
pragma Inline (Scope_Depth_Value);
pragma Inline (Sec_Stack_Needed_For_Return);
pragma Inline (Shadow_Entities);
pragma Inline (Shared_Var_Procs_Instance);
pragma Inline (Size_Check_Code);
pragma Inline (Size_Depends_On_Discriminant);
pragma Inline (Size_Known_At_Compile_Time);
pragma Inline (Small_Value);
pragma Inline (SPARK_Aux_Pragma);
pragma Inline (SPARK_Aux_Pragma_Inherited);
pragma Inline (SPARK_Pragma);
pragma Inline (SPARK_Pragma_Inherited);
pragma Inline (Spec_Entity);
pragma Inline (SSO_Set_High_By_Default);
pragma Inline (SSO_Set_Low_By_Default);
pragma Inline (Static_Elaboration_Desired);
pragma Inline (Static_Initialization);
pragma Inline (Static_Discrete_Predicate);
pragma Inline (Static_Real_Or_String_Predicate);
pragma Inline (Status_Flag_Or_Transient_Decl);
pragma Inline (Storage_Size_Variable);
pragma Inline (Stored_Constraint);
pragma Inline (Stores_Attribute_Old_Prefix);
pragma Inline (Strict_Alignment);
pragma Inline (String_Literal_Length);
pragma Inline (String_Literal_Low_Bound);
pragma Inline (Subprograms_For_Type);
pragma Inline (Suppress_Elaboration_Warnings);
pragma Inline (Suppress_Initialization);
pragma Inline (Suppress_Style_Checks);
pragma Inline (Suppress_Value_Tracking_On_Call);
pragma Inline (Task_Body_Procedure);
pragma Inline (Thunk_Entity);
pragma Inline (Treat_As_Volatile);
pragma Inline (Underlying_Full_View);
pragma Inline (Underlying_Record_View);
pragma Inline (Universal_Aliasing);
pragma Inline (Unset_Reference);
pragma Inline (Used_As_Generic_Actual);
pragma Inline (Uses_Lock_Free);
pragma Inline (Uses_Sec_Stack);
pragma Inline (Warnings_Off);
pragma Inline (Warnings_Off_Used);
pragma Inline (Warnings_Off_Used_Unmodified);
pragma Inline (Warnings_Off_Used_Unreferenced);
pragma Inline (Was_Hidden);
pragma Inline (Wrapped_Entity);
pragma Inline (Init_Alignment);
pragma Inline (Init_Component_Bit_Offset);
pragma Inline (Init_Component_Size);
pragma Inline (Init_Digits_Value);
pragma Inline (Init_Esize);
pragma Inline (Init_RM_Size);
pragma Inline (Set_Abstract_States);
pragma Inline (Set_Accept_Address);
pragma Inline (Set_Access_Disp_Table);
pragma Inline (Set_Actual_Subtype);
pragma Inline (Set_Address_Taken);
pragma Inline (Set_Alias);
pragma Inline (Set_Alignment);
pragma Inline (Set_Associated_Formal_Package);
pragma Inline (Set_Associated_Node_For_Itype);
pragma Inline (Set_Associated_Storage_Pool);
pragma Inline (Set_Barrier_Function);
pragma Inline (Set_Block_Node);
pragma Inline (Set_Body_Entity);
pragma Inline (Set_Body_Needed_For_SAL);
pragma Inline (Set_Body_References);
pragma Inline (Set_BIP_Initialization_Call);
pragma Inline (Set_CR_Discriminant);
pragma Inline (Set_C_Pass_By_Copy);
pragma Inline (Set_Can_Never_Be_Null);
pragma Inline (Set_Can_Use_Internal_Rep);
pragma Inline (Set_Checks_May_Be_Suppressed);
pragma Inline (Set_Class_Wide_Type);
pragma Inline (Set_Cloned_Subtype);
pragma Inline (Set_Component_Bit_Offset);
pragma Inline (Set_Component_Clause);
pragma Inline (Set_Component_Size);
pragma Inline (Set_Component_Type);
pragma Inline (Set_Contract);
pragma Inline (Set_Corresponding_Concurrent_Type);
pragma Inline (Set_Corresponding_Discriminant);
pragma Inline (Set_Corresponding_Equality);
pragma Inline (Set_Corresponding_Protected_Entry);
pragma Inline (Set_Corresponding_Record_Type);
pragma Inline (Set_Corresponding_Remote_Type);
pragma Inline (Set_Current_Use_Clause);
pragma Inline (Set_Current_Value);
pragma Inline (Set_DTC_Entity);
pragma Inline (Set_DT_Entry_Count);
pragma Inline (Set_DT_Offset_To_Top_Func);
pragma Inline (Set_DT_Position);
pragma Inline (Set_Debug_Info_Off);
pragma Inline (Set_Debug_Renaming_Link);
pragma Inline (Set_Default_Aspect_Component_Value);
pragma Inline (Set_Default_Aspect_Value);
pragma Inline (Set_Default_Expr_Function);
pragma Inline (Set_Default_Expressions_Processed);
pragma Inline (Set_Default_Value);
pragma Inline (Set_Delay_Cleanups);
pragma Inline (Set_Delay_Subprogram_Descriptors);
pragma Inline (Set_Delta_Value);
pragma Inline (Set_Dependent_Instances);
pragma Inline (Set_Depends_On_Private);
pragma Inline (Set_Derived_Type_Link);
pragma Inline (Set_Digits_Value);
pragma Inline (Set_Direct_Primitive_Operations);
pragma Inline (Set_Directly_Designated_Type);
pragma Inline (Set_Discard_Names);
pragma Inline (Set_Discriminal);
pragma Inline (Set_Discriminal_Link);
pragma Inline (Set_Discriminant_Checking_Func);
pragma Inline (Set_Discriminant_Constraint);
pragma Inline (Set_Discriminant_Default_Value);
pragma Inline (Set_Discriminant_Number);
pragma Inline (Set_Dispatch_Table_Wrappers);
pragma Inline (Set_Elaborate_Body_Desirable);
pragma Inline (Set_Elaboration_Entity);
pragma Inline (Set_Elaboration_Entity_Required);
pragma Inline (Set_Encapsulating_State);
pragma Inline (Set_Enclosing_Scope);
pragma Inline (Set_Entry_Accepted);
pragma Inline (Set_Entry_Bodies_Array);
pragma Inline (Set_Entry_Cancel_Parameter);
pragma Inline (Set_Entry_Component);
pragma Inline (Set_Entry_Formal);
pragma Inline (Set_Entry_Parameters_Type);
pragma Inline (Set_Enum_Pos_To_Rep);
pragma Inline (Set_Enumeration_Pos);
pragma Inline (Set_Enumeration_Rep);
pragma Inline (Set_Enumeration_Rep_Expr);
pragma Inline (Set_Equivalent_Type);
pragma Inline (Set_Esize);
pragma Inline (Set_Exception_Code);
pragma Inline (Set_Extra_Accessibility);
pragma Inline (Set_Extra_Accessibility_Of_Result);
pragma Inline (Set_Extra_Constrained);
pragma Inline (Set_Extra_Formal);
pragma Inline (Set_Extra_Formals);
pragma Inline (Set_Finalization_Master);
pragma Inline (Set_Finalizer);
pragma Inline (Set_First_Entity);
pragma Inline (Set_First_Exit_Statement);
pragma Inline (Set_First_Index);
pragma Inline (Set_First_Literal);
pragma Inline (Set_First_Optional_Parameter);
pragma Inline (Set_First_Private_Entity);
pragma Inline (Set_First_Rep_Item);
pragma Inline (Set_Freeze_Node);
pragma Inline (Set_From_Limited_With);
pragma Inline (Set_Full_View);
pragma Inline (Set_Generic_Homonym);
pragma Inline (Set_Generic_Renamings);
pragma Inline (Set_Handler_Records);
pragma Inline (Set_Has_Aliased_Components);
pragma Inline (Set_Has_Alignment_Clause);
pragma Inline (Set_Has_All_Calls_Remote);
pragma Inline (Set_Has_Anonymous_Master);
pragma Inline (Set_Has_Atomic_Components);
pragma Inline (Set_Has_Biased_Representation);
pragma Inline (Set_Has_Completion);
pragma Inline (Set_Has_Completion_In_Body);
pragma Inline (Set_Has_Complex_Representation);
pragma Inline (Set_Has_Component_Size_Clause);
pragma Inline (Set_Has_Constrained_Partial_View);
pragma Inline (Set_Has_Contiguous_Rep);
pragma Inline (Set_Has_Controlled_Component);
pragma Inline (Set_Has_Controlling_Result);
pragma Inline (Set_Has_Convention_Pragma);
pragma Inline (Set_Has_Default_Aspect);
pragma Inline (Set_Has_Delayed_Aspects);
pragma Inline (Set_Has_Delayed_Freeze);
pragma Inline (Set_Has_Delayed_Rep_Aspects);
pragma Inline (Set_Has_Discriminants);
pragma Inline (Set_Has_Dispatch_Table);
pragma Inline (Set_Has_Dynamic_Predicate_Aspect);
pragma Inline (Set_Has_Enumeration_Rep_Clause);
pragma Inline (Set_Has_Exit);
pragma Inline (Set_Has_Forward_Instantiation);
pragma Inline (Set_Has_Fully_Qualified_Name);
pragma Inline (Set_Has_Gigi_Rep_Item);
pragma Inline (Set_Has_Homonym);
pragma Inline (Set_Has_Implicit_Dereference);
pragma Inline (Set_Has_Independent_Components);
pragma Inline (Set_Has_Inheritable_Invariants);
pragma Inline (Set_Has_Initial_Value);
pragma Inline (Set_Has_Invariants);
pragma Inline (Set_Has_Loop_Entry_Attributes);
pragma Inline (Set_Has_Machine_Radix_Clause);
pragma Inline (Set_Has_Master_Entity);
pragma Inline (Set_Has_Missing_Return);
pragma Inline (Set_Has_Nested_Block_With_Handler);
pragma Inline (Set_Has_Non_Standard_Rep);
pragma Inline (Set_Has_Object_Size_Clause);
pragma Inline (Set_Has_Out_Or_In_Out_Parameter);
pragma Inline (Set_Has_Per_Object_Constraint);
pragma Inline (Set_Has_Postconditions);
pragma Inline (Set_Has_Pragma_Controlled);
pragma Inline (Set_Has_Pragma_Elaborate_Body);
pragma Inline (Set_Has_Pragma_Inline);
pragma Inline (Set_Has_Pragma_Inline_Always);
pragma Inline (Set_Has_Pragma_No_Inline);
pragma Inline (Set_Has_Pragma_Ordered);
pragma Inline (Set_Has_Pragma_Pack);
pragma Inline (Set_Has_Pragma_Preelab_Init);
pragma Inline (Set_Has_Pragma_Pure);
pragma Inline (Set_Has_Pragma_Pure_Function);
pragma Inline (Set_Has_Pragma_Thread_Local_Storage);
pragma Inline (Set_Has_Pragma_Unmodified);
pragma Inline (Set_Has_Pragma_Unreferenced);
pragma Inline (Set_Has_Pragma_Unreferenced_Objects);
pragma Inline (Set_Has_Predicates);
pragma Inline (Set_Has_Primitive_Operations);
pragma Inline (Set_Has_Private_Ancestor);
pragma Inline (Set_Has_Private_Declaration);
pragma Inline (Set_Has_Protected);
pragma Inline (Set_Has_Qualified_Name);
pragma Inline (Set_Has_RACW);
pragma Inline (Set_Has_Record_Rep_Clause);
pragma Inline (Set_Has_Recursive_Call);
pragma Inline (Set_Has_Shift_Operator);
pragma Inline (Set_Has_Size_Clause);
pragma Inline (Set_Has_Small_Clause);
pragma Inline (Set_Has_Specified_Layout);
pragma Inline (Set_Has_Specified_Stream_Input);
pragma Inline (Set_Has_Specified_Stream_Output);
pragma Inline (Set_Has_Specified_Stream_Read);
pragma Inline (Set_Has_Specified_Stream_Write);
pragma Inline (Set_Has_Static_Discriminants);
pragma Inline (Set_Has_Static_Predicate);
pragma Inline (Set_Has_Static_Predicate_Aspect);
pragma Inline (Set_Has_Storage_Size_Clause);
pragma Inline (Set_Has_Stream_Size_Clause);
pragma Inline (Set_Has_Task);
pragma Inline (Set_Has_Thunks);
pragma Inline (Set_Has_Unchecked_Union);
pragma Inline (Set_Has_Unknown_Discriminants);
pragma Inline (Set_Has_Up_Level_Access);
pragma Inline (Set_Has_Visible_Refinement);
pragma Inline (Set_Has_Volatile_Components);
pragma Inline (Set_Has_Xref_Entry);
pragma Inline (Set_Hiding_Loop_Variable);
pragma Inline (Set_Homonym);
pragma Inline (Set_Import_Pragma);
pragma Inline (Set_In_Package_Body);
pragma Inline (Set_In_Private_Part);
pragma Inline (Set_In_Use);
pragma Inline (Set_Inner_Instances);
pragma Inline (Set_Interface_Alias);
pragma Inline (Set_Interface_Name);
pragma Inline (Set_Interfaces);
pragma Inline (Set_Is_AST_Entry);
pragma Inline (Set_Is_Abstract_Subprogram);
pragma Inline (Set_Is_Abstract_Type);
pragma Inline (Set_Is_Access_Constant);
pragma Inline (Set_Is_Ada_2005_Only);
pragma Inline (Set_Is_Ada_2012_Only);
pragma Inline (Set_Is_Aliased);
pragma Inline (Set_Is_Asynchronous);
pragma Inline (Set_Is_Atomic);
pragma Inline (Set_Is_Bit_Packed_Array);
pragma Inline (Set_Is_CPP_Class);
pragma Inline (Set_Is_Called);
pragma Inline (Set_Is_Character_Type);
pragma Inline (Set_Is_Child_Unit);
pragma Inline (Set_Is_Class_Wide_Equivalent_Type);
pragma Inline (Set_Is_Compilation_Unit);
pragma Inline (Set_Is_Completely_Hidden);
pragma Inline (Set_Is_Concurrent_Record_Type);
pragma Inline (Set_Is_Constr_Subt_For_UN_Aliased);
pragma Inline (Set_Is_Constr_Subt_For_U_Nominal);
pragma Inline (Set_Is_Constrained);
pragma Inline (Set_Is_Constructor);
pragma Inline (Set_Is_Controlled);
pragma Inline (Set_Is_Controlling_Formal);
pragma Inline (Set_Is_Descendent_Of_Address);
pragma Inline (Set_Is_Discrim_SO_Function);
pragma Inline (Set_Is_Discriminant_Check_Function);
pragma Inline (Set_Is_Dispatch_Table_Entity);
pragma Inline (Set_Is_Dispatching_Operation);
pragma Inline (Set_Is_Eliminated);
pragma Inline (Set_Is_Entry_Formal);
pragma Inline (Set_Is_Exported);
pragma Inline (Set_Is_First_Subtype);
pragma Inline (Set_Is_For_Access_Subtype);
pragma Inline (Set_Is_Formal_Subprogram);
pragma Inline (Set_Is_Frozen);
pragma Inline (Set_Is_Generic_Actual_Type);
pragma Inline (Set_Is_Generic_Instance);
pragma Inline (Set_Is_Generic_Type);
pragma Inline (Set_Is_Hidden);
pragma Inline (Set_Is_Hidden_Open_Scope);
pragma Inline (Set_Is_Immediately_Visible);
pragma Inline (Set_Is_Implementation_Defined);
pragma Inline (Set_Is_Imported);
pragma Inline (Set_Is_Independent);
pragma Inline (Set_Is_Inlined);
pragma Inline (Set_Is_Instantiated);
pragma Inline (Set_Is_Interface);
pragma Inline (Set_Is_Internal);
pragma Inline (Set_Is_Interrupt_Handler);
pragma Inline (Set_Is_Intrinsic_Subprogram);
pragma Inline (Set_Is_Invariant_Procedure);
pragma Inline (Set_Is_Itype);
pragma Inline (Set_Is_Known_Non_Null);
pragma Inline (Set_Is_Known_Null);
pragma Inline (Set_Is_Known_Valid);
pragma Inline (Set_Is_Limited_Composite);
pragma Inline (Set_Is_Limited_Interface);
pragma Inline (Set_Is_Limited_Record);
pragma Inline (Set_Is_Local_Anonymous_Access);
pragma Inline (Set_Is_Machine_Code_Subprogram);
pragma Inline (Set_Is_Non_Static_Subtype);
pragma Inline (Set_Is_Null_Init_Proc);
pragma Inline (Set_Is_Obsolescent);
pragma Inline (Set_Is_Only_Out_Parameter);
pragma Inline (Set_Is_Optional_Parameter);
pragma Inline (Set_Is_Package_Body_Entity);
pragma Inline (Set_Is_Packed);
pragma Inline (Set_Is_Packed_Array_Impl_Type);
pragma Inline (Set_Is_Potentially_Use_Visible);
pragma Inline (Set_Is_Predicate_Function);
pragma Inline (Set_Is_Predicate_Function_M);
pragma Inline (Set_Is_Preelaborated);
pragma Inline (Set_Is_Primitive);
pragma Inline (Set_Is_Primitive_Wrapper);
pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Private_Primitive);
pragma Inline (Set_Is_Processed_Transient);
pragma Inline (Set_Is_Public);
pragma Inline (Set_Is_Pure);
pragma Inline (Set_Is_Pure_Unit_Access_Type);
pragma Inline (Set_Is_RACW_Stub_Type);
pragma Inline (Set_Is_Raised);
pragma Inline (Set_Is_Remote_Call_Interface);
pragma Inline (Set_Is_Remote_Types);
pragma Inline (Set_Is_Renaming_Of_Object);
pragma Inline (Set_Is_Return_Object);
pragma Inline (Set_Is_Safe_To_Reevaluate);
pragma Inline (Set_Is_Shared_Passive);
pragma Inline (Set_Is_Statically_Allocated);
pragma Inline (Set_Is_Tag);
pragma Inline (Set_Is_Tagged_Type);
pragma Inline (Set_Is_Thunk);
pragma Inline (Set_Is_Trivial_Subprogram);
pragma Inline (Set_Is_True_Constant);
pragma Inline (Set_Is_Unchecked_Union);
pragma Inline (Set_Is_Underlying_Record_View);
pragma Inline (Set_Is_Unsigned_Type);
pragma Inline (Set_Is_VMS_Exception);
pragma Inline (Set_Is_Valued_Procedure);
pragma Inline (Set_Is_Visible_Formal);
pragma Inline (Set_Is_Visible_Lib_Unit);
pragma Inline (Set_Is_Volatile);
pragma Inline (Set_Itype_Printed);
pragma Inline (Set_Kill_Elaboration_Checks);
pragma Inline (Set_Kill_Range_Checks);
pragma Inline (Set_Known_To_Have_Preelab_Init);
pragma Inline (Set_Last_Aggregate_Assignment);
pragma Inline (Set_Last_Assignment);
pragma Inline (Set_Last_Entity);
pragma Inline (Set_Limited_View);
pragma Inline (Set_Linker_Section_Pragma);
pragma Inline (Set_Lit_Indexes);
pragma Inline (Set_Lit_Strings);
pragma Inline (Set_Low_Bound_Tested);
pragma Inline (Set_Machine_Radix_10);
pragma Inline (Set_Master_Id);
pragma Inline (Set_Materialize_Entity);
pragma Inline (Set_May_Inherit_Delayed_Rep_Aspects);
pragma Inline (Set_Mechanism);
pragma Inline (Set_Modulus);
pragma Inline (Set_Must_Be_On_Byte_Boundary);
pragma Inline (Set_Must_Have_Preelab_Init);
pragma Inline (Set_Needs_Debug_Info);
pragma Inline (Set_Needs_No_Actuals);
pragma Inline (Set_Never_Set_In_Source);
pragma Inline (Set_Next_Inlined_Subprogram);
pragma Inline (Set_No_Pool_Assigned);
pragma Inline (Set_No_Return);
pragma Inline (Set_No_Strict_Aliasing);
pragma Inline (Set_Non_Binary_Modulus);
pragma Inline (Set_Non_Limited_View);
pragma Inline (Set_Nonzero_Is_True);
pragma Inline (Set_Normalized_First_Bit);
pragma Inline (Set_Normalized_Position);
pragma Inline (Set_Normalized_Position_Max);
pragma Inline (Set_OK_To_Rename);
pragma Inline (Set_OK_To_Reorder_Components);
pragma Inline (Set_Optimize_Alignment_Space);
pragma Inline (Set_Optimize_Alignment_Time);
pragma Inline (Set_Original_Access_Type);
pragma Inline (Set_Original_Array_Type);
pragma Inline (Set_Original_Record_Component);
pragma Inline (Set_Overlays_Constant);
pragma Inline (Set_Overridden_Operation);
pragma Inline (Set_PPC_Wrapper);
pragma Inline (Set_Package_Instantiation);
pragma Inline (Set_Packed_Array_Impl_Type);
pragma Inline (Set_Parent_Subtype);
pragma Inline (Set_Part_Of_Constituents);
pragma Inline (Set_Postcondition_Proc);
pragma Inline (Set_Prival);
pragma Inline (Set_Prival_Link);
pragma Inline (Set_Private_Dependents);
pragma Inline (Set_Private_View);
pragma Inline (Set_Protected_Body_Subprogram);
pragma Inline (Set_Protected_Formal);
pragma Inline (Set_Protection_Object);
pragma Inline (Set_RM_Size);
pragma Inline (Set_Reachable);
pragma Inline (Set_Referenced);
pragma Inline (Set_Referenced_As_LHS);
pragma Inline (Set_Referenced_As_Out_Parameter);
pragma Inline (Set_Refinement_Constituents);
pragma Inline (Set_Register_Exception_Call);
pragma Inline (Set_Related_Array_Object);
pragma Inline (Set_Related_Expression);
pragma Inline (Set_Related_Instance);
pragma Inline (Set_Related_Type);
pragma Inline (Set_Relative_Deadline_Variable);
pragma Inline (Set_Renamed_Entity);
pragma Inline (Set_Renamed_In_Spec);
pragma Inline (Set_Renamed_Object);
pragma Inline (Set_Renaming_Map);
pragma Inline (Set_Requires_Overriding);
pragma Inline (Set_Return_Applies_To);
pragma Inline (Set_Return_Present);
pragma Inline (Set_Returns_By_Ref);
pragma Inline (Set_Reverse_Bit_Order);
pragma Inline (Set_Reverse_Storage_Order);
pragma Inline (Set_Scalar_Range);
pragma Inline (Set_Scale_Value);
pragma Inline (Set_Scope_Depth_Value);
pragma Inline (Set_Sec_Stack_Needed_For_Return);
pragma Inline (Set_Shadow_Entities);
pragma Inline (Set_Shared_Var_Procs_Instance);
pragma Inline (Set_Size_Check_Code);
pragma Inline (Set_Size_Depends_On_Discriminant);
pragma Inline (Set_Size_Known_At_Compile_Time);
pragma Inline (Set_Small_Value);
pragma Inline (Set_SPARK_Aux_Pragma);
pragma Inline (Set_SPARK_Aux_Pragma_Inherited);
pragma Inline (Set_SPARK_Pragma);
pragma Inline (Set_SPARK_Pragma_Inherited);
pragma Inline (Set_Spec_Entity);
pragma Inline (Set_SSO_Set_High_By_Default);
pragma Inline (Set_SSO_Set_Low_By_Default);
pragma Inline (Set_Static_Elaboration_Desired);
pragma Inline (Set_Static_Initialization);
pragma Inline (Set_Static_Discrete_Predicate);
pragma Inline (Set_Static_Real_Or_String_Predicate);
pragma Inline (Set_Status_Flag_Or_Transient_Decl);
pragma Inline (Set_Storage_Size_Variable);
pragma Inline (Set_Stored_Constraint);
pragma Inline (Set_Stores_Attribute_Old_Prefix);
pragma Inline (Set_Strict_Alignment);
pragma Inline (Set_String_Literal_Length);
pragma Inline (Set_String_Literal_Low_Bound);
pragma Inline (Set_Subprograms_For_Type);
pragma Inline (Set_Suppress_Elaboration_Warnings);
pragma Inline (Set_Suppress_Initialization);
pragma Inline (Set_Suppress_Style_Checks);
pragma Inline (Set_Suppress_Value_Tracking_On_Call);
pragma Inline (Set_Task_Body_Procedure);
pragma Inline (Set_Thunk_Entity);
pragma Inline (Set_Treat_As_Volatile);
pragma Inline (Set_Underlying_Full_View);
pragma Inline (Set_Underlying_Record_View);
pragma Inline (Set_Universal_Aliasing);
pragma Inline (Set_Unset_Reference);
pragma Inline (Set_Used_As_Generic_Actual);
pragma Inline (Set_Uses_Lock_Free);
pragma Inline (Set_Uses_Sec_Stack);
pragma Inline (Set_Warnings_Off);
pragma Inline (Set_Warnings_Off_Used);
pragma Inline (Set_Warnings_Off_Used_Unmodified);
pragma Inline (Set_Warnings_Off_Used_Unreferenced);
pragma Inline (Set_Was_Hidden);
pragma Inline (Set_Wrapped_Entity);
-- END XEINFO INLINES
-- The following Inline pragmas are *not* read by xeinfo when building
-- the C version of this interface automatically (so the C version will
-- end up making out of line calls). The pragma scan in xeinfo will be
-- terminated on encountering the END XEINFO INLINES line. We inline
-- things here which are small, but not of the canonical attribute
-- access/set format that can be handled by xeinfo.
pragma Inline (Base_Type);
pragma Inline (Is_Base_Type);
pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Packed_Array);
pragma Inline (Is_Volatile);
pragma Inline (Is_Wrapper_Package);
pragma Inline (Known_RM_Size);
pragma Inline (Known_Static_Component_Bit_Offset);
pragma Inline (Known_Static_RM_Size);
pragma Inline (Scope_Depth);
pragma Inline (Scope_Depth_Set);
pragma Inline (Unknown_RM_Size);
end Einfo;
gprbuild-gpl-2014-src/gnat/mlib-tgt.adb 0000644 0000767 0000145 00000033726 12323721731 017266 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M L I B . T G T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2010, AdaCore --
-- --
-- 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with MLib.Fil;
with Prj.Com;
with MLib.Tgt.Specific;
pragma Warnings (Off, MLib.Tgt.Specific);
-- MLib.Tgt.Specific is with'ed only for elaboration purposes
package body MLib.Tgt is
---------------------
-- Archive_Builder --
---------------------
function Archive_Builder return String is
begin
return Archive_Builder_Ptr.all;
end Archive_Builder;
-----------------------------
-- Archive_Builder_Default --
-----------------------------
function Archive_Builder_Default return String is
begin
return "ar";
end Archive_Builder_Default;
-----------------------------
-- Archive_Builder_Options --
-----------------------------
function Archive_Builder_Options return String_List_Access is
begin
return Archive_Builder_Options_Ptr.all;
end Archive_Builder_Options;
-------------------------------------
-- Archive_Builder_Options_Default --
-------------------------------------
function Archive_Builder_Options_Default return String_List_Access is
begin
return new String_List'(1 => new String'("cr"));
end Archive_Builder_Options_Default;
------------------------------------
-- Archive_Builder_Append_Options --
------------------------------------
function Archive_Builder_Append_Options return String_List_Access is
begin
return Archive_Builder_Append_Options_Ptr.all;
end Archive_Builder_Append_Options;
--------------------------------------------
-- Archive_Builder_Append_Options_Default --
--------------------------------------------
function Archive_Builder_Append_Options_Default return String_List_Access is
begin
return new String_List'(1 => new String'("q"));
end Archive_Builder_Append_Options_Default;
-----------------
-- Archive_Ext --
-----------------
function Archive_Ext return String is
begin
return Archive_Ext_Ptr.all;
end Archive_Ext;
-------------------------
-- Archive_Ext_Default --
-------------------------
function Archive_Ext_Default return String is
begin
return "a";
end Archive_Ext_Default;
---------------------
-- Archive_Indexer --
---------------------
function Archive_Indexer return String is
begin
return Archive_Indexer_Ptr.all;
end Archive_Indexer;
-----------------------------
-- Archive_Indexer_Default --
-----------------------------
function Archive_Indexer_Default return String is
begin
return "ranlib";
end Archive_Indexer_Default;
-----------------------------
-- Archive_Indexer_Options --
-----------------------------
function Archive_Indexer_Options return String_List_Access is
begin
return Archive_Indexer_Options_Ptr.all;
end Archive_Indexer_Options;
-------------------------------------
-- Archive_Indexer_Options_Default --
-------------------------------------
function Archive_Indexer_Options_Default return String_List_Access is
begin
return new String_List (1 .. 0);
end Archive_Indexer_Options_Default;
---------------------------
-- Build_Dynamic_Library --
---------------------------
procedure Build_Dynamic_Library
(Ofiles : Argument_List;
Options : Argument_List;
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Version : String := "";
Auto_Init : Boolean := False)
is
begin
Build_Dynamic_Library_Ptr
(Ofiles,
Options,
Interfaces,
Lib_Filename,
Lib_Dir,
Symbol_Data,
Driver_Name,
Lib_Version,
Auto_Init);
end Build_Dynamic_Library;
------------------------------
-- Default_Symbol_File_Name --
------------------------------
function Default_Symbol_File_Name return String is
begin
return Default_Symbol_File_Name_Ptr.all;
end Default_Symbol_File_Name;
--------------------------------------
-- Default_Symbol_File_Name_Default --
--------------------------------------
function Default_Symbol_File_Name_Default return String is
begin
return "";
end Default_Symbol_File_Name_Default;
-------------
-- DLL_Ext --
-------------
function DLL_Ext return String is
begin
return DLL_Ext_Ptr.all;
end DLL_Ext;
---------------------
-- DLL_Ext_Default --
---------------------
function DLL_Ext_Default return String is
begin
return "so";
end DLL_Ext_Default;
----------------
-- DLL_Prefix --
----------------
function DLL_Prefix return String is
begin
return DLL_Prefix_Ptr.all;
end DLL_Prefix;
------------------------
-- DLL_Prefix_Default --
------------------------
function DLL_Prefix_Default return String is
begin
return "lib";
end DLL_Prefix_Default;
--------------------
-- Dynamic_Option --
--------------------
function Dynamic_Option return String is
begin
return Dynamic_Option_Ptr.all;
end Dynamic_Option;
----------------------------
-- Dynamic_Option_Default --
----------------------------
function Dynamic_Option_Default return String is
begin
return "-shared";
end Dynamic_Option_Default;
-------------------
-- Is_Object_Ext --
-------------------
function Is_Object_Ext (Ext : String) return Boolean is
begin
return Is_Object_Ext_Ptr (Ext);
end Is_Object_Ext;
---------------------------
-- Is_Object_Ext_Default --
---------------------------
function Is_Object_Ext_Default (Ext : String) return Boolean is
begin
return Ext = ".o";
end Is_Object_Ext_Default;
--------------
-- Is_C_Ext --
--------------
function Is_C_Ext (Ext : String) return Boolean is
begin
return Is_C_Ext_Ptr (Ext);
end Is_C_Ext;
----------------------
-- Is_C_Ext_Default --
----------------------
function Is_C_Ext_Default (Ext : String) return Boolean is
begin
return Ext = ".c";
end Is_C_Ext_Default;
--------------------
-- Is_Archive_Ext --
--------------------
function Is_Archive_Ext (Ext : String) return Boolean is
begin
return Is_Archive_Ext_Ptr (Ext);
end Is_Archive_Ext;
----------------------------
-- Is_Archive_Ext_Default --
----------------------------
function Is_Archive_Ext_Default (Ext : String) return Boolean is
begin
return Ext = ".a";
end Is_Archive_Ext_Default;
-------------
-- Libgnat --
-------------
function Libgnat return String is
begin
return Libgnat_Ptr.all;
end Libgnat;
---------------------
-- Libgnat_Default --
---------------------
function Libgnat_Default return String is
begin
return "libgnat.a";
end Libgnat_Default;
------------------------
-- Library_Exists_For --
------------------------
function Library_Exists_For
(Project : Project_Id;
In_Tree : Project_Tree_Ref) return Boolean
is
begin
return Library_Exists_For_Ptr (Project, In_Tree);
end Library_Exists_For;
--------------------------------
-- Library_Exists_For_Default --
--------------------------------
function Library_Exists_For_Default
(Project : Project_Id;
In_Tree : Project_Tree_Ref) return Boolean
is
pragma Unreferenced (In_Tree);
begin
if not Project.Library then
Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
"for non library project");
return False;
else
declare
Lib_Dir : constant String :=
Get_Name_String (Project.Library_Dir.Display_Name);
Lib_Name : constant String :=
Get_Name_String (Project.Library_Name);
begin
if Project.Library_Kind = Static then
return Is_Regular_File
(Lib_Dir & Directory_Separator & "lib" &
Fil.Append_To (Lib_Name, Archive_Ext));
else
return Is_Regular_File
(Lib_Dir & Directory_Separator & DLL_Prefix &
Fil.Append_To (Lib_Name, DLL_Ext));
end if;
end;
end if;
end Library_Exists_For_Default;
---------------------------
-- Library_File_Name_For --
---------------------------
function Library_File_Name_For
(Project : Project_Id;
In_Tree : Project_Tree_Ref) return File_Name_Type
is
begin
return Library_File_Name_For_Ptr (Project, In_Tree);
end Library_File_Name_For;
-----------------------------------
-- Library_File_Name_For_Default --
-----------------------------------
function Library_File_Name_For_Default
(Project : Project_Id;
In_Tree : Project_Tree_Ref) return File_Name_Type
is
pragma Unreferenced (In_Tree);
begin
if not Project.Library then
Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
"for non library project");
return No_File;
else
declare
Lib_Name : constant String :=
Get_Name_String (Project.Library_Name);
begin
if Project.Library_Kind =
Static
then
Name_Len := 3;
Name_Buffer (1 .. Name_Len) := "lib";
Add_Str_To_Name_Buffer (Fil.Append_To (Lib_Name, Archive_Ext));
else
Name_Len := 0;
Add_Str_To_Name_Buffer (DLL_Prefix);
Add_Str_To_Name_Buffer (Fil.Append_To (Lib_Name, DLL_Ext));
end if;
return Name_Find;
end;
end if;
end Library_File_Name_For_Default;
--------------------------------------
-- Library_Major_Minor_Id_Supported --
--------------------------------------
function Library_Major_Minor_Id_Supported return Boolean is
begin
return Library_Major_Minor_Id_Supported_Ptr.all;
end Library_Major_Minor_Id_Supported;
----------------------------------------------
-- Library_Major_Minor_Id_Supported_Default --
----------------------------------------------
function Library_Major_Minor_Id_Supported_Default return Boolean is
begin
return True;
end Library_Major_Minor_Id_Supported_Default;
----------------
-- Object_Ext --
----------------
function Object_Ext return String is
begin
return Object_Ext_Ptr.all;
end Object_Ext;
------------------------
-- Object_Ext_Default --
------------------------
function Object_Ext_Default return String is
begin
return "o";
end Object_Ext_Default;
----------------
-- PIC_Option --
----------------
function PIC_Option return String is
begin
return PIC_Option_Ptr.all;
end PIC_Option;
------------------------
-- PIC_Option_Default --
------------------------
function PIC_Option_Default return String is
begin
return "-fPIC";
end PIC_Option_Default;
-----------------------------------------------
-- Standalone_Library_Auto_Init_Is_Supported --
-----------------------------------------------
function Standalone_Library_Auto_Init_Is_Supported return Boolean is
begin
return Standalone_Library_Auto_Init_Is_Supported_Ptr.all;
end Standalone_Library_Auto_Init_Is_Supported;
-------------------------------------------------------
-- Standalone_Library_Auto_Init_Is_Supported_Default --
-------------------------------------------------------
function Standalone_Library_Auto_Init_Is_Supported_Default return Boolean is
begin
return True;
end Standalone_Library_Auto_Init_Is_Supported_Default;
---------------------------
-- Support_For_Libraries --
---------------------------
function Support_For_Libraries return Library_Support is
begin
return Support_For_Libraries_Ptr.all;
end Support_For_Libraries;
-----------------------------------
-- Support_For_Libraries_Default --
-----------------------------------
function Support_For_Libraries_Default return Library_Support is
begin
return Full;
end Support_For_Libraries_Default;
end MLib.Tgt;
gprbuild-gpl-2014-src/gnat/xgnatugn.adb 0000644 0000767 0000145 00000110217 12323721731 017371 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT SYSTEM UTILITIES --
-- --
-- X G N A T U G N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2003-2013, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
------------------------------------------------------------------------------
-- This utility is used to process the source of gnat_ugn.texi to make a
-- version suitable for running through standard Texinfo processor. It is
-- invoked as follows:
-- xgnatugn [ [ ] ]
-- 1. is the target type of the manual, which is one of:
-- unw Unix and Windows platforms
-- vms OpenVMS
-- 2. is the file name of the Texinfo file to be
-- preprocessed.
-- 3. is the name of the word list file. This file is used for
-- rewriting the VMS edition. Each line contains a word mapping: The source
-- word in the first column, the target word in the second column. The
-- columns are separated by a '^' character. When preprocessing for VMS, the
-- first word is replaced with the second. (Words consist of letters,
-- digits, and the four characters "?-_~". A sequence of multiple words can
-- be replaced if they are listed in the first column, separated by a single
-- space character. If multiple words are to be replaced, there must be a
-- replacement for each prefix.)
-- 4. (optional) is the name of the output file. It defaults to
-- gnat_ugn_unw.texi or gnat_ugn_vms.texi, depending on the target.
-- 5. (optional, and allowed only if is explicit)
-- can be any string. If present, it indicates that warning messages are
-- to be output to Standard_Error. If absent, no warning messages are
-- generated.
-- The following steps are performed:
-- In VMS mode
-- Any occurrences of ^alpha^beta^ are replaced by beta. The sequence
-- must fit on a single line, and there can only be one occurrence on a
-- line.
-- Any occurrences of a word in the Ug_Words list are replaced by the
-- appropriate vms equivalents. Note that replacements do not occur
-- within ^alpha^beta^ sequences.
-- Any occurrence of [filename].extension, where extension one of the
-- following:
-- "o", "ads", "adb", "ali", "ada", "atb", "ats", "adc", "c"
-- replaced by the appropriate VMS names (all upper case with .o
-- replaced .OBJ). Note that replacements do not occur within
-- ^alpha^beta^ sequences.
-- In UNW mode
-- Any occurrences of ^alpha^beta^ are replaced by alpha. The sequence
-- must fit on a single line.
-- In both modes
-- The sequence ^^^ is replaced by a single ^. This escape sequence
-- must be used if the literal character ^ is to appear in the
-- output. A line containing this escape sequence may not also contain
-- a ^alpha^beta^ sequence.
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Strings; use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Strings.Maps; use Ada.Strings.Maps;
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Spitbol; use GNAT.Spitbol;
with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString;
procedure Xgnatugn is
procedure Usage;
-- Print usage information. Invoked if an invalid command line is
-- encountered.
subtype Sfile is Ada.Streams.Stream_IO.File_Type;
Output_File : Sfile;
-- The preprocessed output is written to this file
type Input_File is record
Name : VString;
Data : Ada.Text_IO.File_Type;
Line : Natural := 0;
end record;
-- Records information on an input file. Name and Line are used
-- in error messages, Line is updated automatically by Get_Line.
function Get_Line (Input : access Input_File) return String;
-- Returns a line from Input and performs the necessary
-- line-oriented checks (length, character set, trailing spaces).
procedure Put_Line (F : Sfile; S : String);
-- Local version of Put_Line ensures Unix style line endings
First_Time : Boolean := True;
Number_Of_Warnings : Natural := 0;
Number_Of_Errors : Natural := 0;
Warnings_Enabled : Boolean;
procedure Error
(Input : Input_File;
At_Character : Natural;
Message : String);
procedure Error
(Input : Input_File;
Message : String);
-- Prints a message reporting an error on line Input.Line. If
-- At_Character is not 0, indicate the exact character at which
-- the error occurs.
procedure Warning
(Input : Input_File;
At_Character : Natural;
Message : String);
Dictionary_File : aliased Input_File;
procedure Read_Dictionary_File;
-- Dictionary_File is opened using the name given on the command
-- line. It contains the replacements for the Ug_Words list.
-- Read_Dictionary_File reads Dictionary_File and fills the
-- Ug_Words table.
Source_File : aliased Input_File;
procedure Process_Source_File;
-- Source_File is opened using the name given on the command line.
-- It contains the Texinfo source code. Process_Source_File
-- performs the necessary replacements.
type Flag_Type is (UNW, VMS, FSFEDITION, PROEDITION, GPLEDITION);
-- The flags permitted in @ifset or @ifclear commands:
--
-- Targets for preprocessing
-- UNW (Unix and Windows) or VMS
--
-- Editions of the manual
-- FSFEDITION, PROEDITION, or GPLEDITION
--
-- Conditional commands for target are processed by xgnatugn
--
-- Conditional commands for edition are passed through unchanged
subtype Target_Type is Flag_Type range UNW .. VMS;
Target : Target_Type;
-- The Target variable is initialized using the command line
Valid_Characters : constant Character_Set := To_Set (Span => (' ', '~'));
-- This array controls which characters are permitted in the input
-- file (after line breaks have been removed). Valid characters
-- are all printable ASCII characters and the space character.
Word_Characters : constant Character_Set :=
(To_Set (Ranges =>
(('0', '9'), ('a', 'z'), ('A', 'Z')))
or To_Set ("?-_~"));
-- The characters which are permitted in words. Other (valid)
-- characters are assumed to be delimiters between words. Note that
-- this set has to include all characters of the source words of the
-- Ug_Words dictionary.
Reject_Trailing_Spaces : constant Boolean := True;
-- Controls whether Xgnatug rejects superfluous space characters
-- at the end of lines.
Maximum_Line_Length : constant Positive := 79;
Fatal_Line_Length_Limit : constant Positive := 5000;
Fatal_Line_Length : exception;
-- If Maximum_Line_Length is exceeded in an input file, an error
-- message is printed. If Fatal_Line_Length is exceeded,
-- execution terminates with a Fatal_Line_Length exception.
VMS_Escape_Character : constant Character := '^';
-- The character used to mark VMS alternatives (^alpha^beta^)
Extensions : GNAT.Spitbol.Table_VString.Table (20);
procedure Initialize_Extensions;
-- This table records extensions and their replacement for
-- rewriting filenames in the VMS version of the manual.
function Is_Extension (Extension : String) return Boolean;
function Get_Replacement_Extension (Extension : String) return String;
-- These functions query the replacement table. Is_Extension
-- checks if the given string is a known extension.
-- Get_Replacement returns the replacement extension.
Ug_Words : GNAT.Spitbol.Table_VString.Table (200);
function Is_Known_Word (Word : String) return Boolean;
function Get_Replacement_Word (Word : String) return String;
-- The Ug_Words table lists replacement words for the VMS version
-- of the manual. Is_Known_Word and Get_Replacement_Word query
-- this table. The table is filled using Read_Dictionary_File.
function Rewrite_Source_Line (Line : String) return String;
-- This subprogram takes a line and rewrites it according to Target.
-- It relies on information in Source_File to generate error messages.
-----------
-- Usage --
-----------
procedure Usage is
begin
Put_Line (Standard_Error,
"usage: xgnatugn TARGET SOURCE DICTIONARY [OUTFILE [WARNINGS]]");
New_Line;
Put_Line (Standard_Error, "TARGET is one of:");
for T in Target_Type'Range loop
Put_Line (Standard_Error, " " & Target_Type'Image (T));
end loop;
New_Line;
Put_Line (Standard_Error, "SOURCE is the source file to process.");
New_Line;
Put_Line (Standard_Error, "DICTIONARY is the name of a file "
& "that contains word replacements");
Put_Line (Standard_Error, "for the VMS version.");
New_Line;
Put_Line (Standard_Error,
"OUT-FILE, if present, is the output file to be created;");
Put_Line (Standard_Error,
"If OUT-FILE is absent, the output file is either " &
"gnat_ugn_unw.texi, ");
Put_Line (Standard_Error,
"or gnat_ugn_vms.texi, depending on TARGET.");
New_Line;
Put_Line (Standard_Error,
"WARNINGS, if present, is any string;");
Put_Line (Standard_Error,
"it will result in warning messages (e.g., line too long))");
Put_Line (Standard_Error,
"being output to Standard_Error.");
end Usage;
--------------
-- Get_Line --
--------------
function Get_Line (Input : access Input_File) return String is
Line_Buffer : String (1 .. Fatal_Line_Length_Limit);
Last : Natural;
begin
Input.Line := Input.Line + 1;
Get_Line (Input.Data, Line_Buffer, Last);
if Last = Line_Buffer'Last then
Error (Input.all, "line exceeds fatal line length limit");
raise Fatal_Line_Length;
end if;
declare
Line : String renames Line_Buffer (Line_Buffer'First .. Last);
begin
for J in Line'Range loop
if not Is_In (Line (J), Valid_Characters) then
Error (Input.all, J, "invalid character");
exit;
end if;
end loop;
if Line'Length > Maximum_Line_Length then
Warning (Input.all, Maximum_Line_Length + 1, "line too long");
end if;
if Reject_Trailing_Spaces
and then Line'Length > 0
and then Line (Line'Last) = ' '
then
Error (Input.all, Line'Last, "trailing space character");
end if;
return Trim (Line, Right);
end;
end Get_Line;
--------------
-- Put_Line --
--------------
procedure Put_Line (F : Sfile; S : String) is
begin
String'Write (Stream (F), S);
Character'Write (Stream (F), ASCII.LF);
end Put_Line;
-----------
-- Error --
-----------
procedure Error
(Input : Input_File;
Message : String)
is
begin
Error (Input, 0, Message);
end Error;
procedure Error
(Input : Input_File;
At_Character : Natural;
Message : String)
is
Line_Image : constant String := Integer'Image (Input.Line);
At_Character_Image : constant String := Integer'Image (At_Character);
-- These variables are required because we have to drop the leading
-- space character.
begin
Number_Of_Errors := Number_Of_Errors + 1;
if At_Character > 0 then
Put_Line (Standard_Error,
S (Input.Name) & ':'
& Line_Image (Line_Image'First + 1 .. Line_Image'Last) & ':'
& At_Character_Image (At_Character_Image'First + 1
.. At_Character_Image'Last)
& ": "
& Message);
else
Put_Line (Standard_Error,
S (Input.Name) & ':'
& Line_Image (Line_Image'First + 1 .. Line_Image'Last)
& ": "
& Message);
end if;
end Error;
-------------
-- Warning --
-------------
procedure Warning
(Input : Input_File;
At_Character : Natural;
Message : String)
is
Line_Image : constant String := Integer'Image (Input.Line);
At_Character_Image : constant String := Integer'Image (At_Character);
-- These variables are required because we have to drop the leading
-- space character.
begin
if not Warnings_Enabled then
return;
end if;
Number_Of_Warnings := Number_Of_Warnings + 1;
if At_Character > 0 then
Put_Line (Standard_Error,
S (Input.Name) & ':'
& Line_Image (Line_Image'First + 1 .. Line_Image'Last) & ':'
& At_Character_Image (At_Character_Image'First + 1
.. At_Character_Image'Last)
& ": warning: "
& Message);
else
Put_Line (Standard_Error,
S (Input.Name) & ':'
& Line_Image (Line_Image'First + 1 .. Line_Image'Last)
& ": warning: "
& Message);
end if;
end Warning;
--------------------------
-- Read_Dictionary_File --
--------------------------
procedure Read_Dictionary_File is
begin
while not End_Of_File (Dictionary_File.Data) loop
declare
Line : constant String :=
Get_Line (Dictionary_File'Access);
Split : constant Natural :=
Index (Line, (1 => VMS_Escape_Character));
begin
if Line'Length = 0 then
Error (Dictionary_File, "empty line in dictionary file");
elsif Line (Line'First) = ' ' then
Error (Dictionary_File, 1, "line starts with space character");
elsif Split = 0 then
Error (Dictionary_File, "line does not contain "
& VMS_Escape_Character & " character");
else
declare
Source : constant String :=
Trim (Line (1 .. Split - 1), Both);
Target : constant String :=
Trim (Line (Split + 1 .. Line'Last), Both);
Two_Spaces : constant Natural := Index (Source, " ");
Non_Word_Character : constant Natural :=
Index (Source,
Word_Characters or
To_Set (" ."),
Outside);
begin
if Two_Spaces /= 0 then
Error (Dictionary_File, Two_Spaces,
"multiple space characters in source word");
end if;
if Non_Word_Character /= 0 then
Error (Dictionary_File, Non_Word_Character,
"illegal character in source word");
end if;
if Source'Length = 0 then
Error (Dictionary_File, "source is empty");
elsif Target'Length = 0 then
Error (Dictionary_File, "target is empty");
else
Set (Ug_Words, Source, V (Target));
-- Ensure that if Source is a sequence of words
-- "WORD1 WORD2 ...", we already have a mapping for
-- "WORD1".
for J in Source'Range loop
if Source (J) = ' ' then
declare
Prefix : String renames
Source (Source'First .. J - 1);
begin
if not Is_Known_Word (Prefix) then
Error (Dictionary_File,
"prefix '" & Prefix
& "' not known at this point");
end if;
end;
end if;
end loop;
end if;
end;
end if;
end;
end loop;
end Read_Dictionary_File;
-------------------------
-- Rewrite_Source_Line --
-------------------------
function Rewrite_Source_Line (Line : String) return String is
-- We use a simple lexer to split the line into tokens:
-- Word consisting entirely of Word_Characters
-- VMS_Alternative ^alpha^beta^ replacement (but not ^^^)
-- Space a space character
-- Other everything else (sequence of non-word characters)
-- VMS_Error incomplete VMS alternative
-- End_Of_Line no more characters on this line
-- A sequence of three VMS_Escape_Characters is automatically
-- collapsed to an Other token.
type Token_Span is record
First, Last : Positive;
end record;
-- The character range covered by a token in Line
type Token_Kind is (End_Of_Line, Word, Other,
VMS_Alternative, VMS_Error);
type Token_Record (Kind : Token_Kind := End_Of_Line) is record
First : Positive;
case Kind is
when Word | Other =>
Span : Token_Span;
when VMS_Alternative =>
Non_VMS, VMS : Token_Span;
when VMS_Error | End_Of_Line =>
null;
end case;
end record;
Input_Position : Positive := Line'First;
Token : Token_Record;
-- The position of the next character to be processed by Next_Token
procedure Next_Token;
-- Returns the next token in Line, starting at Input_Position
Rewritten_Line : VString;
-- Collects the line as it is rewritten
procedure Rewrite_Word;
-- The current token is assumed to be a Word. When processing the VMS
-- version of the manual, additional tokens are gathered to check if
-- we have a file name or a sequence of known words.
procedure Maybe_Rewrite_Extension;
-- The current token is assumed to be Other. When processing the VMS
-- version of the manual and the token represents a single dot ".",
-- the following word is rewritten according to the rules for
-- extensions.
VMS_Token_Seen : Boolean := False;
-- This is set to true if a VMS_Alternative has been encountered, or a
-- ^^^ token.
----------------
-- Next_Token --
----------------
procedure Next_Token is
Remaining_Line : String renames Line (Input_Position .. Line'Last);
Last_Character : Natural;
begin
if Remaining_Line'Length = 0 then
Token := (End_Of_Line, Remaining_Line'First);
return;
end if;
-- ^alpha^beta^, the VMS_Alternative case
if Remaining_Line (Remaining_Line'First) = VMS_Escape_Character then
declare
VMS_Second_Character, VMS_Third_Character : Natural;
begin
if VMS_Token_Seen then
Error (Source_File, Remaining_Line'First,
"multiple " & VMS_Escape_Character
& " characters on a single line");
else
VMS_Token_Seen := True;
end if;
-- Find the second and third escape character. If one of
-- them is not present, generate an error token.
VMS_Second_Character :=
Index (Remaining_Line (Remaining_Line'First + 1
.. Remaining_Line'Last),
(1 => VMS_Escape_Character));
if VMS_Second_Character = 0 then
Input_Position := Remaining_Line'Last + 1;
Token := (VMS_Error, Remaining_Line'First);
return;
end if;
VMS_Third_Character :=
Index (Remaining_Line (VMS_Second_Character + 1
.. Remaining_Line'Last),
(1 => VMS_Escape_Character));
if VMS_Third_Character = 0 then
Input_Position := Remaining_Line'Last + 1;
Token := (VMS_Error, Remaining_Line'First);
return;
end if;
-- Consume all the characters we are about to include in
-- the token.
Input_Position := VMS_Third_Character + 1;
-- Check if we are in a ^^^ situation, and return an Other
-- token in this case.
if Remaining_Line'First + 1 = VMS_Second_Character
and then Remaining_Line'First + 2 = VMS_Third_Character
then
Token := (Other, Remaining_Line'First,
(Remaining_Line'First, Remaining_Line'First));
return;
end if;
Token := (VMS_Alternative, Remaining_Line'First,
(Remaining_Line'First + 1, VMS_Second_Character - 1),
(VMS_Second_Character + 1, VMS_Third_Character - 1));
return;
end;
end if;
-- The Word case. Search for characters not in Word_Characters.
-- We have found a word if the first non-word character is not
-- the first character in Remaining_Line, i.e. if Remaining_Line
-- starts with a word character.
Last_Character := Index (Remaining_Line, Word_Characters, Outside);
if Last_Character /= Remaining_Line'First then
-- If we haven't found a character which is not in
-- Word_Characters, all remaining characters are part of the
-- current Word token.
if Last_Character = 0 then
Last_Character := Remaining_Line'Last + 1;
end if;
Input_Position := Last_Character;
Token := (Word, Remaining_Line'First,
(Remaining_Line'First, Last_Character - 1));
return;
end if;
-- Remaining characters are in the Other category. To speed
-- up processing, we collect them together if there are several
-- of them.
Input_Position := Last_Character + 1;
Token := (Other,
Remaining_Line'First,
(Remaining_Line'First, Last_Character));
end Next_Token;
------------------
-- Rewrite_Word --
------------------
procedure Rewrite_Word is
First_Word : String
renames Line (Token.Span.First .. Token.Span.Last);
begin
-- We do not perform any error checking below, so we can just skip
-- all processing for the non-VMS version.
if Target /= VMS then
Append (Rewritten_Line, First_Word);
Next_Token;
return;
end if;
if Is_Known_Word (First_Word) then
-- If we have a word from the dictionary, we look for the
-- longest possible sequence we can rewrite.
declare
Seq : Token_Span := Token.Span;
Lost_Space : Boolean := False;
begin
Next_Token;
loop
if Token.Kind = Other
and then Line (Token.Span.First .. Token.Span.Last) = " "
then
Next_Token;
if Token.Kind /= Word
or else not Is_Known_Word (Line (Seq.First
.. Token.Span.Last))
then
-- When we reach this point, the following conditions
-- are true:
-- Seq is a known word
-- The previous token was a space character
-- Seq extended to the current token is not a
-- known word.
Lost_Space := True;
exit;
else
-- Extend Seq to cover the current (known) word
Seq.Last := Token.Span.Last;
Next_Token;
end if;
else
-- When we reach this point, the following conditions
-- are true:
-- Seq is a known word
-- The previous token was a word
-- The current token is not a space character.
exit;
end if;
end loop;
-- Rewrite Seq, and add the lost space if necessary
Append (Rewritten_Line,
Get_Replacement_Word (Line (Seq.First .. Seq.Last)));
if Lost_Space then
Append (Rewritten_Line, ' ');
end if;
-- The unknown token will be processed during the
-- next iteration of the main loop.
return;
end;
end if;
Next_Token;
if Token.Kind = Other
and then Line (Token.Span.First .. Token.Span.Last) = "."
then
-- Deal with extensions
Next_Token;
if Token.Kind = Word
and then
Is_Extension (Line (Token.Span.First .. Token.Span.Last))
then
-- We have discovered a file extension. Convert the file
-- name to upper case.
Append (Rewritten_Line,
Translate (First_Word, Upper_Case_Map) & '.');
Append (Rewritten_Line,
Get_Replacement_Extension
(Line (Token.Span.First .. Token.Span.Last)));
Next_Token;
else
-- We already have: Word ".", followed by an unknown token
Append (Rewritten_Line, First_Word & '.');
-- The unknown token will be processed during the next
-- iteration of the main loop.
end if;
else
-- We have an unknown Word, followed by an unknown token.
-- The unknown token will be processed by the outer loop.
Append (Rewritten_Line, First_Word);
end if;
end Rewrite_Word;
-----------------------------
-- Maybe_Rewrite_Extension --
-----------------------------
procedure Maybe_Rewrite_Extension is
begin
-- Again, we need no special processing in the non-VMS case
if Target = VMS
and then Line (Token.Span.First .. Token.Span.Last) = "."
then
-- This extension is not preceded by a word, otherwise
-- Rewrite_Word would have handled it.
Next_Token;
if Token.Kind = Word
and then Is_Extension (Line (Token.Span.First
.. Token.Span.Last))
then
Append (Rewritten_Line, '.' & Get_Replacement_Extension
(Line (Token.Span.First .. Token.Span.Last)));
Next_Token;
else
Append (Rewritten_Line, '.');
end if;
else
Append (Rewritten_Line, Line (Token.Span.First
.. Token.Span.Last));
Next_Token;
end if;
end Maybe_Rewrite_Extension;
-- Start of processing for Process_Source_Line
begin
-- The following parser recognizes the following special token
-- sequences:
-- Word "." Word rewrite as file name if second word is extension
-- Word " " Word rewrite as a single word using Ug_Words table
Next_Token;
loop
case Token.Kind is
when End_Of_Line =>
exit;
when Word =>
Rewrite_Word;
when Other =>
Maybe_Rewrite_Extension;
when VMS_Alternative =>
if Target = VMS then
Append (Rewritten_Line, Line (Token.VMS.First
.. Token.VMS.Last));
else
Append (Rewritten_Line, Line (Token.Non_VMS.First
.. Token.Non_VMS.Last));
end if;
Next_Token;
when VMS_Error =>
Error (Source_File, Token.First, "invalid VMS alternative");
Next_Token;
end case;
end loop;
return S (Rewritten_Line);
end Rewrite_Source_Line;
-------------------------
-- Process_Source_File --
-------------------------
procedure Process_Source_File is
begin
while not End_Of_File (Source_File.Data) loop
declare
Line : constant String := Get_Line (Source_File'Access);
Rewritten : constant String := Rewrite_Source_Line (Line);
-- We unconditionally rewrite the line so that we can check the
-- syntax of all lines, and not only those which are actually
-- included in the output.
begin
if First_Time
and then Line'Length > 3 and then Line (1 .. 3) = "@if"
then
Put_Line (Output_File, "@set " & Argument (1));
First_Time := False;
end if;
Put_Line (Output_File, Rewritten);
end;
end loop;
end Process_Source_File;
---------------------------
-- Initialize_Extensions --
---------------------------
procedure Initialize_Extensions is
procedure Add (Extension : String);
-- Adds an extension which is replaced with itself (in upper case)
procedure Add (Extension, Replacement : String);
-- Adds an extension with a custom replacement
---------
-- Add --
---------
procedure Add (Extension : String) is
begin
Add (Extension, Translate (Extension, Upper_Case_Map));
end Add;
procedure Add (Extension, Replacement : String) is
begin
Set (Extensions, Extension, V (Replacement));
end Add;
-- Start of processing for Initialize_Extensions
begin
-- To avoid performance degradation, increase the constant in the
-- definition of Extensions above if you add more extensions here.
Add ("o", "OBJ");
Add ("ads");
Add ("adb");
Add ("ali");
Add ("ada");
Add ("atb");
Add ("ats");
Add ("adc");
Add ("c");
end Initialize_Extensions;
------------------
-- Is_Extension --
------------------
function Is_Extension (Extension : String) return Boolean is
begin
return Present (Extensions, Extension);
end Is_Extension;
-------------------------------
-- Get_Replacement_Extension --
-------------------------------
function Get_Replacement_Extension (Extension : String) return String is
begin
return S (Get (Extensions, Extension));
end Get_Replacement_Extension;
-------------------
-- Is_Known_Word --
-------------------
function Is_Known_Word (Word : String) return Boolean is
begin
return Present (Ug_Words, Word);
end Is_Known_Word;
--------------------------
-- Get_Replacement_Word --
--------------------------
function Get_Replacement_Word (Word : String) return String is
begin
return S (Get (Ug_Words, Word));
end Get_Replacement_Word;
-- Start of processing for Xgnatugn
Valid_Command_Line : Boolean;
Output_File_Name : VString;
begin
Initialize_Extensions;
Valid_Command_Line := Argument_Count in 3 .. 5;
-- First argument: Target
if Valid_Command_Line then
begin
Target := Flag_Type'Value (Argument (1));
if not Target'Valid then
Valid_Command_Line := False;
end if;
exception
when Constraint_Error =>
Valid_Command_Line := False;
end;
end if;
-- Second argument: Source_File
if Valid_Command_Line then
begin
Source_File.Name := V (Argument (2));
Open (Source_File.Data, In_File, Argument (2));
exception
when Ada.Text_IO.Name_Error =>
Valid_Command_Line := False;
end;
end if;
-- Third argument: Dictionary_File
if Valid_Command_Line then
begin
Dictionary_File.Name := V (Argument (3));
Open (Dictionary_File.Data, In_File, Argument (3));
exception
when Ada.Text_IO.Name_Error =>
Valid_Command_Line := False;
end;
end if;
-- Fourth argument: Output_File
if Valid_Command_Line then
if Argument_Count in 4 .. 5 then
Output_File_Name := V (Argument (4));
else
case Target is
when UNW =>
Output_File_Name := V ("gnat_ugn_unw.texi");
when VMS =>
Output_File_Name := V ("gnat_ugn_vms.texi");
end case;
end if;
Warnings_Enabled := Argument_Count = 5;
begin
Create (Output_File, Out_File, S (Output_File_Name));
exception
when Ada.Text_IO.Name_Error | Ada.Text_IO.Use_Error =>
Valid_Command_Line := False;
end;
end if;
if not Valid_Command_Line then
Usage;
Set_Exit_Status (Failure);
else
Read_Dictionary_File;
Close (Dictionary_File.Data);
-- Main processing starts here
Process_Source_File;
Close (Output_File);
Close (Source_File.Data);
New_Line (Standard_Error);
if Number_Of_Warnings = 0 then
Put_Line (Standard_Error, " NO Warnings");
else
Put (Standard_Error, Integer'Image (Number_Of_Warnings));
Put (Standard_Error, " Warning");
if Number_Of_Warnings > 1 then
Put (Standard_Error, "s");
end if;
New_Line (Standard_Error);
end if;
if Number_Of_Errors = 0 then
Put_Line (Standard_Error, " NO Errors");
else
Put (Standard_Error, Integer'Image (Number_Of_Errors));
Put (Standard_Error, " Error");
if Number_Of_Errors > 1 then
Put (Standard_Error, "s");
end if;
New_Line (Standard_Error);
end if;
if Number_Of_Errors /= 0 then
Set_Exit_Status (Failure);
else
Set_Exit_Status (Success);
end if;
end if;
end Xgnatugn;
gprbuild-gpl-2014-src/gnat/snames.h-tmpl 0000644 0000767 0000145 00000006267 11061503574 017511 0 ustar gnatmail gnat /****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* S N A M E S *
* *
* C Header File *
* *
* Copyright (C) 1992-2008, 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 3, 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 COPYING3. If not, go to *
* http://www.gnu.org/licenses for a complete copy of the 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 C file that corresponds to the Ada package specification
Snames. It was created automatically from the file snames.ads. */
/* Name_Id values */
#define Name_ !! TEMPLATE INSERTION POINT
/* Define the function to return one of the numeric values below. Note
that it actually returns a char since an enumeration value of less
than 256 entries is represented that way in Ada. The operand is a Chars
field value. */
#define Get_Attribute_Id snames__get_attribute_id
extern unsigned char Get_Attribute_Id (int);
/* Define the numeric values for attributes. */
#define Attr_ !! TEMPLATE INSERTION POINT
/* Define the numeric values for the conventions. */
#define Convention_ !! TEMPLATE INSERTION POINT
/* Define the function to check if a Name_Id value is a valid pragma */
#define Is_Pragma_Name snames__is_pragma_name
extern Boolean Is_Pragma_Name (Name_Id);
/* Define the function to return one of the numeric values below. Note
that it actually returns a char since an enumeration value of less
than 256 entries is represented that way in Ada. The operand is a Chars
field value. */
#define Get_Pragma_Id snames__get_pragma_id
extern unsigned char Get_Pragma_Id (int);
/* Define the numeric values for the pragmas. */
#define Pragma_ !! TEMPLATE_INSERTION_POINT
/* End of snames.h (C version of Snames package spec) */
gprbuild-gpl-2014-src/gnat/restrict.ads 0000644 0000767 0000145 00000063601 12323721731 017422 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- R E S T R I C T --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package deals with the implementation of the Restrictions pragma
with Namet; use Namet;
with Rident; use Rident;
with Table;
with Types; use Types;
with Uintp; use Uintp;
package Restrict is
Restrictions : Restrictions_Info := No_Restrictions;
-- This variable records restrictions found in any units in the main
-- extended unit, and in the case of restrictions checked for partition
-- consistency, restrictions found in any with'ed units, parent specs
-- etc., since we may as well check as much as we can at compile time.
-- These variables should not be referenced directly by clients. Instead
-- use Check_Restriction to record a violation of a restriction, and
-- Restriction_Active to test if a given restriction is active.
Restrictions_Loc : array (All_Restrictions) of Source_Ptr :=
(others => No_Location);
-- Locations of Restrictions pragmas for error message purposes.
-- Valid only if corresponding entry in Restrictions is set. A value
-- of No_Location is used for implicit restrictions set by another
-- pragma, and a value of System_Location is used for restrictions
-- set from package Standard by the processing in Targparm.
Restriction_Profile_Name : array (All_Restrictions) of Profile_Name;
-- Entries in this array are valid only if the corresponding restriction
-- in Restrictions set. The value is the corresponding profile name if the
-- restriction was set by a Profile or Profile_Warnings pragma. The value
-- is No_Profile in all other cases.
Main_Restrictions : Restrictions_Info := No_Restrictions;
-- This variable records only restrictions found in any units of the
-- main extended unit. These are the variables used for ali file output,
-- since we want the binder to be able to accurately diagnose inter-unit
-- restriction violations.
Restriction_Warnings : Rident.Restriction_Flags := (others => False);
-- If one of these flags is set, then it means that violation of the
-- corresponding restriction results only in a warning message, not
-- in an error message, and the restriction is not otherwise enforced.
-- Note that the flags in Restrictions are set to indicate that the
-- restriction is set in this case, but Main_Restrictions is never
-- set if Restriction_Warnings is set, so this does not look like a
-- restriction to the binder.
-- The following declarations establish a mapping between restriction
-- identifiers, and the names of corresponding restricted library units.
type Unit_Entry is record
Res_Id : Restriction_Id;
Filenm : String (1 .. 8);
end record;
Unit_Array : constant array (Positive range <>) of Unit_Entry := (
(No_Asynchronous_Control, "a-astaco"),
(No_Calendar, "a-calend"),
(No_Calendar, "calendar"),
(No_Delay, "a-calend"),
(No_Delay, "calendar"),
(No_Dynamic_Priorities, "a-dynpri"),
(No_Finalization, "a-finali"),
(No_IO, "a-direio"),
(No_IO, "directio"),
(No_IO, "a-sequio"),
(No_IO, "sequenio"),
(No_IO, "a-ststio"),
(No_IO, "a-textio"),
(No_IO, "text_io "),
(No_IO, "a-witeio"),
(No_Task_Attributes_Package, "a-tasatt"),
(No_Unchecked_Conversion, "a-unccon"),
(No_Unchecked_Conversion, "unchconv"),
(No_Unchecked_Deallocation, "a-uncdea"),
(No_Unchecked_Deallocation, "unchdeal"));
-- The following map has True for all GNAT-defined Restrictions. It is used
-- to implement pragma Restrictions (No_Implementation_Restrictions) (which
-- is why this restriction itself is excluded from the list).
Implementation_Restriction : array (All_Restrictions) of Boolean :=
(Simple_Barriers => True,
No_Calendar => True,
No_Default_Initialization => True,
No_Direct_Boolean_Operators => True,
No_Dispatching_Calls => True,
No_Dynamic_Attachment => True,
No_Elaboration_Code => True,
No_Enumeration_Maps => True,
No_Entry_Calls_In_Elaboration_Code => True,
No_Entry_Queue => True,
No_Exception_Handlers => True,
No_Exception_Propagation => True,
No_Exception_Registration => True,
No_Finalization => True,
No_Fixed_IO => True,
No_Implementation_Attributes => True,
No_Implementation_Pragmas => True,
No_Implicit_Conditionals => True,
No_Implicit_Aliasing => True,
No_Implicit_Dynamic_Code => True,
No_Implicit_Loops => True,
No_Initialize_Scalars => True,
No_Local_Protected_Objects => True,
No_Long_Long_Integers => True,
No_Multiple_Elaboration => True,
No_Protected_Type_Allocators => True,
No_Relative_Delay => True,
No_Requeue_Statements => True,
No_Secondary_Stack => True,
No_Select_Statements => True,
No_Standard_Storage_Pools => True,
No_Stream_Optimizations => True,
No_Streams => True,
No_Task_Attributes_Package => True,
No_Task_Termination => True,
No_Tasking => True,
No_Wide_Characters => True,
Static_Priorities => True,
Static_Storage_Size => True,
SPARK_05 => True,
others => False);
-- The following table records entries made by Restrictions pragmas
-- that specify a parameter for No_Dependence. Each such pragma makes
-- an entry in this table.
-- Note: we have chosen to implement this restriction in the "syntactic"
-- form, where we do not check that the named package is a language defined
-- package, but instead we allow arbitrary package names. The discussion of
-- this issue is not complete in the ARG, but the sense seems to be leaning
-- in this direction, which makes more sense to us, since it is much more
-- useful, and much easier to implement.
type ND_Entry is record
Unit : Node_Id;
-- The unit parameter from the No_Dependence pragma
Warn : Boolean;
-- True if from Restriction_Warnings, False if from Restrictions
Profile : Profile_Name;
-- Set to name of profile from which No_Dependence entry came, or to
-- No_Profile if a pragma Restriction set the No_Dependence entry.
end record;
package No_Dependences is new Table.Table (
Table_Component_Type => ND_Entry,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 200,
Table_Increment => 200,
Table_Name => "Name_No_Dependences");
-----------------
-- Subprograms --
-----------------
-- Note: several of these subprograms can generate error messages (e.g.
-- Check_Restriction). These routines should be called in the analyzer
-- rather than the expander, so that the associated error messages are
-- correctly generated in semantics only (-gnatc) mode.
function Abort_Allowed return Boolean;
pragma Inline (Abort_Allowed);
-- Tests to see if abort is allowed by the current restrictions settings.
-- For abort to be allowed, either No_Abort_Statements must be False,
-- or Max_Asynchronous_Select_Nesting must be non-zero.
procedure Check_Compiler_Unit (Feature : String; N : Node_Id);
-- If unit N is in a unit that has a pragma Compiler_Unit_Warning, then
-- a message is posted on node N noting use of the given feature is not
-- permitted in the compiler (bootstrap considerations).
procedure Check_Compiler_Unit (Feature : String; Loc : Source_Ptr);
-- If unit N is in a unit that has a pragma Compiler_Unit_Warning, then a
-- message is posted at location Loc noting use of the given feature is not
-- permitted in the compiler (bootstrap considerations).
procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id);
-- Checks if loading of unit U is prohibited by the setting of some
-- restriction (e.g. No_IO restricts the loading of unit Ada.Text_IO).
-- If a restriction exists post error message at the given node.
procedure Check_Restriction
(Msg_Issued : out Boolean;
R : Restriction_Id;
N : Node_Id;
V : Uint := Uint_Minus_1);
-- Checks that the given restriction is not set, and if it is set, an
-- appropriate message is posted on the given node, in which case
-- Msg_Issued is set to True (and False otherwise). Also records the
-- violation in the appropriate internal arrays. Note that it is mandatory
-- to always use this routine to check if a restriction is violated. Such
-- checks must never be done directly by the caller, since otherwise
-- violations in the absence of restrictions are not properly recorded. The
-- value of V is relevant only for parameter restrictions, and in this case
-- indicates the exact count for the violation. If the exact count is not
-- known, V is left at its default of -1 which indicates an unknown count.
procedure Check_Restriction
(R : Restriction_Id;
N : Node_Id;
V : Uint := Uint_Minus_1);
-- Wrapper on Check_Restriction with Msg_Issued, with the out-parameter
-- being ignored here.
procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id);
-- N is the node of an attribute definition clause. An error message
-- (warning) will be issued if a restriction (warning) was previously set
-- for this attribute using Set_No_Use_Of_Attribute.
procedure Check_Restriction_No_Use_Of_Pragma (N : Node_Id);
-- N is the node of a pragma. An error message (warning) will be issued
-- if a restriction (warning) was previously set for this pragma using
-- Set_No_Use_Of_Pragma.
procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id);
-- Called when a dependence on a unit is created (either implicitly, or by
-- an explicit WITH clause). U is a node for the unit involved, and Err is
-- the node to which an error will be attached if necessary.
procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id);
-- N is the node id for an N_Aspect_Specification. An error message
-- (warning) will be issued if a restriction (warning) was previous set
-- for this aspect using Set_No_Specification_Of_Aspect.
procedure Check_Elaboration_Code_Allowed (N : Node_Id);
-- Tests to see if elaboration code is allowed by the current restrictions
-- settings. This function is called by Gigi when it needs to define an
-- elaboration routine. If elaboration code is not allowed, an error
-- message is posted on the node given as argument.
procedure Check_SPARK_Restriction
(Msg : String;
N : Node_Id;
Force : Boolean := False);
-- Node N represents a construct not allowed in SPARK_05 mode. If this is
-- a source node, or if the restriction is forced (Force = True), and
-- the SPARK_05 restriction is set, then an error is issued on N. Msg
-- is appended to the restriction failure message.
procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id);
-- Same as Check_SPARK_Restriction except there is a continuation message
-- Msg2 following the initial message Msg1.
procedure Check_No_Implicit_Aliasing (Obj : Node_Id);
-- Obj is a node for which Is_Aliased_View is True, which is being used in
-- a context (e.g. 'Access) where no implicit aliasing is allowed if the
-- restriction No_Implicit_Aliasing is set. This procedure checks for the
-- case where the restriction is active and Obj does not meet the required
-- rules for avoiding implicit aliases, and issues a restriction message.
procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id);
-- Tests to see if dynamic code generation (dynamically generated
-- trampolines, in particular) is allowed by the current restrictions
-- settings. This function is called by Gigi when it needs to generate code
-- that generates a trampoline. If not allowed, an error message is posted
-- on the node given as argument.
procedure Check_No_Implicit_Heap_Alloc (N : Node_Id);
-- Equivalent to Check_Restriction (No_Implicit_Heap_Allocations, N).
-- Provided for easy use by back end, which has to check this restriction.
procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id);
-- This routine checks if the entity E is one of the obsolescent entries
-- in Ada.Characters.Handling in Ada 2005 and No_Obsolescent_Features
-- restriction is active. If so an appropriate message is given. N is
-- the node on which the message is to be placed. It's a bit kludgy to
-- have this highly specialized routine rather than some wonderful general
-- mechanism (e.g. a special pragma) to handle this case, but there are
-- only six cases, and it is not worth the effort to do something general.
procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id);
-- This procedure checks if the No_Wide_Character restriction is active,
-- and if so, if N Comes_From_Source, and the root type of E is one of
-- [Wide_]Wide_Character or [Wide_]Wide_String, then the restriction
-- violation is recorded, and an appropriate message given.
function Get_Restriction_Id
(N : Name_Id) return Restriction_Id;
-- Given an identifier name, determines if it is a valid restriction
-- identifier, and if so returns the corresponding Restriction_Id value,
-- otherwise returns Not_A_Restriction_Id.
function OK_No_Dependence_Unit_Name (N : Node_Id) return Boolean;
-- Used in checking No_Dependence argument of pragma Restrictions or
-- pragma Restrictions_Warning, or attribute Restriction_Set. Returns
-- True if N has the proper form for a unit name, False otherwise.
function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean;
-- Determine if given location is covered by a hidden region range in the
-- SPARK hides table.
function No_Exception_Handlers_Set return Boolean;
-- Test to see if current restrictions settings specify that no exception
-- handlers are present. This function is called by Gigi when it needs to
-- expand an AT END clean up identifier with no exception handler. True
-- will be returned if the configurable run-time is activated, and either
-- of the restrictions No_Exception_Handlers or No_Exception_Propagation is
-- set. In the latter case, the source may contain handlers but they either
-- get converted using the local goto transformation or deleted.
function No_Exception_Propagation_Active return Boolean;
-- Test to see if current restrictions settings specify that no
-- exception propagation is activated.
function Process_Restriction_Synonyms (N : Node_Id) return Name_Id;
-- Id is a node whose Chars field contains the name of a restriction.
-- If it is one of synonyms that we allow for historical purposes (for
-- list see System.Rident), then the proper official name is returned.
-- Otherwise the Chars field of the argument is returned unchanged.
function Restriction_Active (R : All_Restrictions) return Boolean;
pragma Inline (Restriction_Active);
-- Determines if a given restriction is active. This call should only be
-- used where the compiled code depends on whether the restriction is
-- active. Always use Check_Restriction to record a violation. Note that
-- this returns False if we only have a Restriction_Warnings set, since
-- restriction warnings should never affect generated code. If you want
-- to know if a call to Check_Restriction is needed then use the function
-- Restriction_Check_Required instead.
function Restriction_Check_Required (R : All_Restrictions) return Boolean;
pragma Inline (Restriction_Check_Required);
-- Determines if either a Restriction_Warnings or Restrictions pragma has
-- been given for the specified restriction. If true, then a subsequent
-- call to Check_Restriction is required if the restriction is violated.
-- This must not be used to guard code generation that depends on whether
-- a restriction is active (see Restriction_Active above). Typically it
-- is used to avoid complex code to determine if a restriction is violated,
-- executing this code only if needed.
function Restricted_Profile return Boolean;
-- Tests if set of restrictions corresponding to Profile (Restricted) is
-- currently in effect (set by pragma Profile, or by an appropriate set of
-- individual Restrictions pragmas). Returns True only if all the required
-- restrictions are set.
procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr);
-- Insert a new hidden region range in the SPARK hides table. The effect
-- is to hide any SPARK violation messages which are in the range Loc1 to
-- Loc2-1 (i.e. Loc2 is the first location for reenabling checks).
procedure Set_Profile_Restrictions
(P : Profile_Name;
N : Node_Id;
Warn : Boolean);
-- Sets the set of restrictions associated with the given profile name. N
-- is the node of the construct to which error messages are to be attached
-- as required. Warn is set True for the case of Profile_Warnings where the
-- restrictions are set as warnings rather than legality requirements, and
-- is also True for Profile if the Treat_Restrictions_As_Warnings flag is
-- set. It is false for Profile if this flag is not set.
procedure Set_Restriction
(R : All_Boolean_Restrictions;
N : Node_Id);
-- N is a node (typically a pragma node) that has the effect of setting
-- Boolean restriction R. The restriction is set in Restrictions, and
-- also in Main_Restrictions if this is the main unit.
procedure Set_Restriction
(R : All_Parameter_Restrictions;
N : Node_Id;
V : Integer);
-- Similar to the above, except that this is used for the case of a
-- parameter restriction, and the corresponding value V is given.
procedure Set_Restriction_No_Dependence
(Unit : Node_Id;
Warn : Boolean;
Profile : Profile_Name := No_Profile);
-- Sets given No_Dependence restriction in table if not there already. Warn
-- is True if from Restriction_Warnings, or for Restrictions if the flag
-- Treat_Restrictions_As_Warnings is set. False if from Restrictions and
-- this flag is not set. Profile is set to a non-default value if the
-- No_Dependence restriction comes from a Profile pragma.
procedure Set_Restriction_No_Specification_Of_Aspect
(N : Node_Id;
Warning : Boolean);
-- N is the node id for an identifier from a pragma Restrictions for the
-- No_Specification_Of_Aspect pragma. An error message will be issued if
-- the identifier is not a valid aspect name. Warning is set True for the
-- case of a Restriction_Warnings pragma specifying this restriction and
-- False for a Restrictions pragma specifying this restriction.
procedure Set_Restriction_No_Use_Of_Attribute
(N : Node_Id;
Warning : Boolean);
-- N is the node id for the identifier in a pragma Restrictions for
-- No_Use_Of_Attribute. Caller has verified that this is a valid attribute
-- designator.
procedure Set_Restriction_No_Use_Of_Pragma
(N : Node_Id;
Warning : Boolean);
-- N is the node id for the identifier in a pragma Restrictions for
-- No_Use_Of_Pragma. Caller has verified that this is a valid pragma id.
function Tasking_Allowed return Boolean;
pragma Inline (Tasking_Allowed);
-- Tests if tasking operations are allowed by the current restrictions
-- settings. For tasking to be allowed Max_Tasks must be non-zero.
----------------------------------------------
-- Handling of Boolean Compilation Switches --
----------------------------------------------
-- The following declarations are used for proper saving and restoring of
-- restrictions for separate compilation units. There are two cases:
-- For partition-wide restrictions, we just let the restrictions pragmas
-- pile up, and we never reset them. We might as well detect what we can
-- at compile time. If e.g. a with'ed unit has a restriction for one of
-- the partition-wide restrictions, then the binder will enforce it on
-- all units in the partition, including the unit with the WITH. Although
-- it would not be wrong to leave this till bind time, we might as well
-- flag it earlier at compile time.
-- For non-partition-wide restrictions, we have quite a different state
-- of affairs. Here it would be quite wrong to carry a restriction from
-- a with'ed unit to another with'ed unit, or from a package spec to the
-- package body. This means that we have to reset these non-partition
-- wide restrictions at the start of each separate compilation unit. For
-- units in the extended main program, we need to reset them all to the
-- values set by the configuration pragma file(s). For units not in the
-- extended main program, e.g. with'ed units, we might as well reset all
-- of these restrictions to off (False). The actual initial values will
-- be taken from the config files active when those units are compiled
-- as main units.
type Save_Cunit_Boolean_Restrictions is private;
-- Type used for saving and restoring compilation unit restrictions.
function Cunit_Boolean_Restrictions_Save
return Save_Cunit_Boolean_Restrictions;
-- This function saves the compilation unit restriction settings, leaving
-- then unchanged. This is used e.g. at the start of processing a context
-- clause, so that the main unit restrictions can be restored after all
-- the with'ed units have been processed.
procedure Cunit_Boolean_Restrictions_Restore
(R : Save_Cunit_Boolean_Restrictions);
-- This is the corresponding restore procedure to restore restrictions
-- previously saved by Cunit_Boolean_Restrictions_Save. However it does
-- not reset No_Elaboration_Code, this stays set if it was set before
-- the call, and also if it is set before the call, then the Config
-- setting is also updated to include this restriction. This is what
-- implements the special handling of No_Elaboration_Code.
procedure Save_Config_Cunit_Boolean_Restrictions;
-- This saves the current compilation unit restrictions in an internal
-- variable, and leaves them unchanged. This is called immediately after
-- processing the configuration file pragmas, to record the restrictions
-- set by these configuration file pragmas.
procedure Restore_Config_Cunit_Boolean_Restrictions;
-- This restores the value saved by the previous call to save config values
-- saved by Save_Config_Cunit_Boolean_Restrictions. It is called at the
-- start of processing a new unit that is part of the main sources (e.g.
-- a package spec when the main unit is a package body).
procedure Reset_Cunit_Boolean_Restrictions;
-- Turns off all non-partition-wide boolean restrictions
procedure Add_To_Config_Boolean_Restrictions (R : Restriction_Id);
-- Add specified restriction to stored configuration boolean restrictions.
-- This is used for handling the special case of No_Elaboration_Code.
private
type Save_Cunit_Boolean_Restrictions is
array (Cunit_Boolean_Restrictions) of Boolean;
-- Type used for saving and restoring compilation unit restrictions.
-- See Compilation_Unit_Restrictions_[Save|Restore] subprograms.
end Restrict;
gprbuild-gpl-2014-src/gnat/prj-env.adb 0000644 0000767 0000145 00000224431 12323721731 017123 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . E N V --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2013, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Fmap;
with Hostparm;
with Makeutl; use Makeutl;
with Opt;
with Osint; use Osint;
with Output; use Output;
with Prj.Com; use Prj.Com;
with Sdefault;
with Tempdir;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
package body Prj.Env is
Buffer_Initial : constant := 1_000;
-- Initial arbitrary size of buffers
Uninitialized_Prefix : constant String := '#' & Path_Separator;
-- Prefix to indicate that the project path has not been initialized yet.
-- Must be two characters long
No_Project_Default_Dir : constant String := "-";
-- Indicator in the project path to indicate that the default search
-- directories should not be added to the path
-----------------------
-- Local Subprograms --
-----------------------
package Source_Path_Table is new GNAT.Dynamic_Tables
(Table_Component_Type => Name_Id,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 50,
Table_Increment => 100);
-- A table to store the source dirs before creating the source path file
package Object_Path_Table is new GNAT.Dynamic_Tables
(Table_Component_Type => Path_Name_Type,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 50,
Table_Increment => 100);
-- A table to store the object dirs, before creating the object path file
procedure Add_To_Buffer
(S : String;
Buffer : in out String_Access;
Buffer_Last : in out Natural);
-- Add a string to Buffer, extending Buffer if needed
procedure Add_To_Path
(Source_Dirs : String_List_Id;
Shared : Shared_Project_Tree_Data_Access;
Buffer : in out String_Access;
Buffer_Last : in out Natural);
-- Add to Ada_Path_Buffer all the source directories in string list
-- Source_Dirs, if any.
procedure Add_To_Path
(Dir : String;
Buffer : in out String_Access;
Buffer_Last : in out Natural);
-- If Dir is not already in the global variable Ada_Path_Buffer, add it.
-- If Buffer_Last /= 0, prepend a Path_Separator character to Path.
procedure Add_To_Source_Path
(Source_Dirs : String_List_Id;
Shared : Shared_Project_Tree_Data_Access;
Source_Paths : in out Source_Path_Table.Instance);
-- Add to Ada_Path_B all the source directories in string list
-- Source_Dirs, if any. Increment Ada_Path_Length.
procedure Add_To_Object_Path
(Object_Dir : Path_Name_Type;
Object_Paths : in out Object_Path_Table.Instance);
-- Add Object_Dir to object path table. Make sure it is not duplicate
-- and it is the last one in the current table.
----------------------
-- Ada_Include_Path --
----------------------
function Ada_Include_Path
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Recursive : Boolean := False) return String
is
Buffer : String_Access;
Buffer_Last : Natural := 0;
procedure Add
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Dummy : in out Boolean);
-- Add source dirs of Project to the path
---------
-- Add --
---------
procedure Add
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Dummy : in out Boolean)
is
pragma Unreferenced (Dummy);
begin
Add_To_Path
(Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last);
end Add;
procedure For_All_Projects is
new For_Every_Project_Imported (Boolean, Add);
Dummy : Boolean := False;
-- Start of processing for Ada_Include_Path
begin
if Recursive then
-- If it is the first time we call this function for this project,
-- compute the source path.
if Project.Ada_Include_Path = null then
Buffer := new String (1 .. Buffer_Initial);
For_All_Projects
(Project, In_Tree, Dummy, Include_Aggregated => True);
Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last));
Free (Buffer);
end if;
return Project.Ada_Include_Path.all;
else
Buffer := new String (1 .. Buffer_Initial);
Add_To_Path
(Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last);
declare
Result : constant String := Buffer (1 .. Buffer_Last);
begin
Free (Buffer);
return Result;
end;
end if;
end Ada_Include_Path;
----------------------
-- Ada_Objects_Path --
----------------------
function Ada_Objects_Path
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Including_Libraries : Boolean := True) return String_Access
is
Buffer : String_Access;
Buffer_Last : Natural := 0;
procedure Add
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Dummy : in out Boolean);
-- Add all the object directories of a project to the path
---------
-- Add --
---------
procedure Add
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Dummy : in out Boolean)
is
pragma Unreferenced (Dummy, In_Tree);
Path : constant Path_Name_Type :=
Get_Object_Directory
(Project,
Including_Libraries => Including_Libraries,
Only_If_Ada => False);
begin
if Path /= No_Path then
Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last);
end if;
end Add;
procedure For_All_Projects is
new For_Every_Project_Imported (Boolean, Add);
Dummy : Boolean := False;
Result : String_Access;
-- Start of processing for Ada_Objects_Path
begin
-- If it is the first time we call this function for
-- this project, compute the objects path
if Including_Libraries and then Project.Ada_Objects_Path /= null then
return Project.Ada_Objects_Path;
elsif not Including_Libraries
and then Project.Ada_Objects_Path_No_Libs /= null
then
return Project.Ada_Objects_Path_No_Libs;
else
Buffer := new String (1 .. Buffer_Initial);
For_All_Projects (Project, In_Tree, Dummy);
Result := new String'(Buffer (1 .. Buffer_Last));
Free (Buffer);
if Including_Libraries then
Project.Ada_Objects_Path := Result;
else
Project.Ada_Objects_Path_No_Libs := Result;
end if;
return Result;
end if;
end Ada_Objects_Path;
-------------------
-- Add_To_Buffer --
-------------------
procedure Add_To_Buffer
(S : String;
Buffer : in out String_Access;
Buffer_Last : in out Natural)
is
Last : constant Natural := Buffer_Last + S'Length;
begin
while Last > Buffer'Last loop
declare
New_Buffer : constant String_Access :=
new String (1 .. 2 * Buffer'Last);
begin
New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
Free (Buffer);
Buffer := New_Buffer;
end;
end loop;
Buffer (Buffer_Last + 1 .. Last) := S;
Buffer_Last := Last;
end Add_To_Buffer;
------------------------
-- Add_To_Object_Path --
------------------------
procedure Add_To_Object_Path
(Object_Dir : Path_Name_Type;
Object_Paths : in out Object_Path_Table.Instance)
is
begin
-- Check if the directory is already in the table
for Index in
Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths)
loop
-- If it is, remove it, and add it as the last one
if Object_Paths.Table (Index) = Object_Dir then
for Index2 in
Index + 1 .. Object_Path_Table.Last (Object_Paths)
loop
Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2);
end loop;
Object_Paths.Table
(Object_Path_Table.Last (Object_Paths)) := Object_Dir;
return;
end if;
end loop;
-- The directory is not already in the table, add it
Object_Path_Table.Append (Object_Paths, Object_Dir);
end Add_To_Object_Path;
-----------------
-- Add_To_Path --
-----------------
procedure Add_To_Path
(Source_Dirs : String_List_Id;
Shared : Shared_Project_Tree_Data_Access;
Buffer : in out String_Access;
Buffer_Last : in out Natural)
is
Current : String_List_Id;
Source_Dir : String_Element;
begin
Current := Source_Dirs;
while Current /= Nil_String loop
Source_Dir := Shared.String_Elements.Table (Current);
Add_To_Path (Get_Name_String (Source_Dir.Display_Value),
Buffer, Buffer_Last);
Current := Source_Dir.Next;
end loop;
end Add_To_Path;
procedure Add_To_Path
(Dir : String;
Buffer : in out String_Access;
Buffer_Last : in out Natural)
is
Len : Natural;
New_Buffer : String_Access;
Min_Len : Natural;
function Is_Present (Path : String; Dir : String) return Boolean;
-- Return True if Dir is part of Path
----------------
-- Is_Present --
----------------
function Is_Present (Path : String; Dir : String) return Boolean is
Last : constant Integer := Path'Last - Dir'Length + 1;
begin
for J in Path'First .. Last loop
-- Note: the order of the conditions below is important, since
-- it ensures a minimal number of string comparisons.
if (J = Path'First or else Path (J - 1) = Path_Separator)
and then
(J + Dir'Length > Path'Last
or else Path (J + Dir'Length) = Path_Separator)
and then Dir = Path (J .. J + Dir'Length - 1)
then
return True;
end if;
end loop;
return False;
end Is_Present;
-- Start of processing for Add_To_Path
begin
if Is_Present (Buffer (1 .. Buffer_Last), Dir) then
-- Dir is already in the path, nothing to do
return;
end if;
Min_Len := Buffer_Last + Dir'Length;
if Buffer_Last > 0 then
-- Add 1 for the Path_Separator character
Min_Len := Min_Len + 1;
end if;
-- If Ada_Path_Buffer is too small, increase it
Len := Buffer'Last;
if Len < Min_Len then
loop
Len := Len * 2;
exit when Len >= Min_Len;
end loop;
New_Buffer := new String (1 .. Len);
New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
Free (Buffer);
Buffer := New_Buffer;
end if;
if Buffer_Last > 0 then
Buffer_Last := Buffer_Last + 1;
Buffer (Buffer_Last) := Path_Separator;
end if;
Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir;
Buffer_Last := Buffer_Last + Dir'Length;
end Add_To_Path;
------------------------
-- Add_To_Source_Path --
------------------------
procedure Add_To_Source_Path
(Source_Dirs : String_List_Id;
Shared : Shared_Project_Tree_Data_Access;
Source_Paths : in out Source_Path_Table.Instance)
is
Current : String_List_Id;
Source_Dir : String_Element;
Add_It : Boolean;
begin
-- Add each source directory
Current := Source_Dirs;
while Current /= Nil_String loop
Source_Dir := Shared.String_Elements.Table (Current);
Add_It := True;
-- Check if the source directory is already in the table
for Index in
Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths)
loop
-- If it is already, no need to add it
if Source_Paths.Table (Index) = Source_Dir.Value then
Add_It := False;
exit;
end if;
end loop;
if Add_It then
Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value);
end if;
-- Next source directory
Current := Source_Dir.Next;
end loop;
end Add_To_Source_Path;
--------------------------------
-- Create_Config_Pragmas_File --
--------------------------------
procedure Create_Config_Pragmas_File
(For_Project : Project_Id;
In_Tree : Project_Tree_Ref)
is
type Naming_Id is new Nat;
package Naming_Table is new GNAT.Dynamic_Tables
(Table_Component_Type => Lang_Naming_Data,
Table_Index_Type => Naming_Id,
Table_Low_Bound => 1,
Table_Initial => 5,
Table_Increment => 100);
Default_Naming : constant Naming_Id := Naming_Table.First;
Namings : Naming_Table.Instance;
-- Table storing the naming data for gnatmake/gprmake
Buffer : String_Access := new String (1 .. Buffer_Initial);
Buffer_Last : Natural := 0;
File_Name : Path_Name_Type := No_Path;
File : File_Descriptor := Invalid_FD;
Current_Naming : Naming_Id;
procedure Check
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
State : in out Integer);
-- Recursive procedure that put in the config pragmas file any non
-- standard naming schemes, if it is not already in the file, then call
-- itself for any imported project.
procedure Put (Source : Source_Id);
-- Put an SFN pragma in the temporary file
procedure Put (S : String);
procedure Put_Line (S : String);
-- Output procedures, analogous to normal Text_IO procs of same name.
-- The text is put in Buffer, then it will be written into a temporary
-- file with procedure Write_Temp_File below.
procedure Write_Temp_File;
-- Create a temporary file and put the content of the buffer in it
-----------
-- Check --
-----------
procedure Check
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
State : in out Integer)
is
pragma Unreferenced (State);
Lang : constant Language_Ptr :=
Get_Language_From_Name (Project, "ada");
Naming : Lang_Naming_Data;
Iter : Source_Iterator;
Source : Source_Id;
begin
if Current_Verbosity = High then
Debug_Output ("Checking project file:", Project.Name);
end if;
if Lang = null then
if Current_Verbosity = High then
Debug_Output ("Languages does not contain Ada, nothing to do");
end if;
return;
end if;
-- Visit all the files and process those that need an SFN pragma
Iter := For_Each_Source (In_Tree, Project);
while Element (Iter) /= No_Source loop
Source := Element (Iter);
if not Source.Locally_Removed
and then Source.Unit /= null
and then
(Source.Index >= 1 or else Source.Naming_Exception /= No)
then
Put (Source);
end if;
Next (Iter);
end loop;
Naming := Lang.Config.Naming_Data;
-- Is the naming scheme of this project one that we know?
Current_Naming := Default_Naming;
while Current_Naming <= Naming_Table.Last (Namings)
and then Namings.Table (Current_Naming).Dot_Replacement =
Naming.Dot_Replacement
and then Namings.Table (Current_Naming).Casing =
Naming.Casing
and then Namings.Table (Current_Naming).Separate_Suffix =
Naming.Separate_Suffix
loop
Current_Naming := Current_Naming + 1;
end loop;
-- If we don't know it, add it
if Current_Naming > Naming_Table.Last (Namings) then
Naming_Table.Increment_Last (Namings);
Namings.Table (Naming_Table.Last (Namings)) := Naming;
-- Put the SFN pragmas for the naming scheme
-- Spec
Put_Line
("pragma Source_File_Name_Project");
Put_Line
(" (Spec_File_Name => ""*" &
Get_Name_String (Naming.Spec_Suffix) & """,");
Put_Line
(" Casing => " &
Image (Naming.Casing) & ",");
Put_Line
(" Dot_Replacement => """ &
Get_Name_String (Naming.Dot_Replacement) & """);");
-- and body
Put_Line
("pragma Source_File_Name_Project");
Put_Line
(" (Body_File_Name => ""*" &
Get_Name_String (Naming.Body_Suffix) & """,");
Put_Line
(" Casing => " &
Image (Naming.Casing) & ",");
Put_Line
(" Dot_Replacement => """ &
Get_Name_String (Naming.Dot_Replacement) &
""");");
-- and maybe separate
if Naming.Body_Suffix /= Naming.Separate_Suffix then
Put_Line ("pragma Source_File_Name_Project");
Put_Line
(" (Subunit_File_Name => ""*" &
Get_Name_String (Naming.Separate_Suffix) & """,");
Put_Line
(" Casing => " &
Image (Naming.Casing) & ",");
Put_Line
(" Dot_Replacement => """ &
Get_Name_String (Naming.Dot_Replacement) &
""");");
end if;
end if;
end Check;
---------
-- Put --
---------
procedure Put (Source : Source_Id) is
begin
-- Put the pragma SFN for the unit kind (spec or body)
Put ("pragma Source_File_Name_Project (");
Put (Namet.Get_Name_String (Source.Unit.Name));
if Source.Kind = Spec then
Put (", Spec_File_Name => """);
else
Put (", Body_File_Name => """);
end if;
Put (Namet.Get_Name_String (Source.File));
Put ("""");
if Source.Index /= 0 then
Put (", Index =>");
Put (Source.Index'Img);
end if;
Put_Line (");");
end Put;
procedure Put (S : String) is
begin
Add_To_Buffer (S, Buffer, Buffer_Last);
if Current_Verbosity = High then
Write_Str (S);
end if;
end Put;
--------------
-- Put_Line --
--------------
procedure Put_Line (S : String) is
begin
-- Add an ASCII.LF to the string. As this config file is supposed to
-- be used only by the compiler, we don't care about the characters
-- for the end of line. In fact we could have put a space, but
-- it is more convenient to be able to read gnat.adc during
-- development, for which the ASCII.LF is fine.
Put (S);
Put (S => (1 => ASCII.LF));
end Put_Line;
---------------------
-- Write_Temp_File --
---------------------
procedure Write_Temp_File is
Status : Boolean := False;
Last : Natural;
begin
Tempdir.Create_Temp_File (File, File_Name);
if File /= Invalid_FD then
Last := Write (File, Buffer (1)'Address, Buffer_Last);
if Last = Buffer_Last then
Close (File, Status);
end if;
end if;
if not Status then
Prj.Com.Fail ("unable to create temporary file");
end if;
end Write_Temp_File;
procedure Check_Imported_Projects is
new For_Every_Project_Imported (Integer, Check);
Dummy : Integer := 0;
-- Start of processing for Create_Config_Pragmas_File
begin
if not For_Project.Config_Checked then
Naming_Table.Init (Namings);
-- Check the naming schemes
Check_Imported_Projects
(For_Project, In_Tree, Dummy, Imported_First => False);
-- If there are no non standard naming scheme, issue the GNAT
-- standard naming scheme. This will tell the compiler that
-- a project file is used and will forbid any pragma SFN.
if Buffer_Last = 0 then
Put_Line ("pragma Source_File_Name_Project");
Put_Line (" (Spec_File_Name => ""*.ads"",");
Put_Line (" Dot_Replacement => ""-"",");
Put_Line (" Casing => lowercase);");
Put_Line ("pragma Source_File_Name_Project");
Put_Line (" (Body_File_Name => ""*.adb"",");
Put_Line (" Dot_Replacement => ""-"",");
Put_Line (" Casing => lowercase);");
end if;
-- Close the temporary file
Write_Temp_File;
if Opt.Verbose_Mode then
Write_Str ("Created configuration file """);
Write_Str (Get_Name_String (File_Name));
Write_Line ("""");
end if;
For_Project.Config_File_Name := File_Name;
For_Project.Config_File_Temp := True;
For_Project.Config_Checked := True;
end if;
Free (Buffer);
end Create_Config_Pragmas_File;
--------------------
-- Create_Mapping --
--------------------
procedure Create_Mapping (In_Tree : Project_Tree_Ref) is
Data : Source_Id;
Iter : Source_Iterator;
begin
Fmap.Reset_Tables;
Iter := For_Each_Source (In_Tree);
loop
Data := Element (Iter);
exit when Data = No_Source;
if Data.Unit /= No_Unit_Index then
if Data.Locally_Removed and then not Data.Suppressed then
Fmap.Add_Forbidden_File_Name (Data.File);
else
Fmap.Add_To_File_Map
(Unit_Name => Unit_Name_Type (Data.Unit.Name),
File_Name => Data.File,
Path_Name => File_Name_Type (Data.Path.Display_Name));
end if;
end if;
Next (Iter);
end loop;
end Create_Mapping;
-------------------------
-- Create_Mapping_File --
-------------------------
procedure Create_Mapping_File
(Project : Project_Id;
Language : Name_Id;
In_Tree : Project_Tree_Ref;
Name : out Path_Name_Type)
is
File : File_Descriptor := Invalid_FD;
Buffer : String_Access := new String (1 .. Buffer_Initial);
Buffer_Last : Natural := 0;
procedure Put_Name_Buffer;
-- Put the line contained in the Name_Buffer in the global buffer
procedure Process
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
State : in out Integer);
-- Generate the mapping file for Project (not recursively)
---------------------
-- Put_Name_Buffer --
---------------------
procedure Put_Name_Buffer is
begin
if Current_Verbosity = High then
Debug_Output (Name_Buffer (1 .. Name_Len));
end if;
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.LF;
Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
end Put_Name_Buffer;
-------------
-- Process --
-------------
procedure Process
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
State : in out Integer)
is
pragma Unreferenced (State);
Source : Source_Id;
Suffix : File_Name_Type;
Iter : Source_Iterator;
begin
Debug_Output ("Add mapping for project", Project.Name);
Iter := For_Each_Source (In_Tree, Project, Language => Language);
loop
Source := Prj.Element (Iter);
exit when Source = No_Source;
if not Source.Suppressed
and then Source.Replaced_By = No_Source
and then Source.Path.Name /= No_Path
and then (Source.Language.Config.Kind = File_Based
or else Source.Unit /= No_Unit_Index)
then
if Source.Unit /= No_Unit_Index then
-- Put the encoded unit name in the name buffer
declare
Uname : constant String :=
Get_Name_String (Source.Unit.Name);
begin
Name_Len := 0;
for J in Uname'Range loop
if Uname (J) in Upper_Half_Character then
Store_Encoded_Character (Get_Char_Code (Uname (J)));
else
Add_Char_To_Name_Buffer (Uname (J));
end if;
end loop;
end;
if Source.Language.Config.Kind = Unit_Based then
-- ??? Mapping_Spec_Suffix could be set in the case of
-- gnatmake as well
Add_Char_To_Name_Buffer ('%');
if Source.Kind = Spec then
Add_Char_To_Name_Buffer ('s');
else
Add_Char_To_Name_Buffer ('b');
end if;
else
case Source.Kind is
when Spec =>
Suffix :=
Source.Language.Config.Mapping_Spec_Suffix;
when Impl | Sep =>
Suffix :=
Source.Language.Config.Mapping_Body_Suffix;
end case;
if Suffix /= No_File then
Add_Str_To_Name_Buffer (Get_Name_String (Suffix));
end if;
end if;
Put_Name_Buffer;
end if;
Get_Name_String (Source.Display_File);
Put_Name_Buffer;
if Source.Locally_Removed then
Name_Len := 1;
Name_Buffer (1) := '/';
else
Get_Name_String (Source.Path.Display_Name);
end if;
Put_Name_Buffer;
end if;
Next (Iter);
end loop;
end Process;
procedure For_Every_Imported_Project is new
For_Every_Project_Imported (State => Integer, Action => Process);
-- Local variables
Dummy : Integer := 0;
-- Start of processing for Create_Mapping_File
begin
if Current_Verbosity = High then
Debug_Output ("Create mapping file for", Debug_Name (In_Tree));
end if;
Create_Temp_File (In_Tree.Shared, File, Name, "mapping");
if Current_Verbosity = High then
Debug_Increase_Indent ("Create mapping file ", Name_Id (Name));
end if;
For_Every_Imported_Project
(Project, In_Tree, Dummy, Include_Aggregated => False);
declare
Last : Natural;
Status : Boolean := False;
begin
if File /= Invalid_FD then
Last := Write (File, Buffer (1)'Address, Buffer_Last);
if Last = Buffer_Last then
GNAT.OS_Lib.Close (File, Status);
end if;
end if;
if not Status then
Prj.Com.Fail ("could not write mapping file");
end if;
end;
Free (Buffer);
Debug_Decrease_Indent ("Done create mapping file");
end Create_Mapping_File;
----------------------
-- Create_Temp_File --
----------------------
procedure Create_Temp_File
(Shared : Shared_Project_Tree_Data_Access;
Path_FD : out File_Descriptor;
Path_Name : out Path_Name_Type;
File_Use : String)
is
begin
Tempdir.Create_Temp_File (Path_FD, Path_Name);
if Path_Name /= No_Path then
if Current_Verbosity = High then
Write_Line ("Create temp file (" & File_Use & ") "
& Get_Name_String (Path_Name));
end if;
Record_Temp_File (Shared, Path_Name);
else
Prj.Com.Fail
("unable to create temporary " & File_Use & " file");
end if;
end Create_Temp_File;
--------------------------
-- Create_New_Path_File --
--------------------------
procedure Create_New_Path_File
(Shared : Shared_Project_Tree_Data_Access;
Path_FD : out File_Descriptor;
Path_Name : out Path_Name_Type)
is
begin
Create_Temp_File (Shared, Path_FD, Path_Name, "path file");
end Create_New_Path_File;
------------------------------------
-- File_Name_Of_Library_Unit_Body --
------------------------------------
function File_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id;
In_Tree : Project_Tree_Ref;
Main_Project_Only : Boolean := True;
Full_Path : Boolean := False) return String
is
Lang : constant Language_Ptr :=
Get_Language_From_Name (Project, "ada");
The_Project : Project_Id := Project;
Original_Name : String := Name;
Unit : Unit_Index;
The_Original_Name : Name_Id;
The_Spec_Name : Name_Id;
The_Body_Name : Name_Id;
begin
-- ??? Same block in Project_Of
Canonical_Case_File_Name (Original_Name);
Name_Len := Original_Name'Length;
Name_Buffer (1 .. Name_Len) := Original_Name;
The_Original_Name := Name_Find;
if Lang /= null then
declare
Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data;
Extended_Spec_Name : String :=
Name & Namet.Get_Name_String
(Naming.Spec_Suffix);
Extended_Body_Name : String :=
Name & Namet.Get_Name_String
(Naming.Body_Suffix);
begin
Canonical_Case_File_Name (Extended_Spec_Name);
Name_Len := Extended_Spec_Name'Length;
Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
The_Spec_Name := Name_Find;
Canonical_Case_File_Name (Extended_Body_Name);
Name_Len := Extended_Body_Name'Length;
Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
The_Body_Name := Name_Find;
end;
else
Name_Len := Name'Length;
Name_Buffer (1 .. Name_Len) := Name;
Canonical_Case_File_Name (Name_Buffer);
The_Spec_Name := Name_Find;
The_Body_Name := The_Spec_Name;
end if;
if Current_Verbosity = High then
Write_Str ("Looking for file name of """);
Write_Str (Name);
Write_Char ('"');
Write_Eol;
Write_Str (" Extended Spec Name = """);
Write_Str (Get_Name_String (The_Spec_Name));
Write_Char ('"');
Write_Eol;
Write_Str (" Extended Body Name = """);
Write_Str (Get_Name_String (The_Body_Name));
Write_Char ('"');
Write_Eol;
end if;
-- For extending project, search in the extended project if the source
-- is not found. For non extending projects, this loop will be run only
-- once.
loop
-- Loop through units
Unit := Units_Htable.Get_First (In_Tree.Units_HT);
while Unit /= null loop
-- Check for body
if not Main_Project_Only
or else
(Unit.File_Names (Impl) /= null
and then Unit.File_Names (Impl).Project = The_Project)
then
declare
Current_Name : File_Name_Type;
begin
-- Case of a body present
if Unit.File_Names (Impl) /= null then
Current_Name := Unit.File_Names (Impl).File;
if Current_Verbosity = High then
Write_Str (" Comparing with """);
Write_Str (Get_Name_String (Current_Name));
Write_Char ('"');
Write_Eol;
end if;
-- If it has the name of the original name, return the
-- original name.
if Unit.Name = The_Original_Name
or else
Current_Name = File_Name_Type (The_Original_Name)
then
if Current_Verbosity = High then
Write_Line (" OK");
end if;
if Full_Path then
return Get_Name_String
(Unit.File_Names (Impl).Path.Name);
else
return Get_Name_String (Current_Name);
end if;
-- If it has the name of the extended body name,
-- return the extended body name
elsif Current_Name = File_Name_Type (The_Body_Name) then
if Current_Verbosity = High then
Write_Line (" OK");
end if;
if Full_Path then
return Get_Name_String
(Unit.File_Names (Impl).Path.Name);
else
return Get_Name_String (The_Body_Name);
end if;
else
if Current_Verbosity = High then
Write_Line (" not good");
end if;
end if;
end if;
end;
end if;
-- Check for spec
if not Main_Project_Only
or else (Unit.File_Names (Spec) /= null
and then Unit.File_Names (Spec).Project = The_Project)
then
declare
Current_Name : File_Name_Type;
begin
-- Case of spec present
if Unit.File_Names (Spec) /= null then
Current_Name := Unit.File_Names (Spec).File;
if Current_Verbosity = High then
Write_Str (" Comparing with """);
Write_Str (Get_Name_String (Current_Name));
Write_Char ('"');
Write_Eol;
end if;
-- If name same as original name, return original name
if Unit.Name = The_Original_Name
or else
Current_Name = File_Name_Type (The_Original_Name)
then
if Current_Verbosity = High then
Write_Line (" OK");
end if;
if Full_Path then
return Get_Name_String
(Unit.File_Names (Spec).Path.Name);
else
return Get_Name_String (Current_Name);
end if;
-- If it has the same name as the extended spec name,
-- return the extended spec name.
elsif Current_Name = File_Name_Type (The_Spec_Name) then
if Current_Verbosity = High then
Write_Line (" OK");
end if;
if Full_Path then
return Get_Name_String
(Unit.File_Names (Spec).Path.Name);
else
return Get_Name_String (The_Spec_Name);
end if;
else
if Current_Verbosity = High then
Write_Line (" not good");
end if;
end if;
end if;
end;
end if;
Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
end loop;
-- If we are not in an extending project, give up
exit when not Main_Project_Only
or else The_Project.Extends = No_Project;
-- Otherwise, look in the project we are extending
The_Project := The_Project.Extends;
end loop;
-- We don't know this file name, return an empty string
return "";
end File_Name_Of_Library_Unit_Body;
-------------------------
-- For_All_Object_Dirs --
-------------------------
procedure For_All_Object_Dirs
(Project : Project_Id;
Tree : Project_Tree_Ref)
is
procedure For_Project
(Prj : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Integer);
-- Get all object directories of Prj
-----------------
-- For_Project --
-----------------
procedure For_Project
(Prj : Project_Id;
Tree : Project_Tree_Ref;
Dummy : in out Integer)
is
pragma Unreferenced (Dummy, Tree);
begin
-- ??? Set_Ada_Paths has a different behavior for library project
-- files, should we have the same ?
if Prj.Object_Directory /= No_Path_Information then
Get_Name_String (Prj.Object_Directory.Display_Name);
Action (Name_Buffer (1 .. Name_Len));
end if;
end For_Project;
procedure Get_Object_Dirs is
new For_Every_Project_Imported (Integer, For_Project);
Dummy : Integer := 1;
-- Start of processing for For_All_Object_Dirs
begin
Get_Object_Dirs (Project, Tree, Dummy);
end For_All_Object_Dirs;
-------------------------
-- For_All_Source_Dirs --
-------------------------
procedure For_All_Source_Dirs
(Project : Project_Id;
In_Tree : Project_Tree_Ref)
is
procedure For_Project
(Prj : Project_Id;
In_Tree : Project_Tree_Ref;
Dummy : in out Integer);
-- Get all object directories of Prj
-----------------
-- For_Project --
-----------------
procedure For_Project
(Prj : Project_Id;
In_Tree : Project_Tree_Ref;
Dummy : in out Integer)
is
pragma Unreferenced (Dummy);
Current : String_List_Id := Prj.Source_Dirs;
The_String : String_Element;
begin
-- If there are Ada sources, call action with the name of every
-- source directory.
if Has_Ada_Sources (Prj) then
while Current /= Nil_String loop
The_String := In_Tree.Shared.String_Elements.Table (Current);
Action (Get_Name_String (The_String.Display_Value));
Current := The_String.Next;
end loop;
end if;
end For_Project;
procedure Get_Source_Dirs is
new For_Every_Project_Imported (Integer, For_Project);
Dummy : Integer := 1;
-- Start of processing for For_All_Source_Dirs
begin
Get_Source_Dirs (Project, In_Tree, Dummy);
end For_All_Source_Dirs;
-------------------
-- Get_Reference --
-------------------
procedure Get_Reference
(Source_File_Name : String;
In_Tree : Project_Tree_Ref;
Project : out Project_Id;
Path : out Path_Name_Type)
is
begin
-- Body below could use some comments ???
if Current_Verbosity > Default then
Write_Str ("Getting Reference_Of (""");
Write_Str (Source_File_Name);
Write_Str (""") ... ");
end if;
declare
Original_Name : String := Source_File_Name;
Unit : Unit_Index;
begin
Canonical_Case_File_Name (Original_Name);
Unit := Units_Htable.Get_First (In_Tree.Units_HT);
while Unit /= null loop
if Unit.File_Names (Spec) /= null
and then not Unit.File_Names (Spec).Locally_Removed
and then Unit.File_Names (Spec).File /= No_File
and then
(Namet.Get_Name_String
(Unit.File_Names (Spec).File) = Original_Name
or else (Unit.File_Names (Spec).Path /= No_Path_Information
and then
Namet.Get_Name_String
(Unit.File_Names (Spec).Path.Name) =
Original_Name))
then
Project :=
Ultimate_Extending_Project_Of
(Unit.File_Names (Spec).Project);
Path := Unit.File_Names (Spec).Path.Display_Name;
if Current_Verbosity > Default then
Write_Str ("Done: Spec.");
Write_Eol;
end if;
return;
elsif Unit.File_Names (Impl) /= null
and then Unit.File_Names (Impl).File /= No_File
and then not Unit.File_Names (Impl).Locally_Removed
and then
(Namet.Get_Name_String
(Unit.File_Names (Impl).File) = Original_Name
or else (Unit.File_Names (Impl).Path /= No_Path_Information
and then Namet.Get_Name_String
(Unit.File_Names (Impl).Path.Name) =
Original_Name))
then
Project :=
Ultimate_Extending_Project_Of
(Unit.File_Names (Impl).Project);
Path := Unit.File_Names (Impl).Path.Display_Name;
if Current_Verbosity > Default then
Write_Str ("Done: Body.");
Write_Eol;
end if;
return;
end if;
Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
end loop;
end;
Project := No_Project;
Path := No_Path;
if Current_Verbosity > Default then
Write_Str ("Cannot be found.");
Write_Eol;
end if;
end Get_Reference;
----------------------
-- Get_Runtime_Path --
----------------------
function Get_Runtime_Path
(Self : Project_Search_Path;
Name : String) return String_Access
is
function Is_Base_Name (Path : String) return Boolean;
-- Returns True if Path has no directory separator
------------------
-- Is_Base_Name --
------------------
function Is_Base_Name (Path : String) return Boolean is
begin
for J in Path'Range loop
if Path (J) = Directory_Separator or else Path (J) = '/' then
return False;
end if;
end loop;
return True;
end Is_Base_Name;
function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path
(Check_Filename => Is_Directory);
-- Start of processing for Get_Runtime_Path
begin
if not Is_Base_Name (Name) then
return Find_Rts_In_Path (Self, Name);
else
return null;
end if;
end Get_Runtime_Path;
----------------
-- Initialize --
----------------
procedure Initialize (In_Tree : Project_Tree_Ref) is
begin
In_Tree.Shared.Private_Part.Current_Source_Path_File := No_Path;
In_Tree.Shared.Private_Part.Current_Object_Path_File := No_Path;
end Initialize;
-------------------
-- Print_Sources --
-------------------
-- Could use some comments in this body ???
procedure Print_Sources (In_Tree : Project_Tree_Ref) is
Unit : Unit_Index;
begin
Write_Line ("List of Sources:");
Unit := Units_Htable.Get_First (In_Tree.Units_HT);
while Unit /= No_Unit_Index loop
Write_Str (" ");
Write_Line (Namet.Get_Name_String (Unit.Name));
if Unit.File_Names (Spec).File /= No_File then
if Unit.File_Names (Spec).Project = No_Project then
Write_Line (" No project");
else
Write_Str (" Project: ");
Get_Name_String
(Unit.File_Names (Spec).Project.Path.Name);
Write_Line (Name_Buffer (1 .. Name_Len));
end if;
Write_Str (" spec: ");
Write_Line
(Namet.Get_Name_String
(Unit.File_Names (Spec).File));
end if;
if Unit.File_Names (Impl).File /= No_File then
if Unit.File_Names (Impl).Project = No_Project then
Write_Line (" No project");
else
Write_Str (" Project: ");
Get_Name_String
(Unit.File_Names (Impl).Project.Path.Name);
Write_Line (Name_Buffer (1 .. Name_Len));
end if;
Write_Str (" body: ");
Write_Line
(Namet.Get_Name_String (Unit.File_Names (Impl).File));
end if;
Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
end loop;
Write_Line ("end of List of Sources.");
end Print_Sources;
----------------
-- Project_Of --
----------------
function Project_Of
(Name : String;
Main_Project : Project_Id;
In_Tree : Project_Tree_Ref) return Project_Id
is
Result : Project_Id := No_Project;
Original_Name : String := Name;
Lang : constant Language_Ptr :=
Get_Language_From_Name (Main_Project, "ada");
Unit : Unit_Index;
Current_Name : File_Name_Type;
The_Original_Name : File_Name_Type;
The_Spec_Name : File_Name_Type;
The_Body_Name : File_Name_Type;
begin
-- ??? Same block in File_Name_Of_Library_Unit_Body
Canonical_Case_File_Name (Original_Name);
Name_Len := Original_Name'Length;
Name_Buffer (1 .. Name_Len) := Original_Name;
The_Original_Name := Name_Find;
if Lang /= null then
declare
Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
Extended_Spec_Name : String :=
Name & Namet.Get_Name_String
(Naming.Spec_Suffix);
Extended_Body_Name : String :=
Name & Namet.Get_Name_String
(Naming.Body_Suffix);
begin
Canonical_Case_File_Name (Extended_Spec_Name);
Name_Len := Extended_Spec_Name'Length;
Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
The_Spec_Name := Name_Find;
Canonical_Case_File_Name (Extended_Body_Name);
Name_Len := Extended_Body_Name'Length;
Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
The_Body_Name := Name_Find;
end;
else
The_Spec_Name := The_Original_Name;
The_Body_Name := The_Original_Name;
end if;
Unit := Units_Htable.Get_First (In_Tree.Units_HT);
while Unit /= null loop
-- Case of a body present
if Unit.File_Names (Impl) /= null then
Current_Name := Unit.File_Names (Impl).File;
-- If it has the name of the original name or the body name,
-- we have found the project.
if Unit.Name = Name_Id (The_Original_Name)
or else Current_Name = The_Original_Name
or else Current_Name = The_Body_Name
then
Result := Unit.File_Names (Impl).Project;
exit;
end if;
end if;
-- Check for spec
if Unit.File_Names (Spec) /= null then
Current_Name := Unit.File_Names (Spec).File;
-- If name same as the original name, or the spec name, we have
-- found the project.
if Unit.Name = Name_Id (The_Original_Name)
or else Current_Name = The_Original_Name
or else Current_Name = The_Spec_Name
then
Result := Unit.File_Names (Spec).Project;
exit;
end if;
end if;
Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
end loop;
return Ultimate_Extending_Project_Of (Result);
end Project_Of;
-------------------
-- Set_Ada_Paths --
-------------------
procedure Set_Ada_Paths
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Including_Libraries : Boolean;
Include_Path : Boolean := True;
Objects_Path : Boolean := True)
is
Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
Source_Paths : Source_Path_Table.Instance;
Object_Paths : Object_Path_Table.Instance;
-- List of source or object dirs. Only computed the first time this
-- procedure is called (since Source_FD is then reused)
Source_FD : File_Descriptor := Invalid_FD;
Object_FD : File_Descriptor := Invalid_FD;
-- The temporary files to store the paths. These are only created the
-- first time this procedure is called, and reused from then on.
Process_Source_Dirs : Boolean := False;
Process_Object_Dirs : Boolean := False;
Status : Boolean;
-- For calls to Close
Last : Natural;
Buffer : String_Access := new String (1 .. Buffer_Initial);
Buffer_Last : Natural := 0;
procedure Recursive_Add
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Dummy : in out Boolean);
-- Recursive procedure to add the source/object paths of extended/
-- imported projects.
-------------------
-- Recursive_Add --
-------------------
procedure Recursive_Add
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Dummy : in out Boolean)
is
pragma Unreferenced (Dummy, In_Tree);
Path : Path_Name_Type;
begin
if Process_Source_Dirs then
-- Add to path all source directories of this project if there are
-- Ada sources.
if Has_Ada_Sources (Project) then
Add_To_Source_Path (Project.Source_Dirs, Shared, Source_Paths);
end if;
end if;
if Process_Object_Dirs then
Path := Get_Object_Directory
(Project,
Including_Libraries => Including_Libraries,
Only_If_Ada => True);
if Path /= No_Path then
Add_To_Object_Path (Path, Object_Paths);
end if;
end if;
end Recursive_Add;
procedure For_All_Projects is
new For_Every_Project_Imported (Boolean, Recursive_Add);
Dummy : Boolean := False;
-- Start of processing for Set_Ada_Paths
begin
-- If it is the first time we call this procedure for this project,
-- compute the source path and/or the object path.
if Include_Path and then Project.Include_Path_File = No_Path then
Source_Path_Table.Init (Source_Paths);
Process_Source_Dirs := True;
Create_New_Path_File (Shared, Source_FD, Project.Include_Path_File);
end if;
-- For the object path, we make a distinction depending on
-- Including_Libraries.
if Objects_Path and Including_Libraries then
if Project.Objects_Path_File_With_Libs = No_Path then
Object_Path_Table.Init (Object_Paths);
Process_Object_Dirs := True;
Create_New_Path_File
(Shared, Object_FD, Project.Objects_Path_File_With_Libs);
end if;
elsif Objects_Path then
if Project.Objects_Path_File_Without_Libs = No_Path then
Object_Path_Table.Init (Object_Paths);
Process_Object_Dirs := True;
Create_New_Path_File
(Shared, Object_FD, Project.Objects_Path_File_Without_Libs);
end if;
end if;
-- If there is something to do, set Seen to False for all projects,
-- then call the recursive procedure Add for Project.
if Process_Source_Dirs or Process_Object_Dirs then
For_All_Projects (Project, In_Tree, Dummy);
end if;
-- Write and close any file that has been created. Source_FD is not set
-- when this subprogram is called a second time or more, since we reuse
-- the previous version of the file.
if Source_FD /= Invalid_FD then
Buffer_Last := 0;
for Index in
Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths)
loop
Get_Name_String (Source_Paths.Table (Index));
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.LF;
Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
end loop;
Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last);
if Last = Buffer_Last then
Close (Source_FD, Status);
else
Status := False;
end if;
if not Status then
Prj.Com.Fail ("could not write temporary file");
end if;
end if;
if Object_FD /= Invalid_FD then
Buffer_Last := 0;
for Index in
Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths)
loop
Get_Name_String (Object_Paths.Table (Index));
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.LF;
Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
end loop;
Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last);
if Last = Buffer_Last then
Close (Object_FD, Status);
else
Status := False;
end if;
if not Status then
Prj.Com.Fail ("could not write temporary file");
end if;
end if;
-- Set the env vars, if they need to be changed, and set the
-- corresponding flags.
if Include_Path
and then
Shared.Private_Part.Current_Source_Path_File /=
Project.Include_Path_File
then
Shared.Private_Part.Current_Source_Path_File :=
Project.Include_Path_File;
Set_Path_File_Var
(Project_Include_Path_File,
Get_Name_String (Shared.Private_Part.Current_Source_Path_File));
end if;
if Objects_Path then
if Including_Libraries then
if Shared.Private_Part.Current_Object_Path_File /=
Project.Objects_Path_File_With_Libs
then
Shared.Private_Part.Current_Object_Path_File :=
Project.Objects_Path_File_With_Libs;
Set_Path_File_Var
(Project_Objects_Path_File,
Get_Name_String
(Shared.Private_Part.Current_Object_Path_File));
end if;
else
if Shared.Private_Part.Current_Object_Path_File /=
Project.Objects_Path_File_Without_Libs
then
Shared.Private_Part.Current_Object_Path_File :=
Project.Objects_Path_File_Without_Libs;
Set_Path_File_Var
(Project_Objects_Path_File,
Get_Name_String
(Shared.Private_Part.Current_Object_Path_File));
end if;
end if;
end if;
Free (Buffer);
end Set_Ada_Paths;
---------------------
-- Add_Directories --
---------------------
procedure Add_Directories
(Self : in out Project_Search_Path;
Path : String;
Prepend : Boolean := False)
is
Tmp : String_Access;
begin
if Self.Path = null then
Self.Path := new String'(Uninitialized_Prefix & Path);
else
Tmp := Self.Path;
if Prepend then
Self.Path := new String'(Path & Path_Separator & Tmp.all);
else
Self.Path := new String'(Tmp.all & Path_Separator & Path);
end if;
Free (Tmp);
end if;
if Current_Verbosity = High then
Debug_Output ("Adding directories to Project_Path: """
& Path & '"');
end if;
end Add_Directories;
--------------------
-- Is_Initialized --
--------------------
function Is_Initialized (Self : Project_Search_Path) return Boolean is
begin
return Self.Path /= null
and then (Self.Path'Length = 0
or else Self.Path (Self.Path'First) /= '#');
end Is_Initialized;
----------------------
-- Initialize_Empty --
----------------------
procedure Initialize_Empty (Self : in out Project_Search_Path) is
begin
Free (Self.Path);
Self.Path := new String'("");
end Initialize_Empty;
-------------------------------------
-- Initialize_Default_Project_Path --
-------------------------------------
procedure Initialize_Default_Project_Path
(Self : in out Project_Search_Path;
Target_Name : String)
is
Add_Default_Dir : Boolean := True;
First : Positive;
Last : Positive;
New_Len : Positive;
New_Last : Positive;
Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
Gpr_Project_Path_File : constant String := "GPR_PROJECT_PATH_FILE";
-- Names of alternate env. variable that contain path name(s) of
-- directories where project files may reside. They are taken into
-- account in this order: GPR_PROJECT_PATH_FILE, GPR_PROJECT_PATH,
-- ADA_PROJECT_PATH.
Gpr_Prj_Path_File : String_Access;
Gpr_Prj_Path : String_Access;
Ada_Prj_Path : String_Access;
-- The path name(s) of directories where project files may reside.
-- May be empty.
begin
if Is_Initialized (Self) then
return;
end if;
-- The current directory is always first in the search path. Since the
-- Project_Path currently starts with '#:' as a sign that it isn't
-- initialized, we simply replace '#' with '.'
if Self.Path = null then
Self.Path := new String'('.' & Path_Separator);
else
Self.Path (Self.Path'First) := '.';
end if;
-- Then the reset of the project path (if any) currently contains the
-- directories added through Add_Search_Project_Directory
-- If environment variables are defined and not empty, add their content
Gpr_Prj_Path_File := Getenv (Gpr_Project_Path_File);
Gpr_Prj_Path := Getenv (Gpr_Project_Path);
Ada_Prj_Path := Getenv (Ada_Project_Path);
if Gpr_Prj_Path_File.all /= "" then
declare
File : Ada.Text_IO.File_Type;
Line : String (1 .. 10_000);
Last : Natural;
Tmp : String_Access;
begin
Open (File, In_File, Gpr_Prj_Path_File.all);
while not End_Of_File (File) loop
Get_Line (File, Line, Last);
if Last /= 0
and then (Last = 1 or else Line (1 .. 2) /= "--")
then
Tmp := Self.Path;
Self.Path :=
new String'
(Tmp.all & Path_Separator & Line (1 .. Last));
Free (Tmp);
end if;
if Current_Verbosity = High then
Debug_Output ("Adding directory to Project_Path: """
& Line (1 .. Last) & '"');
end if;
end loop;
Close (File);
exception
when others =>
Write_Str ("warning: could not read project path file """);
Write_Str (Gpr_Prj_Path_File.all);
Write_Line ("""");
end;
end if;
if Gpr_Prj_Path.all /= "" then
Add_Directories (Self, Gpr_Prj_Path.all);
end if;
Free (Gpr_Prj_Path);
if Ada_Prj_Path.all /= "" then
Add_Directories (Self, Ada_Prj_Path.all);
end if;
Free (Ada_Prj_Path);
-- Copy to Name_Buffer, since we will need to manipulate the path
Name_Len := Self.Path'Length;
Name_Buffer (1 .. Name_Len) := Self.Path.all;
-- Scan the directory path to see if "-" is one of the directories.
-- Remove each occurrence of "-" and set Add_Default_Dir to False.
-- Also resolve relative paths and symbolic links.
First := 3;
loop
while First <= Name_Len
and then (Name_Buffer (First) = Path_Separator)
loop
First := First + 1;
end loop;
exit when First > Name_Len;
Last := First;
while Last < Name_Len
and then Name_Buffer (Last + 1) /= Path_Separator
loop
Last := Last + 1;
end loop;
-- If the directory is "-", set Add_Default_Dir to False and
-- remove from path.
if Name_Buffer (First .. Last) = No_Project_Default_Dir then
Add_Default_Dir := False;
for J in Last + 1 .. Name_Len loop
Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
Name_Buffer (J);
end loop;
Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
-- After removing the '-', go back one character to get the next
-- directory correctly.
Last := Last - 1;
elsif not Hostparm.OpenVMS
or else not Is_Absolute_Path (Name_Buffer (First .. Last))
then
-- On VMS, only expand relative path names, as absolute paths
-- may correspond to multi-valued VMS logical names.
declare
New_Dir : constant String :=
Normalize_Pathname
(Name_Buffer (First .. Last),
Resolve_Links => Opt.Follow_Links_For_Dirs);
begin
-- If the absolute path was resolved and is different from
-- the original, replace original with the resolved path.
if New_Dir /= Name_Buffer (First .. Last)
and then New_Dir'Length /= 0
then
New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
New_Last := First + New_Dir'Length - 1;
Name_Buffer (New_Last + 1 .. New_Len) :=
Name_Buffer (Last + 1 .. Name_Len);
Name_Buffer (First .. New_Last) := New_Dir;
Name_Len := New_Len;
Last := New_Last;
end if;
end;
end if;
First := Last + 1;
end loop;
Free (Self.Path);
-- Set the initial value of Current_Project_Path
if Add_Default_Dir then
declare
Prefix : String_Ptr;
begin
if Sdefault.Search_Dir_Prefix = null then
-- gprbuild case
Prefix := new String'(Executable_Prefix_Path);
else
Prefix := new String'(Sdefault.Search_Dir_Prefix.all
& ".." & Dir_Separator
& ".." & Dir_Separator
& ".." & Dir_Separator
& ".." & Dir_Separator);
end if;
if Prefix.all /= "" then
if Target_Name /= "" then
-- $prefix/$target/lib/gnat
Add_Str_To_Name_Buffer
(Path_Separator & Prefix.all & Target_Name);
-- Note: Target_Name has a trailing / when it comes from
-- Sdefault.
if Name_Buffer (Name_Len) /= '/' then
Add_Char_To_Name_Buffer (Directory_Separator);
end if;
Add_Str_To_Name_Buffer
("lib" & Directory_Separator & "gnat");
-- $prefix/$target/share/gpr
Add_Str_To_Name_Buffer
(Path_Separator & Prefix.all & Target_Name);
-- Note: Target_Name has a trailing / when it comes from
-- Sdefault.
if Name_Buffer (Name_Len) /= '/' then
Add_Char_To_Name_Buffer (Directory_Separator);
end if;
Add_Str_To_Name_Buffer
("share" & Directory_Separator & "gpr");
end if;
-- $prefix/share/gpr
Add_Str_To_Name_Buffer
(Path_Separator & Prefix.all &
"share" & Directory_Separator & "gpr");
-- $prefix/lib/gnat
Add_Str_To_Name_Buffer
(Path_Separator & Prefix.all &
"lib" & Directory_Separator & "gnat");
end if;
Free (Prefix);
end;
end if;
Self.Path := new String'(Name_Buffer (1 .. Name_Len));
end Initialize_Default_Project_Path;
--------------
-- Get_Path --
--------------
procedure Get_Path (Self : Project_Search_Path; Path : out String_Access) is
begin
pragma Assert (Is_Initialized (Self));
Path := Self.Path;
end Get_Path;
--------------
-- Set_Path --
--------------
procedure Set_Path (Self : in out Project_Search_Path; Path : String) is
begin
Free (Self.Path);
Self.Path := new String'(Path);
Projects_Paths.Reset (Self.Cache);
end Set_Path;
-----------------------
-- Find_Name_In_Path --
-----------------------
function Find_Name_In_Path
(Self : Project_Search_Path;
Path : String) return String_Access
is
First : Natural;
Last : Natural;
begin
if Current_Verbosity = High then
Debug_Output ("Trying " & Path);
end if;
if Is_Absolute_Path (Path) then
if Check_Filename (Path) then
return new String'(Path);
else
return null;
end if;
else
-- Because we don't want to resolve symbolic links, we cannot use
-- Locate_Regular_File. So, we try each possible path successively.
First := Self.Path'First;
while First <= Self.Path'Last loop
while First <= Self.Path'Last
and then Self.Path (First) = Path_Separator
loop
First := First + 1;
end loop;
exit when First > Self.Path'Last;
Last := First;
while Last < Self.Path'Last
and then Self.Path (Last + 1) /= Path_Separator
loop
Last := Last + 1;
end loop;
Name_Len := 0;
if not Is_Absolute_Path (Self.Path (First .. Last)) then
Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call
Add_Char_To_Name_Buffer (Directory_Separator);
end if;
Add_Str_To_Name_Buffer (Self.Path (First .. Last));
Add_Char_To_Name_Buffer (Directory_Separator);
Add_Str_To_Name_Buffer (Path);
if Current_Verbosity = High then
Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len));
end if;
if Check_Filename (Name_Buffer (1 .. Name_Len)) then
return new String'(Name_Buffer (1 .. Name_Len));
end if;
First := Last + 1;
end loop;
end if;
return null;
end Find_Name_In_Path;
------------------
-- Find_Project --
------------------
procedure Find_Project
(Self : in out Project_Search_Path;
Project_File_Name : String;
Directory : String;
Path : out Namet.Path_Name_Type)
is
Result : String_Access;
Has_Dot : Boolean := False;
Key : Name_Id;
File : constant String := Project_File_Name;
-- Have to do a copy, in case the parameter is Name_Buffer, which we
-- modify below.
Cached_Path : Namet.Path_Name_Type;
-- This should be commented rather than making us guess from the name???
function Try_Path_Name is new
Find_Name_In_Path (Check_Filename => Is_Regular_File);
-- Find a file in the project search path
-- Start of processing for Find_Project
begin
pragma Assert (Is_Initialized (Self));
if Current_Verbosity = High then
Debug_Increase_Indent
("Searching for project """ & File & """ in """
& Directory & '"');
end if;
-- Check the project cache
Name_Len := File'Length;
Name_Buffer (1 .. Name_Len) := File;
Key := Name_Find;
Cached_Path := Projects_Paths.Get (Self.Cache, Key);
-- Check if File contains an extension (a dot before a
-- directory separator). If it is the case we do not try project file
-- with an added extension as it is not possible to have multiple dots
-- on a project file name.
Check_Dot : for K in reverse File'Range loop
if File (K) = '.' then
Has_Dot := True;
exit Check_Dot;
end if;
exit Check_Dot when File (K) = Directory_Separator
or else File (K) = '/';
end loop Check_Dot;
if not Is_Absolute_Path (File) then
-- If we have found project in the cache, check if in the directory
if Cached_Path /= No_Path then
declare
Cached : constant String := Get_Name_String (Cached_Path);
begin
if (not Has_Dot
and then Cached =
GNAT.OS_Lib.Normalize_Pathname
(File & Project_File_Extension,
Directory => Directory,
Resolve_Links => Opt.Follow_Links_For_Files,
Case_Sensitive => True))
or else
Cached =
GNAT.OS_Lib.Normalize_Pathname
(File,
Directory => Directory,
Resolve_Links => Opt.Follow_Links_For_Files,
Case_Sensitive => True)
then
Path := Cached_Path;
Debug_Decrease_Indent;
return;
end if;
end;
end if;
-- First we try /.
if not Has_Dot then
Result :=
Try_Path_Name
(Self,
Directory & Directory_Separator
& File & Project_File_Extension);
end if;
-- Then we try /
if Result = null then
Result :=
Try_Path_Name (Self, Directory & Directory_Separator & File);
end if;
end if;
-- If we found the path in the cache, this is the one
if Result = null and then Cached_Path /= No_Path then
Path := Cached_Path;
Debug_Decrease_Indent;
return;
end if;
-- Then we try .
if Result = null and then not Has_Dot then
Result := Try_Path_Name (Self, File & Project_File_Extension);
end if;
-- Then we try
if Result = null then
Result := Try_Path_Name (Self, File);
end if;
-- If we cannot find the project file, we return an empty string
if Result = null then
Path := Namet.No_Path;
return;
else
declare
Final_Result : constant String :=
GNAT.OS_Lib.Normalize_Pathname
(Result.all,
Directory => Directory,
Resolve_Links => Opt.Follow_Links_For_Files,
Case_Sensitive => True);
begin
Free (Result);
Name_Len := Final_Result'Length;
Name_Buffer (1 .. Name_Len) := Final_Result;
Path := Name_Find;
Projects_Paths.Set (Self.Cache, Key, Path);
end;
end if;
Debug_Decrease_Indent;
end Find_Project;
----------
-- Free --
----------
procedure Free (Self : in out Project_Search_Path) is
begin
Free (Self.Path);
Projects_Paths.Reset (Self.Cache);
end Free;
----------
-- Copy --
----------
procedure Copy (From : Project_Search_Path; To : out Project_Search_Path) is
begin
Free (To);
if From.Path /= null then
To.Path := new String'(From.Path.all);
end if;
-- No need to copy the Cache, it will be recomputed as needed
end Copy;
end Prj.Env;
gprbuild-gpl-2014-src/gnat/prj-conf.ads 0000644 0000767 0000145 00000030416 12323721731 017277 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . C O N F --
-- --
-- S p e c --
-- --
-- Copyright (C) 2006-2014, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- The following package manipulates the configuration files
with Prj.Tree;
with Prj.Proc;
package Prj.Conf is
type Config_File_Hook is access procedure
(Config_File : in out Prj.Tree.Project_Node_Id;
Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref);
-- Hook called after the config file has been parsed. This lets the
-- application do last minute changes to it (GPS uses this to add the
-- default naming schemes for instance). At that point, the config file
-- has not been applied to the project yet. When no config file was found,
-- and automatic generation is disabled, it is possible that Config_File
-- is set to Empty_Node when this procedure is called. You can then decide
-- to create a new config file if you need.
No_Configuration_File : constant String := "/";
-- When specified as a parameter Config_File_Name in the procedures below,
-- no existing configuration project file is parsed. This is used by
-- gnatmake, gnatclean and the GNAT driver to avoid parsing an existing
-- default configuration project file.
procedure Parse_Project_And_Apply_Config
(Main_Project : out Prj.Project_Id;
User_Project_Node : out Prj.Tree.Project_Node_Id;
Config_File_Name : String := "";
Autoconf_Specified : Boolean;
Project_File_Name : String;
Project_Tree : Prj.Project_Tree_Ref;
Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
Env : in out Prj.Tree.Environment;
Packages_To_Check : String_List_Access;
Allow_Automatic_Generation : Boolean := True;
Automatically_Generated : out Boolean;
Config_File_Path : out String_Access;
Target_Name : String := "";
Normalized_Hostname : String;
On_Load_Config : Config_File_Hook := null;
Implicit_Project : Boolean := False;
On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null);
-- Find the main configuration project and parse the project tree rooted at
-- this configuration project.
--
-- Project_Node_Tree must have been initialized first (and possibly the
-- value for external references and project path should also have been
-- set).
--
-- If the processing fails, Main_Project is set to No_Project. If the error
-- happened while parsing the project itself (i.e. creating the tree),
-- User_Project_Node is also set to Empty_Node.
--
-- If Config_File_Name is No_Configuration_File, then no configuration
-- project file is parsed. Normally, in this case On_Load_Config is not
-- null, and it is used to create a configuration project file in memory.
--
-- Autoconf_Specified indicates whether the user has specified --autoconf.
-- If this is the case, the config file might be (re)generated, as
-- appropriate, to match languages and target if the one specified doesn't
-- already match.
--
-- Normalized_Hostname is the host on which gprbuild is returned,
-- normalized so that we can more easily compare it with what is stored in
-- configuration files. It is used when the target is unspecified, although
-- we need to know the target specified by the user (Target_Name) when
-- computing the name of the default config file that should be used.
--
-- If specified, On_Load_Config is called just after the config file has
-- been created/loaded. You can then modify it before it is later applied
-- to the project itself.
--
-- Any error in generating or parsing the config file is reported via the
-- Invalid_Config exception, with an appropriate message. Any error while
-- parsing the project file results in No_Project.
--
-- If Implicit_Project is True, the main project file being parsed is
-- deemed to be in the current working directory, even if it is not the
-- case. Implicit_Project is set to True when a tool such as gprbuild is
-- invoked without a project file and is using an implicit project file
-- that is virtually in the current working directory, but is physically
-- in another directory.
--
-- If specified, On_New_Tree_Loaded is called after each aggregated project
-- has been processed succesfully.
procedure Process_Project_And_Apply_Config
(Main_Project : out Prj.Project_Id;
User_Project_Node : Prj.Tree.Project_Node_Id;
Config_File_Name : String := "";
Autoconf_Specified : Boolean;
Project_Tree : Prj.Project_Tree_Ref;
Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
Env : in out Prj.Tree.Environment;
Packages_To_Check : String_List_Access;
Allow_Automatic_Generation : Boolean := True;
Automatically_Generated : out Boolean;
Config_File_Path : out String_Access;
Target_Name : String := "";
Normalized_Hostname : String;
On_Load_Config : Config_File_Hook := null;
Reset_Tree : Boolean := True;
On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null);
-- Same as above, except the project must already have been parsed through
-- Prj.Part.Parse, and only the processing of the project and the
-- configuration is done at this level.
--
-- If Reset_Tree is true, all projects are first removed from the tree.
-- When_No_Sources indicates what should be done when no sources are found
-- for one of the languages of the project.
--
-- If Require_Sources_Other_Lang is true, then all languages must have at
-- least one source file, or an error is reported via When_No_Sources. If
-- it is false, this is only required for Ada (and only if it is a language
-- of the project).
Invalid_Config : exception;
procedure Get_Or_Create_Configuration_File
(Project : Prj.Project_Id;
Conf_Project : Project_Id;
Project_Tree : Prj.Project_Tree_Ref;
Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
Env : in out Prj.Tree.Environment;
Allow_Automatic_Generation : Boolean;
Config_File_Name : String := "";
Autoconf_Specified : Boolean;
Target_Name : String := "";
Normalized_Hostname : String;
Packages_To_Check : String_List_Access := null;
Config : out Prj.Project_Id;
Config_File_Path : out String_Access;
Automatically_Generated : out Boolean;
On_Load_Config : Config_File_Hook := null);
-- Compute the name of the configuration file that should be used. If no
-- default configuration file is found, a new one will be automatically
-- generated if Allow_Automatic_Generation is true. This configuration
-- project file will be generated in the object directory of project
-- Conf_Project.
--
-- Any error in generating or parsing the config file is reported via the
-- Invalid_Config exception, with an appropriate message.
--
-- On exit, Configuration_Project_Path is never null (if none could be
-- found, Os.Fail was called and the program exited anyway).
--
-- The choice and generation of a configuration file depends on several
-- attributes of the user's project file (given by the Project argument),
-- e.g. list of languages that must be supported. Project must therefore
-- have been partially processed (phase one of the processing only).
--
-- Config_File_Name should be set to the name of the config file specified
-- by the user (either through gprbuild's --config or --autoconf switches).
-- In the latter case, Autoconf_Specified should be set to true to indicate
-- that the configuration file can be regenerated to match target and
-- languages. This name can either be an absolute path, or the base name
-- that will be searched in the default config file directories (which
-- depends on the installation path for the tools).
--
-- Target_Name is used to chose the configuration file that will be used
-- from among several possibilities.
--
-- If a project file could be found, it is automatically parsed and
-- processed (and Packages_To_Check is used to indicate which packages
-- should be processed).
procedure Add_Default_GNAT_Naming_Scheme
(Config_File : in out Prj.Tree.Project_Node_Id;
Project_Tree : Prj.Tree.Project_Node_Tree_Ref);
-- A hook that will create a new config file (in memory), used for
-- Get_Or_Create_Configuration_File and Process_Project_And_Apply_Config
-- and add the default GNAT naming scheme to it. Nothing is done if the
-- config_file already exists, to avoid overriding what the user might
-- have put in there.
--------------
-- Runtimes --
--------------
procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String);
-- Specifies the runtime to use for a specific language. Most of the time
-- this should be used for Ada, but other languages can also specify their
-- own runtime. This is in general specified via the --RTS command line
-- switch, and results in a specific component passed to gprconfig's
-- --config switch then automatically generating a configuration file.
function Runtime_Name_For (Language : Name_Id) return String;
-- Returns the runtime name for a language. Returns an empty string if no
-- runtime was specified for the language using option --RTS.
function Runtime_Name_Set_For (Language : Name_Id) return Boolean;
-- Returns True only if Set_Runtime_For has been called for the Language
procedure Locate_Runtime
(Language : Name_Id;
Project_Tree : Prj.Project_Tree_Ref;
Env : Prj.Tree.Environment);
-- If RTS_Name is a base name (a name without path separator), then
-- do nothing. Otherwise, convert it to an absolute path (possibly by
-- searching it in the project path) and call Set_Runtime_For with the
-- absolute path. Fail the program if the path does not exist.
end Prj.Conf;
gprbuild-gpl-2014-src/gnat/targparm.ads 0000644 0000767 0000145 00000076167 12323721731 017413 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- T A R G P A R M --
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2014, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package obtains parameters from the target runtime version of System,
-- to indicate parameters relevant to the target environment.
-- Conceptually, these parameters could be obtained using rtsfind, but
-- we do not do this for four reasons:
-- 1. Compiling System for every compilation wastes time
-- 2. This compilation impedes debugging by adding extra compile steps
-- 3. There are recursion problems coming from compiling System itself
-- or any of its children.
-- 4. The binder also needs the parameters, and we do not want to have
-- to drag a lot of front end stuff into the binder.
-- For all these reasons, we read in the source of System, and then scan
-- it at the text level to extract the parameter values.
-- Note however, that later on, when the ali file is written, we make sure
-- that the System file is at least parsed, so that the checksum is properly
-- computed and set in the ali file. This partially negates points 1 and 2
-- above although just parsing is quick and does not impact debugging much.
-- The parameters acquired by this routine from system.ads fall into four
-- categories:
-- 1. Configuration pragmas, that must appear at the start of the file.
-- Any such pragmas automatically apply to any unit compiled in the
-- presence of this system file. Only a limited set of such pragmas
-- may appear as documented in the corresponding section below,
-- 2. Target parameters. These are boolean constants that are defined
-- in the private part of the package giving fixed information
-- about the target architecture, and the capabilities of the
-- code generator and run-time library.
-- 3. Identification information. This is an optional string constant
-- that gives the name of the run-time library configuration. This
-- line may be omitted for a version of system.ads to be used with
-- the full Ada 95 run time.
-- 4. Other characteristics of package System. At the current time the
-- only item in this category is whether type Address is private.
with Rident; use Rident;
with Namet; use Namet;
with Types; use Types;
package Targparm is
---------------------------
-- Configuration Pragmas --
---------------------------
-- The following switches get set if the corresponding configuration
-- pragma is scanned from the source of system.ads. No other pragmas
-- are permitted to appear at the start of the system.ads source file.
-- If a pragma Discard_Names appears, then Opt.Global_Discard_Names is
-- set to True to indicate that all units must be compiled in this mode.
-- If a pragma Locking_Policy appears, then Opt.Locking_Policy is set
-- to the first character of the policy name, and Opt.Locking_Policy_Sloc
-- is set to System_Location.
-- If a pragma Normalize_Scalars appears, then Opt.Normalize_Scalars
-- is set True, as well as Opt.Init_Or_Norm_Scalars.
-- If a pragma Queuing_Policy appears, then Opt.Queuing_Policy is set
-- to the first character of the policy name, and Opt.Queuing_Policy_Sloc
-- is set to System_Location.
-- If a pragma Task_Dispatching_Policy appears, then the flag
-- Opt.Task_Dispatching_Policy is set to the first character of the
-- policy name, and Opt.Task_Dispatching_Policy_Sloc is set to
-- System_Location.
-- 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.
-- If a pragma Profile with a valid profile argument appears, then
-- the appropriate restrictions and policy flags are set.
-- The only other pragma allowed is a pragma Restrictions that specifies
-- a restriction that will be imposed on all units in the partition. Note
-- that in this context, only one restriction can be specified in a single
-- pragma, and the pragma must appear on its own on a single source line.
-- If package System contains exactly the line "type Address is private;"
-- then the flag Opt.Address_Is_Private is set True, otherwise this flag
-- is set False.
Restrictions_On_Target : Restrictions_Info := No_Restrictions;
-- Records restrictions specified by system.ads. Only the Set and Value
-- members are modified. The Violated and Count fields are never modified.
-- Note that entries can be set either by a pragma Restrictions or by
-- a pragma Profile.
-------------------
-- Run Time Name --
-------------------
-- This parameter should be regarded as read only by all clients of
-- of package. The only way they get modified is by calling the
-- Get_Target_Parameters routine which reads the values from a provided
-- text buffer containing the source of the system package.
-- The corresponding string constant is placed immediately at the start
-- of the private part of system.ads if is present, e.g. in the form:
-- Run_Time_Name : constant String := "Zero Footprint Run Time";
-- the corresponding messages will look something like
-- xxx not supported (Zero Footprint Run Time)
Run_Time_Name_On_Target : Name_Id := No_Name;
-- Set to appropriate names table entry Id value if a Run_Time_Name
-- string constant is defined in system.ads. This name is used only
-- for the configurable run-time case, and is used to parameterize
-- messages that complain about non-supported run-time features.
-- The name should contain only letters A-Z, digits 1-9, spaces,
-- and underscores.
--------------------------
-- Executable Extension --
--------------------------
Executable_Extension_On_Target : Name_Id := No_Name;
-- Executable extension on the target. This name is useful for setting
-- the executable extension in a dynamic way, e.g. depending on the
-- run time used, rather than using a configure-time macro as done by
-- Get_Target_Executable_Suffix. If not set (No_Name), instead use
-- System.OS_Lib.Get_Target_Executable_Suffix.
-----------------------
-- Target Parameters --
-----------------------
-- The following parameters correspond to the variables defined in the
-- private part of System (without the terminating _On_Target). Note
-- that it is required that all parameters defined here be specified
-- in the target specific version of system.ads. Thus, to add a new
-- parameter, add it to all system*.ads files. (There is a defaulting
-- mechanism, but we don't normally take advantage of it, as explained
-- below.)
-- The default values here are used if no value is found in system.ads.
-- This should normally happen if the special version of system.ads used
-- by the compiler itself is in use or if the value is only relevant to
-- a particular target (e.g. OpenVMS, AAMP). The default values are
-- suitable for use in normal environments. This approach allows the
-- possibility of new versions of the compiler (possibly with new system
-- parameters added) being used to compile older versions of the compiler
-- sources, as well as avoiding duplicating values in all system-*.ads
-- files for flags that are used on a few platforms only.
-- All these parameters should be regarded as read only by all clients
-- of the package. The only way they get modified is by calling the
-- Get_Target_Parameters routine which reads the values from a provided
-- text buffer containing the source of the system package.
----------------------------
-- Special Target Control --
----------------------------
-- The great majority of GNAT ports are based on GCC. The switches in
-- this section indicate the use of some non-standard target back end
-- or other special targetting requirements.
AAMP_On_Target : Boolean := False;
-- Set to True if target is AAMP
OpenVMS_On_Target : Boolean := False;
-- Set to True if target is OpenVMS
VAX_Float_On_Target : Boolean := False;
-- Set to True if target float format is VAX Float
RTX_RTSS_Kernel_Module_On_Target : Boolean := False;
-- Set to True if target is RTSS module for RTX
type Virtual_Machine_Kind is (No_VM, JVM_Target, CLI_Target);
VM_Target : Virtual_Machine_Kind := No_VM;
-- Kind of virtual machine targetted
-- No_VM: no virtual machine, default case of a standard processor
-- JVM_Target: Java Virtual Machine
-- CLI_Target: CLI/.NET Virtual Machine
-------------------------------
-- Backend Arithmetic Checks --
-------------------------------
-- Divide and overflow checks are either done in the front end or
-- back end. The front end will generate checks when required unless
-- the corresponding parameter here is set to indicate that the back
-- end will generate the required checks (or that the checks are
-- automatically performed by the hardware in an appropriate form).
Backend_Divide_Checks_On_Target : Boolean := False;
-- Set True if the back end generates divide checks, or if the hardware
-- checks automatically. Set False if the front end must generate the
-- required tests using explicit expanded code.
Backend_Overflow_Checks_On_Target : Boolean := False;
-- Set True if the back end generates arithmetic overflow checks, or if
-- the hardware checks automatically. Set False if the front end must
-- generate the required tests using explicit expanded code.
-----------------------------------
-- Control of Exception Handling --
-----------------------------------
-- GNAT implements three methods of implementing exceptions:
-- Front-End Longjmp/Setjmp Exceptions
-- This approach uses longjmp/setjmp to handle exceptions. It
-- uses less storage, and can often propagate exceptions faster,
-- at the expense of (sometimes considerable) overhead in setting
-- up an exception handler. This approach is available on all
-- targets, and is the default where it is the only approach.
-- The generation of the setjmp and longjmp calls is handled by
-- the front end of the compiler (this includes gigi in the case
-- of the standard GCC back end). It does not use any back end
-- support (such as the GCC3 exception handling mechanism). When
-- this approach is used, the compiler generates special exception
-- handlers for handling cleanups when an exception is raised.
-- Front-End Zero Cost Exceptions
-- This approach uses separate exception tables. These use extra
-- storage, and exception propagation can be quite slow, but there
-- is no overhead in setting up an exception handler (it is to this
-- latter operation that the phrase zero-cost refers). This approach
-- is only available on some targets, and is the default where it is
-- available.
-- The generation of the exception tables is handled by the front
-- end of the compiler. It does not use any back end support (such
-- as the GCC3 exception handling mechanism). When this approach
-- is used, the compiler generates special exception handlers for
-- handling cleanups when an exception is raised.
-- Back-End Zero Cost Exceptions
-- With this approach, the back end handles the generation and
-- handling of exceptions. For example, the GCC3 exception handling
-- mechanisms are used in this mode. The front end simply generates
-- code for explicit exception handlers, and AT END cleanup handlers
-- are simply passed unchanged to the backend for generating cleanups
-- both in the exceptional and non-exceptional cases.
-- As the name implies, this approach generally uses a zero-cost
-- mechanism with tables, but the tables are generated by the back
-- end. However, since the back-end is entirely responsible for the
-- handling of exceptions, another mechanism might be used. In the
-- case of GCC3 for instance, it might be the case that the compiler
-- is configured for setjmp/longjmp handling, then everything will
-- work correctly. However, it is definitely preferred that the
-- back end provide zero cost exception handling.
-- Controlling the selection of methods
-- On most implementations, back-end zero-cost exceptions are used.
-- Otherwise, Front-End Longjmp/Setjmp approach is used.
-- Note that there is a requirement that all Ada units in a partition
-- be compiled with the same exception model.
-- Control of Available Methods and Defaults
-- The following switches specify whether ZCX is available, and
-- whether it is enabled by default.
ZCX_By_Default_On_Target : Boolean := False;
-- Indicates if zero cost exceptions are active by default. If this
-- variable is False, then the only possible exception method is the
-- front-end setjmp/longjmp approach, and this is the default. If
-- this variable is True, then GCC ZCX is used.
------------------------------------
-- Run-Time Library Configuration --
------------------------------------
-- In configurable run-time mode, the system run-time may not support
-- the full Ada language. The effect of setting this switch is to let
-- the compiler know that it is not surprising (i.e. the system is not
-- misconfigured) if run-time library units or entities within units are
-- not present in the run-time.
Configurable_Run_Time_On_Target : Boolean := False;
-- Indicates that the system.ads file is for a configurable run-time
--
-- This has some specific effects as follows
--
-- The binder generates the gnat_argc/argv/envp variables in the
-- binder file instead of being imported from the run-time library.
-- If Command_Line_Args_On_Target is set to False, then the
-- generation of these variables is suppressed completely.
--
-- The binder generates the gnat_exit_status variable in the binder
-- file instead of being imported from the run-time library. If
-- Exit_Status_Supported_On_Target is set to False, then the
-- generation of this variable is suppressed entirely.
--
-- The routine __gnat_break_start is defined within the binder file
-- instead of being imported from the run-time library.
--
-- The variable __gnat_exit_status is generated within the binder file
-- instead of being imported from the run-time library.
Suppress_Standard_Library_On_Target : Boolean := False;
-- If this flag is True, then the standard library is not included by
-- default in the executable (see unit System.Standard_Library in file
-- s-stalib.ads for details of what this includes). This is for example
-- set True for the zero foot print case, where these files should not
-- be included by default.
--
-- This flag has some other related effects:
--
-- The generation of global variables in the bind file is suppressed,
-- with the exception of the priority of the environment task, which
-- is needed by the Ravenscar run-time.
--
-- The calls to __gnat_initialize and __gnat_finalize are omitted
--
-- All finalization and initialization (controlled types) is omitted
--
-- The routine __gnat_handler_installed is not imported
Preallocated_Stacks_On_Target : Boolean := False;
-- If this flag is True, then the expander preallocates all task stacks
-- at compile time. If the flag is False, then task stacks are not pre-
-- allocated, and task stack allocation is the responsibility of the
-- run-time (which typically delegates the task to the underlying
-- operating system environment).
---------------------
-- Duration Format --
---------------------
-- By default, type Duration is a 64-bit fixed-point type with a delta
-- and small of 10**(-9) (i.e. it is a count in nanoseconds. This flag
-- allows that standard format to be modified.
Duration_32_Bits_On_Target : Boolean := False;
-- If True, then Duration is represented in 32 bits and the delta and
-- small values are set to 20.0*(10**(-3)) (i.e. it is a count in units
-- of 20 milliseconds.
------------------------------------
-- Back-End Code Generation Flags --
------------------------------------
-- These flags indicate possible limitations in what the code generator
-- can handle. They will all be True for a full run-time, but one or more
-- of these may be false for a configurable run-time, and if a feature is
-- used at the source level, and the corresponding flag is false, then an
-- error message will be issued saying the feature is not supported.
Atomic_Sync_Default_On_Target : Boolean := True;
-- Access to atomic variables requires memory barrier synchronization in
-- the general case to ensure proper behavior when such accesses are used
-- on a multi-processor to synchronize tasks (e.g. by using spin locks).
-- The setting of this flag determines the default behavior. Normally this
-- is True, which will mean that appropriate synchronization instructions
-- are generated by default. If it is False, then the default will be that
-- these synchronization instructions are not generated. This may be a more
-- appropriate default in some cases, e.g. on embedded targets which do not
-- allow the possibility of multi-processors. The default can be overridden
-- using pragmas Enable/Disable_Atomic_Synchronization and also by use of
-- the corresponding debug flags -gnatd.e and -gnatd.d.
Support_Aggregates_On_Target : Boolean := True;
-- In the general case, the use of aggregates may generate calls
-- to run-time routines in the C library, including memset, memcpy,
-- memmove, and bcopy. This flag is set to True if these routines
-- are available. If any of these routines is not available, then
-- this flag is False, and the use of aggregates is not permitted.
Support_Atomic_Primitives_On_Target : Boolean := False;
-- If this flag is True, then the back-end support GCC built-in atomic
-- operations for memory model such as atomic load or atomic compare
-- exchange (see the GCC manual for more information). If the flag is
-- False, then the back-end doesn't provide this support. Note this flag is
-- set to True only if the target supports all atomic primitives up to 64
-- bits. ??? To be modified.
Support_Composite_Assign_On_Target : Boolean := True;
-- The assignment of composite objects other than small records and
-- arrays whose size is 64-bits or less and is set by an explicit
-- size clause may generate calls to memcpy, memmove, and bcopy.
-- If versions of all these routines are available, then this flag
-- is set to True. If any of these routines is not available, then
-- the flag is set False, and composite assignments are not allowed.
Support_Composite_Compare_On_Target : Boolean := True;
-- If this flag is True, then the back end supports bit-wise comparison
-- of composite objects for equality, either generating inline code or
-- calling appropriate (and available) run-time routines. If this flag
-- is False, then the back end does not provide this support, and the
-- front end uses component by component comparison for composites.
Support_Long_Shifts_On_Target : Boolean := True;
-- If True, the back end supports 64-bit shift operations. If False, then
-- the source program may not contain explicit 64-bit shifts. In addition,
-- the code generated for packed arrays will avoid the use of long shifts.
Support_Nondefault_SSO_On_Target : Boolean := True;
-- If True, the back end supports the non-default Scalar_Storage_Order
-- (i.e. allows non-confirming Scalar_Storage_Order attribute definition
-- clauses).
--------------------
-- Indirect Calls --
--------------------
Always_Compatible_Rep_On_Target : Boolean := True;
-- If True, the Can_Use_Internal_Rep flag (see Einfo) is set to False in
-- all cases. This corresponds to the traditional code generation
-- strategy. False allows the front end to choose a policy that partly or
-- entirely eliminates dynamically generated trampolines.
-------------------------------
-- Control of Stack Checking --
-------------------------------
-- GNAT provides three methods of implementing exceptions:
-- GCC Probing Mechanism
-- This approach uses the standard GCC mechanism for
-- stack checking. The method assumes that accessing
-- storage immediately beyond the end of the stack
-- will result in a trap that is converted to a storage
-- error by the runtime system. This mechanism has
-- minimal overhead, but requires complex hardware,
-- operating system and run-time support. Probing is
-- the default method where it is available. The stack
-- size for the environment task depends on the operating
-- system and cannot be set in a system-independent way.
-- GCC Stack-limit Mechanism
-- This approach uses the GCC stack limits mechanism.
-- It relies on comparing the stack pointer with the
-- values of a global symbol. If the check fails, a
-- trap is explicitly generated. The advantage is
-- that the mechanism requires no memory protection,
-- but operating system and run-time support are
-- needed to manage the per-task values of the symbol.
-- This is the default method after probing where it
-- is available.
-- GNAT Stack-limit Checking
-- This method relies on comparing the stack pointer
-- with per-task stack limits. If the check fails, an
-- exception is explicitly raised. The advantage is
-- that the method requires no extra system dependent
-- runtime support and can be used on systems without
-- memory protection as well, but at the cost of more
-- overhead for doing the check. This is the fallback
-- method if the above two are not supported.
Stack_Check_Probes_On_Target : Boolean := False;
-- Indicates if the GCC probing mechanism is used
Stack_Check_Limits_On_Target : Boolean := False;
-- Indicates if the GCC stack-limit mechanism is used
-- Both flags cannot be simultaneously set to True. If neither
-- is, the target independent fallback method is used.
Stack_Check_Default_On_Target : Boolean := False;
-- Indicates if stack checking is on by default
----------------------------
-- Command Line Arguments --
----------------------------
-- For most ports of GNAT, command line arguments are supported. The
-- following flag is set to False for targets that do not support
-- command line arguments (VxWorks and AAMP). Note that support of
-- command line arguments is not required on such targets (RM A.15(13)).
Command_Line_Args_On_Target : Boolean := True;
-- Set False if no command line arguments on target. Note that if this
-- is False in with Configurable_Run_Time_On_Target set to True, then
-- this causes suppression of generation of the argv/argc variables
-- used to record command line arguments.
-- Similarly, most ports support the use of an exit status, but AAMP
-- is an exception (as allowed by RM A.15(18-20))
Exit_Status_Supported_On_Target : Boolean := True;
-- Set False if returning of an exit status is not supported on target.
-- Note that if this False in with Configurable_Run_Time_On_Target
-- set to True, then this causes suppression of the gnat_exit_status
-- variable used to record the exit status.
-----------------------
-- Main Program Name --
-----------------------
-- When the binder generates the main program to be used to create the
-- executable, the main program name is main by default (to match the
-- usual Unix practice). If this parameter is set to True, then the
-- name is instead by default taken from the actual Ada main program
-- name (just the name of the child if the main program is a child unit).
-- In either case, this value can be overridden using -M name.
Use_Ada_Main_Program_Name_On_Target : Boolean := False;
-- Set True to use the Ada main program name as the main name
----------------------------------------------
-- Boolean-Valued Floating-Point Attributes --
----------------------------------------------
-- The constants below give the values for representation oriented
-- floating-point attributes that are the same for all float types
-- on the target. These are all boolean values.
-- A value is only True if the target reliably supports the corresponding
-- feature. Reliably here means that support is guaranteed for all
-- possible settings of the relevant compiler switches (like -mieee),
-- since we cannot control the user setting of those switches.
-- The attributes cannot dependent on the current setting of compiler
-- switches, since the values must be static and consistent throughout
-- the partition. We probably should add such consistency checks in future,
-- but for now we don't do this.
-- Note: the compiler itself does not use floating-point, so the
-- settings of the defaults here are not really relevant.
-- Note: in some cases, proper support of some of these floating point
-- features may require a specific switch (e.g. -mieee on the Alpha)
-- to be used to obtain full RM compliant support.
Denorm_On_Target : Boolean := False;
-- Set to False on targets that do not reliably support denormals
Machine_Rounds_On_Target : Boolean := True;
-- Set to False for targets where S'Machine_Rounds is False
Machine_Overflows_On_Target : Boolean := False;
-- Set to True for targets where S'Machine_Overflows is True
Signed_Zeros_On_Target : Boolean := True;
-- Set to False on targets that do not reliably support signed zeros
-------------------------------------------
-- Boolean-Valued Fixed-Point Attributes --
-------------------------------------------
Fractional_Fixed_Ops_On_Target : Boolean := False;
-- Set to True for targets that support fixed-by-fixed multiplication
-- and division for fixed-point types with a small value equal to
-- 2 ** (-(T'Object_Size - 1)) and whose values have an absolute
-- value less than 1.0.
-----------------
-- Data Layout --
-----------------
-- Normally when using the GCC backend, Gigi and GCC perform much of the
-- data layout using the standard layout capabilities of GCC. If the
-- parameter Backend_Layout is set to False, then the front end must
-- perform all data layout. For further details see the package Layout.
Frontend_Layout_On_Target : Boolean := False;
-- Set True if front end does layout
-----------------
-- Subprograms --
-----------------
-- These subprograms are used to initialize the target parameter values
-- from the system.ads file. Note that this is only done once, so if more
-- than one call is made to either routine, the second and subsequent
-- calls are ignored. It also reads restriction pragmas from system.ads
-- and records them, though as further detailed below, the caller has some
-- control over the handling of No_Dependence restrictions.
type Make_Id_Type is access function (Str : Text_Buffer) return Node_Id;
-- Parameter type for Get_Target_Parameters for function that creates an
-- identifier node with Sloc value System_Location and given string as the
-- Chars value.
type Make_SC_Type is access function (Pre, Sel : Node_Id) return Node_Id;
-- Parameter type for Get_Target_Parameters for function that creates a
-- selected component with Sloc value System_Location and given Prefix
-- (Pre) and Selector (Sel) values.
type Set_RND_Type is access procedure (Unit : Node_Id);
-- Parameter type for Get_Target_Parameters that records a Restriction
-- No_Dependence for the given unit (identifier or selected component).
procedure Get_Target_Parameters
(System_Text : Source_Buffer_Ptr;
Source_First : Source_Ptr;
Source_Last : Source_Ptr;
Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
Set_RND : Set_RND_Type := null);
-- Called at the start of execution to obtain target parameters from
-- the source of package System. The parameters provide the source
-- text to be scanned (in System_Text (Source_First .. Source_Last)).
-- if the three subprograms are left at their default value of null,
-- Get_Target_Parameters will ignore pragma Restrictions No_Dependence
-- lines, otherwise it will use these three subprograms to record them.
procedure Get_Target_Parameters
(Make_Id : Make_Id_Type := null;
Make_SC : Make_SC_Type := null;
Set_RND : Set_RND_Type := null);
-- This version reads in system.ads using Osint. The idea is that the
-- caller uses the first version if they have to read system.ads anyway
-- (e.g. the compiler) and uses this simpler interface if system.ads is
-- not otherwise needed.
end Targparm;
gprbuild-gpl-2014-src/gnat/Make-lang.hie 0000644 0000767 0000145 00000000000 12323721723 017336 0 ustar gnatmail gnat gprbuild-gpl-2014-src/gnat/widechar.adb 0000644 0000767 0000145 00000017366 12323721731 017337 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- W I D E C H A R --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, 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 3, 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. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- >
loop
-- Skip past blanks, loop is opened up for speed
while Source (Scan_Ptr) = ' ' loop
if Source (Scan_Ptr + 1) /= ' ' then
Scan_Ptr := Scan_Ptr + 1;
exit;
end if;
if Source (Scan_Ptr + 2) /= ' ' then
Scan_Ptr := Scan_Ptr + 2;
exit;
end if;
if Source (Scan_Ptr + 3) /= ' ' then
Scan_Ptr := Scan_Ptr + 3;
exit;
end if;
if Source (Scan_Ptr + 4) /= ' ' then
Scan_Ptr := Scan_Ptr + 4;
exit;
end if;
if Source (Scan_Ptr + 5) /= ' ' then
Scan_Ptr := Scan_Ptr + 5;
exit;
end if;
if Source (Scan_Ptr + 6) /= ' ' then
Scan_Ptr := Scan_Ptr + 6;
exit;
end if;
if Source (Scan_Ptr + 7) /= ' ' then
Scan_Ptr := Scan_Ptr + 7;
exit;
end if;
Scan_Ptr := Scan_Ptr + 8;
end loop;
-- We are now at a non-blank character, which is the first character
-- of the token we will scan, and hence the value of Token_Ptr.
Token_Ptr := Scan_Ptr;
-- Here begins the main case statement which transfers control on the
-- basis of the non-blank character we have encountered.
case Source (Scan_Ptr) is
-- Line terminator characters
when CR | LF | FF | VT =>
goto Scan_Line_Terminator;
-- Horizontal tab, just skip past it
when HT =>
if Style_Check then
Style.Check_HT;
end if;
Scan_Ptr := Scan_Ptr + 1;
-- End of file character, treated as an end of file only if it is
-- the last character in the buffer, otherwise it is ignored.
when EOF =>
if Scan_Ptr = Source_Last (Current_Source_File) then
Check_End_Of_Line;
if Style_Check then
Style.Check_EOF;
end if;
Token := Tok_EOF;
return;
else
Scan_Ptr := Scan_Ptr + 1;
end if;
-- Ampersand
when '&' =>
Accumulate_Checksum ('&');
if Source (Scan_Ptr + 1) = '&' then
Error_Msg_S -- CODEFIX
("'&'& should be `AND THEN`");
Scan_Ptr := Scan_Ptr + 2;
Token := Tok_And;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Ampersand;
return;
end if;
-- Asterisk (can be multiplication operator or double asterisk which
-- is the exponentiation compound delimiter).
when '*' =>
Accumulate_Checksum ('*');
if Source (Scan_Ptr + 1) = '*' then
Accumulate_Checksum ('*');
Scan_Ptr := Scan_Ptr + 2;
Token := Tok_Double_Asterisk;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Asterisk;
return;
end if;
-- Colon, which can either be an isolated colon, or part of an
-- assignment compound delimiter.
when ':' =>
Accumulate_Checksum (':');
if Double_Char_Token ('=') then
Token := Tok_Colon_Equal;
if Style_Check then
Style.Check_Colon_Equal;
end if;
return;
elsif Source (Scan_Ptr + 1) = '-'
and then Source (Scan_Ptr + 2) /= '-'
then
Token := Tok_Colon_Equal;
Error_Msg -- CODEFIX
(":- should be :=", Scan_Ptr);
Scan_Ptr := Scan_Ptr + 2;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Colon;
if Style_Check then
Style.Check_Colon;
end if;
return;
end if;
-- Left parenthesis
when '(' =>
Accumulate_Checksum ('(');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Left_Paren;
if Style_Check then
Style.Check_Left_Paren;
end if;
return;
-- Left bracket
when '[' =>
if Source (Scan_Ptr + 1) = '"' then
goto Scan_Wide_Character;
else
Error_Msg_S ("illegal character, replaced by ""(""");
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Left_Paren;
return;
end if;
-- Left brace
when '{' =>
Error_Msg_S ("illegal character, replaced by ""(""");
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Left_Paren;
return;
-- Comma
when ',' =>
Accumulate_Checksum (',');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Comma;
if Style_Check then
Style.Check_Comma;
end if;
return;
-- Dot, which is either an isolated period, or part of a double dot
-- compound delimiter sequence. We also check for the case of a
-- digit following the period, to give a better error message.
when '.' =>
Accumulate_Checksum ('.');
if Double_Char_Token ('.') then
Token := Tok_Dot_Dot;
if Style_Check then
Style.Check_Dot_Dot;
end if;
return;
elsif Source (Scan_Ptr + 1) in '0' .. '9' then
Error_Msg_S ("numeric literal cannot start with point");
Scan_Ptr := Scan_Ptr + 1;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Dot;
return;
end if;
-- Equal, which can either be an equality operator, or part of the
-- arrow (=>) compound delimiter.
when '=' =>
Accumulate_Checksum ('=');
if Double_Char_Token ('>') then
Token := Tok_Arrow;
if Style_Check then
Style.Check_Arrow;
end if;
return;
elsif Source (Scan_Ptr + 1) = '=' then
Error_Msg_S -- CODEFIX
("== should be =");
Scan_Ptr := Scan_Ptr + 1;
end if;
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Equal;
return;
-- Greater than, which can be a greater than operator, greater than
-- or equal operator, or first character of a right label bracket.
when '>' =>
Accumulate_Checksum ('>');
if Double_Char_Token ('=') then
Token := Tok_Greater_Equal;
return;
elsif Double_Char_Token ('>') then
Token := Tok_Greater_Greater;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Greater;
return;
end if;
-- Less than, which can be a less than operator, less than or equal
-- operator, or the first character of a left label bracket, or the
-- first character of a box (<>) compound delimiter.
when '<' =>
Accumulate_Checksum ('<');
if Double_Char_Token ('=') then
Token := Tok_Less_Equal;
return;
elsif Double_Char_Token ('>') then
Token := Tok_Box;
if Style_Check then
Style.Check_Box;
end if;
return;
elsif Double_Char_Token ('<') then
Token := Tok_Less_Less;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Less;
return;
end if;
-- Minus, which is either a subtraction operator, or the first
-- character of double minus starting a comment
when '-' => Minus_Case : begin
if Source (Scan_Ptr + 1) = '>' then
Error_Msg_S ("invalid token");
Scan_Ptr := Scan_Ptr + 2;
Token := Tok_Arrow;
return;
elsif Source (Scan_Ptr + 1) /= '-' then
Accumulate_Checksum ('-');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Minus;
return;
-- Comment
else -- Source (Scan_Ptr + 1) = '-' then
if Style_Check then
Style.Check_Comment;
end if;
Scan_Ptr := Scan_Ptr + 2;
-- If we are in preprocessor mode with Replace_In_Comments set,
-- then we return the "--" as a token on its own.
if Replace_In_Comments then
Token := Tok_Comment;
return;
end if;
-- Otherwise scan out the comment
Start_Of_Comment := Scan_Ptr;
-- Loop to scan comment (this loop runs more than once only if
-- a horizontal tab or other non-graphic character is scanned)
loop
-- Scan to non graphic character (opened up for speed)
-- Note that we just eat left brackets, which means that
-- bracket notation cannot be used for end of line
-- characters in comments. This seems a reasonable choice,
-- since no one would ever use brackets notation in a real
-- program in this situation, and if we allow brackets
-- notation, we forbid some valid comments which contain a
-- brackets sequence that happens to match an end of line
-- character.
loop
exit when Source (Scan_Ptr) not in Graphic_Character;
Scan_Ptr := Scan_Ptr + 1;
exit when Source (Scan_Ptr) not in Graphic_Character;
Scan_Ptr := Scan_Ptr + 1;
exit when Source (Scan_Ptr) not in Graphic_Character;
Scan_Ptr := Scan_Ptr + 1;
exit when Source (Scan_Ptr) not in Graphic_Character;
Scan_Ptr := Scan_Ptr + 1;
exit when Source (Scan_Ptr) not in Graphic_Character;
Scan_Ptr := Scan_Ptr + 1;
end loop;
-- Keep going if horizontal tab
if Source (Scan_Ptr) = HT then
if Style_Check then
Style.Check_HT;
end if;
Scan_Ptr := Scan_Ptr + 1;
-- Terminate scan of comment if line terminator
elsif Source (Scan_Ptr) in Line_Terminator then
exit;
-- Terminate scan of comment if end of file encountered
-- (embedded EOF character or real last character in file)
elsif Source (Scan_Ptr) = EOF then
exit;
-- If we have a wide character, we have to scan it out,
-- because it might be a legitimate line terminator
elsif Start_Of_Wide_Character then
declare
Wptr : constant Source_Ptr := Scan_Ptr;
Code : Char_Code;
Err : Boolean;
begin
Scan_Wide (Source, Scan_Ptr, Code, Err);
-- If not well formed wide character, then just skip
-- past it and ignore it.
if Err then
Scan_Ptr := Wptr + 1;
-- If UTF_32 terminator, terminate comment scan
elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then
Scan_Ptr := Wptr;
exit;
end if;
end;
-- Keep going if character in 80-FF range, or is ESC. These
-- characters are allowed in comments by RM-2.1(1), 2.7(2).
-- They are allowed even in Ada 83 mode according to the
-- approved AI. ESC was added to the AI in June 93.
elsif Source (Scan_Ptr) in Upper_Half_Character
or else Source (Scan_Ptr) = ESC
then
Scan_Ptr := Scan_Ptr + 1;
-- Otherwise we have an illegal comment character
else
Error_Illegal_Character;
end if;
end loop;
-- Note that, except when comments are tokens, we do NOT
-- execute a return here, instead we fall through to reexecute
-- the scan loop to look for a token.
if Comment_Is_Token then
Name_Len := Integer (Scan_Ptr - Start_Of_Comment);
Name_Buffer (1 .. Name_Len) :=
String (Source (Start_Of_Comment .. Scan_Ptr - 1));
Comment_Id := Name_Find;
Token := Tok_Comment;
return;
end if;
-- If the SPARK restriction is set for this unit, then generate
-- a token Tok_SPARK_Hide for a SPARK HIDE directive.
if Restriction_Check_Required (SPARK_05)
and then Source (Start_Of_Comment) = '#'
then
declare
Scan_SPARK_Ptr : Source_Ptr;
begin
Scan_SPARK_Ptr := Start_Of_Comment + 1;
-- Scan out blanks
while Source (Scan_SPARK_Ptr) = ' '
or else Source (Scan_SPARK_Ptr) = HT
loop
Scan_SPARK_Ptr := Scan_SPARK_Ptr + 1;
end loop;
-- Recognize HIDE directive. SPARK input cannot be
-- encoded as wide characters, so only deal with
-- lower/upper case.
if (Source (Scan_SPARK_Ptr) = 'h'
or else Source (Scan_SPARK_Ptr) = 'H')
and then (Source (Scan_SPARK_Ptr + 1) = 'i'
or else Source (Scan_SPARK_Ptr + 1) = 'I')
and then (Source (Scan_SPARK_Ptr + 2) = 'd'
or else Source (Scan_SPARK_Ptr + 2) = 'D')
and then (Source (Scan_SPARK_Ptr + 3) = 'e'
or else Source (Scan_SPARK_Ptr + 3) = 'E')
and then (Source (Scan_SPARK_Ptr + 4) = ' '
or else Source (Scan_SPARK_Ptr + 4) = HT)
then
Token := Tok_SPARK_Hide;
return;
end if;
end;
end if;
end if;
end Minus_Case;
-- Double quote or percent starting a string literal
when '"' | '%' =>
Slit;
Post_Scan;
return;
-- Apostrophe. This can either be the start of a character literal,
-- or an isolated apostrophe used in a qualified expression or an
-- attribute. We treat it as a character literal if it does not
-- follow a right parenthesis, identifier, the keyword ALL or
-- a literal. This means that we correctly treat constructs like:
-- A := CHARACTER'('A');
-- Note that RM-2.2(7) does not require a separator between
-- "CHARACTER" and "'" in the above.
when ''' => Char_Literal_Case : declare
Code : Char_Code;
Err : Boolean;
begin
Accumulate_Checksum (''');
Scan_Ptr := Scan_Ptr + 1;
-- Here is where we make the test to distinguish the cases. Treat
-- as apostrophe if previous token is an identifier, right paren
-- or the reserved word "all" (latter case as in A.all'Address)
-- (or the reserved word "project" in project files). Also treat
-- it as apostrophe after a literal (this catches some legitimate
-- cases, like A."abs"'Address, and also gives better error
-- behavior for impossible cases like 123'xxx).
if Prev_Token = Tok_Identifier
or else Prev_Token = Tok_Right_Paren
or else Prev_Token = Tok_All
or else Prev_Token = Tok_Project
or else Prev_Token in Token_Class_Literal
then
Token := Tok_Apostrophe;
if Style_Check then
Style.Check_Apostrophe;
end if;
return;
-- Otherwise the apostrophe starts a character literal
else
-- Case of wide character literal
if Start_Of_Wide_Character then
Wptr := Scan_Ptr;
Scan_Wide (Source, Scan_Ptr, Code, Err);
Accumulate_Checksum (Code);
if Err then
Error_Illegal_Wide_Character;
Code := Character'Pos (' ');
-- In Ada 95 mode we allow any wide character in a character
-- literal, but in Ada 2005, the set of characters allowed
-- is restricted to graphic characters.
elsif Ada_Version >= Ada_2005
and then Is_UTF_32_Non_Graphic (UTF_32 (Code))
then
Error_Msg -- CODEFIX????
("(Ada 2005) non-graphic character not permitted " &
"in character literal", Wptr);
end if;
if Source (Scan_Ptr) /= ''' then
Error_Msg_S ("missing apostrophe");
else
Scan_Ptr := Scan_Ptr + 1;
end if;
-- If we do not find a closing quote in the expected place then
-- assume that we have a misguided attempt at a string literal.
-- However, if previous token is RANGE, then we return an
-- apostrophe instead since this gives better error recovery
elsif Source (Scan_Ptr + 1) /= ''' then
if Prev_Token = Tok_Range then
Token := Tok_Apostrophe;
return;
else
Scan_Ptr := Scan_Ptr - 1;
Error_Msg_S
("strings are delimited by double quote character");
Slit;
Post_Scan;
return;
end if;
-- Otherwise we have a (non-wide) character literal
else
Accumulate_Checksum (Source (Scan_Ptr));
if Source (Scan_Ptr) not in Graphic_Character then
if Source (Scan_Ptr) in Upper_Half_Character then
if Ada_Version = Ada_83 then
Error_Illegal_Character;
end if;
else
Error_Illegal_Character;
end if;
end if;
Code := Get_Char_Code (Source (Scan_Ptr));
Scan_Ptr := Scan_Ptr + 2;
end if;
-- Fall through here with Scan_Ptr updated past the closing
-- quote, and Code set to the Char_Code value for the literal
Accumulate_Checksum (''');
Token := Tok_Char_Literal;
Set_Character_Literal_Name (Code);
Token_Name := Name_Find;
Character_Code := Code;
Post_Scan;
return;
end if;
end Char_Literal_Case;
-- Right parenthesis
when ')' =>
Accumulate_Checksum (')');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Right_Paren;
if Style_Check then
Style.Check_Right_Paren;
end if;
return;
-- Right bracket or right brace, treated as right paren
when ']' | '}' =>
Error_Msg_S ("illegal character, replaced by "")""");
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Right_Paren;
return;
-- Slash (can be division operator or first character of not equal)
when '/' =>
Accumulate_Checksum ('/');
if Double_Char_Token ('=') then
Token := Tok_Not_Equal;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Slash;
return;
end if;
-- Semicolon
when ';' =>
Accumulate_Checksum (';');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Semicolon;
if Style_Check then
Style.Check_Semicolon;
end if;
return;
-- Vertical bar
when '|' => Vertical_Bar_Case : begin
Accumulate_Checksum ('|');
-- Special check for || to give nice message
if Source (Scan_Ptr + 1) = '|' then
Error_Msg_S -- CODEFIX
("""'|'|"" should be `OR ELSE`");
Scan_Ptr := Scan_Ptr + 2;
Token := Tok_Or;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Vertical_Bar;
if Style_Check then
Style.Check_Vertical_Bar;
end if;
Post_Scan;
return;
end if;
end Vertical_Bar_Case;
-- Exclamation, replacement character for vertical bar
when '!' => Exclamation_Case : begin
Accumulate_Checksum ('!');
if Source (Scan_Ptr + 1) = '=' then
Error_Msg_S -- CODEFIX
("'!= should be /=");
Scan_Ptr := Scan_Ptr + 2;
Token := Tok_Not_Equal;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Vertical_Bar;
Post_Scan;
return;
end if;
end Exclamation_Case;
-- Plus
when '+' => Plus_Case : begin
Accumulate_Checksum ('+');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Plus;
return;
end Plus_Case;
-- Digits starting a numeric literal
when '0' .. '9' =>
-- First a bit of a scan ahead to see if we have a case of an
-- identifier starting with a digit (remembering exponent case).
declare
C : constant Character := Source (Scan_Ptr + 1);
begin
-- OK literal if digit followed by digit or underscore
if C in '0' .. '9' or else C = '_' then
null;
-- OK literal if digit not followed by identifier char
elsif not Identifier_Char (C) then
null;
-- OK literal if digit followed by e/E followed by digit/sign.
-- We also allow underscore after the E, which is an error, but
-- better handled by Nlit than deciding this is an identifier.
elsif (C = 'e' or else C = 'E')
and then (Source (Scan_Ptr + 2) in '0' .. '9'
or else Source (Scan_Ptr + 2) = '+'
or else Source (Scan_Ptr + 2) = '-'
or else Source (Scan_Ptr + 2) = '_')
then
null;
-- Here we have what really looks like an identifier that
-- starts with a digit, so give error msg.
else
Error_Msg_S ("identifier may not start with digit");
Name_Len := 1;
Underline_Found := False;
Name_Buffer (1) := Source (Scan_Ptr);
Accumulate_Checksum (Name_Buffer (1));
Scan_Ptr := Scan_Ptr + 1;
goto Scan_Identifier;
end if;
end;
-- Here we have an OK integer literal
Nlit;
-- Check for proper delimiter, ignoring other format characters
Skip_Other_Format_Characters;
if Identifier_Char (Source (Scan_Ptr)) then
Error_Msg_S
("delimiter required between literal and identifier");
end if;
Post_Scan;
return;
-- Lower case letters
when 'a' .. 'z' =>
Name_Len := 1;
Underline_Found := False;
Name_Buffer (1) := Source (Scan_Ptr);
Accumulate_Checksum (Name_Buffer (1));
Scan_Ptr := Scan_Ptr + 1;
goto Scan_Identifier;
-- Upper case letters
when 'A' .. 'Z' =>
Name_Len := 1;
Underline_Found := False;
Name_Buffer (1) :=
Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
Accumulate_Checksum (Name_Buffer (1));
Scan_Ptr := Scan_Ptr + 1;
goto Scan_Identifier;
-- Underline character
when '_' =>
if Special_Characters ('_') then
Token_Ptr := Scan_Ptr;
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Special;
Special_Character := '_';
return;
end if;
Error_Msg_S ("identifier cannot start with underline");
Name_Len := 1;
Name_Buffer (1) := '_';
Scan_Ptr := Scan_Ptr + 1;
Underline_Found := False;
goto Scan_Identifier;
-- Space (not possible, because we scanned past blanks)
when ' ' =>
raise Program_Error;
-- Characters in top half of ASCII 8-bit chart
when Upper_Half_Character =>
-- Wide character case
if Upper_Half_Encoding then
goto Scan_Wide_Character;
-- Otherwise we have OK Latin-1 character
else
-- Upper half characters may possibly be identifier letters
-- but can never be digits, so Identifier_Char can be used to
-- test for a valid start of identifier character.
if Identifier_Char (Source (Scan_Ptr)) then
Name_Len := 0;
Underline_Found := False;
goto Scan_Identifier;
else
Error_Illegal_Character;
end if;
end if;
when ESC =>
-- ESC character, possible start of identifier if wide characters
-- using ESC encoding are allowed in identifiers, which we can
-- tell by looking at the Identifier_Char flag for ESC, which is
-- only true if these conditions are met. In Ada 2005 mode, may
-- also be valid UTF_32 space or line terminator character.
if Identifier_Char (ESC) then
Name_Len := 0;
goto Scan_Wide_Character;
else
Error_Illegal_Character;
end if;
-- Invalid control characters
when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | ASCII.SO |
SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
EM | FS | GS | RS | US | DEL
=>
Error_Illegal_Character;
-- Invalid graphic characters
when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' =>
-- If Set_Special_Character has been called for this character,
-- set Scans.Special_Character and return a Special token.
if Special_Characters (Source (Scan_Ptr)) then
Token_Ptr := Scan_Ptr;
Token := Tok_Special;
Special_Character := Source (Scan_Ptr);
Scan_Ptr := Scan_Ptr + 1;
return;
-- Check for something looking like a preprocessor directive
elsif Source (Scan_Ptr) = '#'
and then (Source (Scan_Ptr + 1 .. Scan_Ptr + 2) = "if"
or else
Source (Scan_Ptr + 1 .. Scan_Ptr + 5) = "elsif"
or else
Source (Scan_Ptr + 1 .. Scan_Ptr + 4) = "else"
or else
Source (Scan_Ptr + 1 .. Scan_Ptr + 3) = "end")
then
Error_Msg_S
("preprocessor directive ignored, preprocessor not active");
-- Skip to end of line
loop
if Source (Scan_Ptr) in Graphic_Character
or else
Source (Scan_Ptr) = HT
then
Scan_Ptr := Scan_Ptr + 1;
-- Done if line terminator or EOF
elsif Source (Scan_Ptr) in Line_Terminator
or else
Source (Scan_Ptr) = EOF
then
exit;
-- If we have a wide character, we have to scan it out,
-- because it might be a legitimate line terminator
elsif Start_Of_Wide_Character then
declare
Wptr : constant Source_Ptr := Scan_Ptr;
Code : Char_Code;
Err : Boolean;
begin
Scan_Wide (Source, Scan_Ptr, Code, Err);
-- If not well formed wide character, then just skip
-- past it and ignore it.
if Err then
Scan_Ptr := Wptr + 1;
-- If UTF_32 terminator, terminate comment scan
elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then
Scan_Ptr := Wptr;
exit;
end if;
end;
-- Else keep going (don't worry about bad comment chars
-- in this context, we just want to find the end of line.
else
Scan_Ptr := Scan_Ptr + 1;
end if;
end loop;
-- Otherwise, this is an illegal character
else
Error_Illegal_Character;
end if;
-- End switch on non-blank character
end case;
-- End loop past format effectors. The exit from this loop is by
-- executing a return statement following completion of token scan
-- (control never falls out of this loop to the code which follows)
end loop;
-- Wide_Character scanning routine. On entry we have encountered the
-- initial character of a wide character sequence.
<>
declare
Code : Char_Code;
Cat : Category;
Err : Boolean;
begin
Wptr := Scan_Ptr;
Scan_Wide (Source, Scan_Ptr, Code, Err);
-- If bad wide character, signal error and continue scan
if Err then
Error_Illegal_Wide_Character;
goto Scan_Next_Character;
end if;
Cat := Get_Category (UTF_32 (Code));
-- If OK letter, reset scan ptr and go scan identifier
if Is_UTF_32_Letter (Cat) then
Scan_Ptr := Wptr;
Name_Len := 0;
Underline_Found := False;
goto Scan_Identifier;
-- If OK wide space, ignore and keep scanning (we do not include
-- any ignored spaces in checksum)
elsif Is_UTF_32_Space (Cat) then
goto Scan_Next_Character;
-- If other format character, ignore and keep scanning (again we
-- do not include in the checksum) (this is for AI-0079).
elsif Is_UTF_32_Other (Cat) then
goto Scan_Next_Character;
-- If OK wide line terminator, terminate current line
elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then
Scan_Ptr := Wptr;
goto Scan_Line_Terminator;
-- Punctuation is an error (at start of identifier)
elsif Is_UTF_32_Punctuation (Cat) then
Error_Msg ("identifier cannot start with punctuation", Wptr);
Scan_Ptr := Wptr;
Name_Len := 0;
Underline_Found := False;
goto Scan_Identifier;
-- Mark character is an error (at start of identifier)
elsif Is_UTF_32_Mark (Cat) then
Error_Msg ("identifier cannot start with mark character", Wptr);
Scan_Ptr := Wptr;
Name_Len := 0;
Underline_Found := False;
goto Scan_Identifier;
-- Extended digit character is an error. Could be bad start of
-- identifier or bad literal. Not worth doing too much to try to
-- distinguish these cases, but we will do a little bit.
elsif Is_UTF_32_Digit (Cat) then
Error_Msg
("identifier cannot start with digit character", Wptr);
Scan_Ptr := Wptr;
Name_Len := 0;
Underline_Found := False;
goto Scan_Identifier;
-- All other wide characters are illegal here
else
Error_Illegal_Wide_Character;
goto Scan_Next_Character;
end if;
end;
-- Routine to scan line terminator. On entry Scan_Ptr points to a
-- character which is one of FF,LR,CR,VT, or one of the wide characters
-- that is treated as a line terminator.
<>
-- Check line too long
Check_End_Of_Line;
-- Set Token_Ptr, if End_Of_Line is a token, for the case when it is
-- a physical line.
if End_Of_Line_Is_Token then
Token_Ptr := Scan_Ptr;
end if;
declare
Physical : Boolean;
begin
Skip_Line_Terminators (Scan_Ptr, Physical);
-- If we are at start of physical line, update scan pointers to
-- reflect the start of the new line.
if Physical then
Current_Line_Start := Scan_Ptr;
Start_Column := Set_Start_Column;
First_Non_Blank_Location := Scan_Ptr;
-- If End_Of_Line is a token, we return it as it is a
-- physical line.
if End_Of_Line_Is_Token then
Token := Tok_End_Of_Line;
return;
end if;
end if;
end;
goto Scan_Next_Character;
-- Identifier scanning routine. On entry, some initial characters of
-- the identifier may have already been stored in Name_Buffer. If so,
-- Name_Len has the number of characters stored, otherwise Name_Len is
-- set to zero on entry. Underline_Found is also set False on entry.
<>
-- This loop scans as fast as possible past lower half letters and
-- digits, which we expect to be the most common characters.
loop
if Source (Scan_Ptr) in 'a' .. 'z'
or else Source (Scan_Ptr) in '0' .. '9'
then
Name_Buffer (Name_Len + 1) := Source (Scan_Ptr);
Accumulate_Checksum (Source (Scan_Ptr));
elsif Source (Scan_Ptr) in 'A' .. 'Z' then
Name_Buffer (Name_Len + 1) :=
Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
Accumulate_Checksum (Name_Buffer (Name_Len + 1));
else
exit;
end if;
Underline_Found := False;
Scan_Ptr := Scan_Ptr + 1;
Name_Len := Name_Len + 1;
end loop;
-- If we fall through, then we have encountered either an underline
-- character, or an extended identifier character (i.e. one from the
-- upper half), or a wide character, or an identifier terminator. The
-- initial test speeds us up in the most common case where we have
-- an identifier terminator. Note that ESC is an identifier character
-- only if a wide character encoding method that uses ESC encoding
-- is active, so if we find an ESC character we know that we have a
-- wide character.
if Identifier_Char (Source (Scan_Ptr))
or else (Source (Scan_Ptr) in Upper_Half_Character
and then Upper_Half_Encoding)
then
-- Case of underline
if Source (Scan_Ptr) = '_' then
Accumulate_Checksum ('_');
if Underline_Found then
Error_No_Double_Underline;
else
Underline_Found := True;
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := '_';
end if;
Scan_Ptr := Scan_Ptr + 1;
goto Scan_Identifier;
-- Upper half character
elsif Source (Scan_Ptr) in Upper_Half_Character
and then not Upper_Half_Encoding
then
Accumulate_Checksum (Source (Scan_Ptr));
Store_Encoded_Character
(Get_Char_Code (Fold_Lower (Source (Scan_Ptr))));
Scan_Ptr := Scan_Ptr + 1;
Underline_Found := False;
goto Scan_Identifier;
-- Left bracket not followed by a quote terminates an identifier.
-- This is an error, but we don't want to give a junk error msg
-- about wide characters in this case.
elsif Source (Scan_Ptr) = '['
and then Source (Scan_Ptr + 1) /= '"'
then
null;
-- We know we have a wide character encoding here (the current
-- character is either ESC, left bracket, or an upper half
-- character depending on the encoding method).
else
-- Scan out the wide character and insert the appropriate
-- encoding into the name table entry for the identifier.
declare
Code : Char_Code;
Err : Boolean;
Chr : Character;
Cat : Category;
begin
Wptr := Scan_Ptr;
Scan_Wide (Source, Scan_Ptr, Code, Err);
-- If error, signal error
if Err then
Error_Illegal_Wide_Character;
-- If the character scanned is a normal identifier
-- character, then we treat it that way.
elsif In_Character_Range (Code)
and then Identifier_Char (Get_Character (Code))
then
Chr := Get_Character (Code);
Accumulate_Checksum (Chr);
Store_Encoded_Character
(Get_Char_Code (Fold_Lower (Chr)));
Underline_Found := False;
-- Here if not a normal identifier character
else
Cat := Get_Category (UTF_32 (Code));
-- Wide character in Unicode category "Other, Format"
-- is not accepted in an identifier. This is because it
-- it is considered a security risk (AI-0091).
-- However, it is OK for such a character to appear at
-- the end of an identifier.
if Is_UTF_32_Other (Cat) then
if not Identifier_Char (Source (Scan_Ptr)) then
goto Scan_Identifier_Complete;
else
Error_Msg
("identifier cannot contain other_format "
& "character", Wptr);
goto Scan_Identifier;
end if;
-- Wide character in category Separator,Space terminates
elsif Is_UTF_32_Space (Cat) then
goto Scan_Identifier_Complete;
end if;
-- Here if wide character is part of the identifier
-- Make sure we are allowing wide characters in
-- identifiers. Note that we allow wide character
-- notation for an OK identifier character. This in
-- particular allows bracket or other notation to be
-- used for upper half letters.
-- Wide characters are always allowed in Ada 2005
if Identifier_Character_Set /= 'w'
and then Ada_Version < Ada_2005
then
Error_Msg
("wide character not allowed in identifier", Wptr);
end if;
-- If OK letter, store it folding to upper case. Note
-- that we include the folded letter in the checksum.
if Is_UTF_32_Letter (Cat) then
Code :=
Char_Code (UTF_32_To_Upper_Case (UTF_32 (Code)));
Accumulate_Checksum (Code);
Store_Encoded_Character (Code);
Underline_Found := False;
-- If OK extended digit or mark, then store it
elsif Is_UTF_32_Digit (Cat)
or else Is_UTF_32_Mark (Cat)
then
Accumulate_Checksum (Code);
Store_Encoded_Character (Code);
Underline_Found := False;
-- Wide punctuation is also stored, but counts as an
-- underline character for error checking purposes.
elsif Is_UTF_32_Punctuation (Cat) then
Accumulate_Checksum (Code);
if Underline_Found then
declare
Cend : constant Source_Ptr := Scan_Ptr;
begin
Scan_Ptr := Wptr;
Error_No_Double_Underline;
Scan_Ptr := Cend;
end;
else
Store_Encoded_Character (Code);
Underline_Found := True;
end if;
-- Any other wide character is not acceptable
else
Error_Msg
("invalid wide character in identifier", Wptr);
end if;
end if;
goto Scan_Identifier;
end;
end if;
end if;
-- Scan of identifier is complete. The identifier is stored in
-- Name_Buffer, and Scan_Ptr points past the last character.
<>
Token_Name := Name_Find;
-- Check for identifier ending with underline or punctuation char
if Underline_Found then
Underline_Found := False;
if Source (Scan_Ptr - 1) = '_' then
Error_Msg
("identifier cannot end with underline", Scan_Ptr - 1);
else
Error_Msg
("identifier cannot end with punctuation character", Wptr);
end if;
end if;
-- We will assume it is an identifier, not a keyword, so that the
-- checksum is independent of the Ada version.
Token := Tok_Identifier;
-- Here is where we check if it was a keyword
if Is_Keyword_Name (Token_Name) then
if Opt.Checksum_GNAT_6_3 then
Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
if Checksum_Accumulate_Token_Checksum then
if Checksum_GNAT_5_03 then
Accumulate_Token_Checksum_GNAT_5_03;
else
Accumulate_Token_Checksum_GNAT_6_3;
end if;
end if;
else
Accumulate_Token_Checksum;
Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
end if;
-- Keyword style checks
if Style_Check then
-- Deal with possible style check for non-lower case keyword,
-- but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords
-- for this purpose if they appear as attribute designators.
-- Actually we only check the first character for speed.
-- Ada 2005 (AI-284): Do not apply the style check in case of
-- "pragma Interface"
-- Ada 2005 (AI-340): Do not apply the style check in case of
-- MOD attribute.
if Source (Token_Ptr) <= 'Z'
and then (Prev_Token /= Tok_Apostrophe
or else
(Token /= Tok_Access and then
Token /= Tok_Delta and then
Token /= Tok_Digits and then
Token /= Tok_Mod and then
Token /= Tok_Range))
and then (Token /= Tok_Interface
or else
(Token = Tok_Interface
and then Prev_Token /= Tok_Pragma))
then
Style.Non_Lower_Case_Keyword;
end if;
-- Check THEN/ELSE style rules. These do not apply to AND THEN
-- or OR ELSE, and do not apply in if expressions.
if (Token = Tok_Then and then Prev_Token /= Tok_And)
or else
(Token = Tok_Else and then Prev_Token /= Tok_Or)
then
if Inside_If_Expression = 0 then
Style.Check_Separate_Stmt_Lines;
end if;
end if;
end if;
-- We must reset Token_Name since this is not an identifier and
-- if we leave Token_Name set, the parser gets confused because
-- it thinks it is dealing with an identifier instead of the
-- corresponding keyword.
Token_Name := No_Name;
return;
-- It is an identifier after all
else
if Checksum_Accumulate_Token_Checksum then
Accumulate_Token_Checksum;
end if;
Post_Scan;
return;
end if;
end Scan;
--------------------------
-- Set_Comment_As_Token --
--------------------------
procedure Set_Comment_As_Token (Value : Boolean) is
begin
Comment_Is_Token := Value;
end Set_Comment_As_Token;
------------------------------
-- Set_End_Of_Line_As_Token --
------------------------------
procedure Set_End_Of_Line_As_Token (Value : Boolean) is
begin
End_Of_Line_Is_Token := Value;
end Set_End_Of_Line_As_Token;
---------------------------
-- Set_Special_Character --
---------------------------
procedure Set_Special_Character (C : Character) is
begin
case C is
when '#' | '$' | '_' | '?' | '@' | '`' | '\' | '^' | '~' =>
Special_Characters (C) := True;
when others =>
null;
end case;
end Set_Special_Character;
----------------------
-- Set_Start_Column --
----------------------
-- Note: it seems at first glance a little expensive to compute this value
-- for every source line (since it is certainly not used for all source
-- lines). On the other hand, it doesn't take much more work to skip past
-- the initial white space on the line counting the columns than it would
-- to scan past the white space using the standard scanning circuits.
function Set_Start_Column return Column_Number is
Start_Column : Column_Number := 0;
begin
-- Outer loop scans past horizontal tab characters
Tabs_Loop : loop
-- Inner loop scans past blanks as fast as possible, bumping Scan_Ptr
-- past the blanks and adjusting Start_Column to account for them.
Blanks_Loop : loop
if Source (Scan_Ptr) = ' ' then
if Source (Scan_Ptr + 1) = ' ' then
if Source (Scan_Ptr + 2) = ' ' then
if Source (Scan_Ptr + 3) = ' ' then
if Source (Scan_Ptr + 4) = ' ' then
if Source (Scan_Ptr + 5) = ' ' then
if Source (Scan_Ptr + 6) = ' ' then
Scan_Ptr := Scan_Ptr + 7;
Start_Column := Start_Column + 7;
else
Scan_Ptr := Scan_Ptr + 6;
Start_Column := Start_Column + 6;
exit Blanks_Loop;
end if;
else
Scan_Ptr := Scan_Ptr + 5;
Start_Column := Start_Column + 5;
exit Blanks_Loop;
end if;
else
Scan_Ptr := Scan_Ptr + 4;
Start_Column := Start_Column + 4;
exit Blanks_Loop;
end if;
else
Scan_Ptr := Scan_Ptr + 3;
Start_Column := Start_Column + 3;
exit Blanks_Loop;
end if;
else
Scan_Ptr := Scan_Ptr + 2;
Start_Column := Start_Column + 2;
exit Blanks_Loop;
end if;
else
Scan_Ptr := Scan_Ptr + 1;
Start_Column := Start_Column + 1;
exit Blanks_Loop;
end if;
else
exit Blanks_Loop;
end if;
end loop Blanks_Loop;
-- Outer loop keeps going only if a horizontal tab follows
if Source (Scan_Ptr) = HT then
if Style_Check then
Style.Check_HT;
end if;
Scan_Ptr := Scan_Ptr + 1;
Start_Column := (Start_Column / 8) * 8 + 8;
else
exit Tabs_Loop;
end if;
end loop Tabs_Loop;
return Start_Column;
-- A constraint error can happen only if we have a compiler with checks on
-- and a line with a ludicrous number of tabs or spaces at the start. In
-- such a case, we really don't care if Start_Column is right or not.
exception
when Constraint_Error =>
return Start_Column;
end Set_Start_Column;
end Scng;
gprbuild-gpl-2014-src/gnat/sdefault.ads 0000644 0000767 0000145 00000004613 12323721731 017370 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S D E F A U L T --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2012, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package contains functions that return the default values for the
-- include and object file directories, target name, default library
-- subdirectory (libsubdir) prefix, and the target OS. The body is generated
-- automatically by the build process.
with Types; use Types;
package Sdefault is
function Include_Dir_Default_Name return String_Ptr;
function Object_Dir_Default_Name return String_Ptr;
function Target_Name return String_Ptr;
function Search_Dir_Prefix return String_Ptr;
end Sdefault;
gprbuild-gpl-2014-src/gnat/erroutc.ads 0000644 0000767 0000145 00000067141 12323721731 017251 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E R R O U T C --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This packages contains global variables and routines common to error
-- reporting packages, including Errout and Prj.Err.
with Table;
with Types; use Types;
package Erroutc is
Class_Flag : Boolean := False;
-- This flag is set True when outputting a reference to a class-wide
-- type, and is used by Add_Class to insert 'Class at the proper point
Continuation : Boolean := False;
-- Indicates if current message is a continuation. Initialized from the
-- Msg_Cont parameter in Error_Msg_Internal and then set True if a \
-- insertion character is encountered.
Continuation_New_Line : Boolean := False;
-- Indicates if current message was a continuation line marked with \\ to
-- force a new line. Set True if \\ encountered.
Flag_Source : Source_File_Index;
-- Source file index for source file where error is being posted
Has_Double_Exclam : Boolean := False;
-- Set true to indicate that the current message contains the insertion
-- sequence !! (force warnings even in non-main unit source files).
Is_Serious_Error : Boolean := False;
-- Set True for a serious error (i.e. any message that is not a warning
-- or style message, and that does not contain a | insertion character).
Is_Unconditional_Msg : Boolean := False;
-- Set True to indicate that the current message contains the insertion
-- character ! and is thus to be treated as an unconditional message.
Is_Warning_Msg : Boolean := False;
-- Set True to indicate if current message is warning message (contains ?
-- or contains < and Error_Msg_Warn is True.
Is_Info_Msg : Boolean := False;
-- Set True to indicate that the current message starts with the characters
-- "info: " and is to be treated as an information message. This string
-- will be prepended to the message and all its continuations.
Warning_Msg_Char : Character;
-- Warning character, valid only if Is_Warning_Msg is True
-- ' ' -- ? or < appeared on its own in message
-- '?' -- ?? or << appeared in message
-- 'x' -- ?x? or Error_Msg_Object,
Table_Index_Type => Error_Msg_Id,
Table_Low_Bound => 1,
Table_Initial => 200,
Table_Increment => 200,
Table_Name => "Error");
First_Error_Msg : Error_Msg_Id;
-- The list of error messages, i.e. the first entry on the list of error
-- messages. This is not the same as the physically first entry in the
-- error message table, since messages are not always inserted in sequence.
Last_Error_Msg : Error_Msg_Id;
-- The last entry on the list of error messages. Note: this is not the same
-- as the physically last entry in the error message table, since messages
-- are not always inserted in sequence.
--------------------------
-- Warning Mode Control --
--------------------------
-- Pragma Warnings allows warnings to be turned off for a specified region
-- of code, and the following tables are the data structures used to keep
-- track of these regions.
-- The first table is used for the basic command line control, and for the
-- forms of Warning with a single ON or OFF parameter.
-- It contains pairs of source locations, the first being the start
-- location for a warnings off region, and the second being the end
-- location. When a pragma Warnings (Off) is encountered, a new entry is
-- established extending from the location of the pragma to the end of the
-- current source file. A subsequent pragma Warnings (On) adjusts the end
-- point of this entry appropriately.
-- If all warnings are suppressed by command switch, then there is a dummy
-- entry (put there by Errout.Initialize) at the start of the table which
-- covers all possible Source_Ptr values. Note that the source pointer
-- values in this table always reference the original template, not an
-- instantiation copy, in the generic case.
-- Reason is the reason from the pragma Warnings (Off,..) or the null
-- string if no reason parameter is given.
type Warnings_Entry is record
Start : Source_Ptr;
Stop : Source_Ptr;
Reason : String_Id;
end record;
package Warnings is new Table.Table (
Table_Component_Type => Warnings_Entry,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 100,
Table_Increment => 200,
Table_Name => "Warnings");
-- The second table is used for the specific forms of the pragma, where
-- the first argument is ON or OFF, and the second parameter is a string
-- which is the pattern to match for suppressing a warning.
type Specific_Warning_Entry is record
Start : Source_Ptr;
Stop : Source_Ptr;
-- Starting and ending source pointers for the range. These are always
-- from the same source file.
Reason : String_Id;
-- Reason string from pragma Warnings, or null string if none
Msg : String_Ptr;
-- Message from pragma Warnings (Off, string)
Open : Boolean;
-- Set to True if OFF has been encountered with no matching ON
Used : Boolean;
-- Set to True if entry has been used to suppress a warning
Config : Boolean;
-- True if pragma is configuration pragma (in which case no matching Off
-- pragma is required, and it is not required that a specific warning be
-- suppressed).
end record;
package Specific_Warnings is new Table.Table (
Table_Component_Type => Specific_Warning_Entry,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 100,
Table_Increment => 200,
Table_Name => "Specific_Warnings");
-- Note on handling configuration case versus specific case. A complication
-- arises from this example:
-- pragma Warnings (Off, "not referenced*");
-- procedure Mumble (X : Integer) is
-- pragma Warnings (On, "not referenced*");
-- begin
-- null;
-- end Mumble;
-- The trouble is that the first pragma is technically a configuration
-- pragma, and yet it is clearly being used in the context of thinking of
-- it as a specific case. To deal with this, what we do is that the On
-- entry can match a configuration pragma from the same file, and if we
-- find such an On entry, we cancel the indication of it being the
-- configuration case. This seems to handle all cases we run into ok.
-----------------
-- Subprograms --
-----------------
procedure Add_Class;
-- Add 'Class to buffer for class wide type case (Class_Flag set)
function Buffer_Ends_With (C : Character) return Boolean;
-- Tests if message buffer ends with given character
function Buffer_Ends_With (S : String) return Boolean;
-- Tests if message buffer ends with given string preceded by a space
procedure Buffer_Remove (C : Character);
-- Remove given character fron end of buffer if it is present
procedure Buffer_Remove (S : String);
-- Removes given string from end of buffer if it is present at end of
-- buffer, and preceded by a space.
function Compilation_Errors return Boolean;
-- Returns true if errors have been detected, or warnings in -gnatwe
-- (treat warnings as errors) mode.
procedure dmsg (Id : Error_Msg_Id);
-- Debugging routine to dump an error message
procedure Debug_Output (N : Node_Id);
-- Called from Error_Msg_N and Error_Msg_NE to generate line of debug
-- output giving node number (of node N) if the debug X switch is set.
procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id);
-- This function is passed the Id values of two error messages. If either
-- M1 or M2 is a continuation message, or is already deleted, the call is
-- ignored. Otherwise a check is made to see if M1 and M2 are duplicated or
-- redundant. If so, the message to be deleted and all its continuations
-- are marked with the Deleted flag set to True.
function Get_Warning_Tag (Id : Error_Msg_Id) return String;
-- Given an error message ID, return tag showing warning message class, or
-- the null string if this option is not enabled or this is not a warning.
procedure Output_Error_Msgs (E : in out Error_Msg_Id);
-- Output source line, error flag, and text of stored error message and all
-- subsequent messages for the same line and unit. On return E is set to be
-- one higher than the last message output.
procedure Output_Line_Number (L : Logical_Line_Number);
-- Output a line number as six digits (with leading zeroes suppressed),
-- followed by a period and a blank (note that this is 8 characters which
-- means that tabs in the source line will not get messed up). Line numbers
-- that match or are less than the last Source_Reference pragma are listed
-- as all blanks, avoiding output of junk line numbers.
procedure Output_Msg_Text (E : Error_Msg_Id);
-- Outputs characters of text in the text of the error message E. Note that
-- no end of line is output, the caller is responsible for adding the end
-- of line. If Error_Msg_Line_Length is non-zero, this is the routine that
-- splits the line generating multiple lines of output, and in this case
-- the last line has no terminating end of line character.
procedure Prescan_Message (Msg : String);
-- Scans message text and sets the following variables:
--
-- Is_Warning_Msg is set True if Msg is a warning message (contains a
-- question mark character), and False otherwise.
--
-- Is_Style_Msg is set True if Msg is a style message (starts with
-- "(style)") and False otherwise.
--
-- Is_Info_Msg is set True if Msg is an information message (starts
-- with "info: ". Such messages must contain a ? sequence since they
-- are also considered to be warning messages, and get a tag.
--
-- Is_Serious_Error is set to True unless the message is a warning or
-- style message or contains the character | (non-serious error).
--
-- Is_Unconditional_Msg is set True if the message contains the character
-- ! and is otherwise set False.
--
-- Has_Double_Exclam is set True if the message contains the sequence !!
-- and is otherwise set False.
--
-- We need to know right away these aspects of a message, since we will
-- test these values before doing the full error scan.
--
-- Note that the call has no effect for continuation messages (those whose
-- first character is '\'), and all variables are left unchanged.
procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr);
-- All error messages whose location is in the range From .. To (not
-- including the end points) will be deleted from the error listing.
function Same_Error (M1, M2 : Error_Msg_Id) return Boolean;
-- See if two messages have the same text. Returns true if the text of the
-- two messages is identical, or if one of them is the same as the other
-- with an appended "instance at xxx" tag.
procedure Set_Msg_Blank;
-- Sets a single blank in the message if the preceding character is a
-- non-blank character other than a left parenthesis or minus. Has no
-- effect if manual quote mode is turned on.
procedure Set_Msg_Blank_Conditional;
-- Sets a single blank in the message if the preceding character is a
-- non-blank character other than a left parenthesis or quote. Has no
-- effect if manual quote mode is turned on.
procedure Set_Msg_Char (C : Character);
-- Add a single character to the current message. This routine does not
-- check for special insertion characters (they are just treated as text
-- characters if they occur).
procedure Set_Msg_Insertion_File_Name;
-- Handle file name insertion (left brace insertion character)
procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr);
-- Handle line number insertion (# insertion character). Loc is the
-- location to be referenced, and Flag is the location at which the
-- flag is posted (used to determine whether to add "in file xxx")
procedure Set_Msg_Insertion_Name_Literal;
procedure Set_Msg_Insertion_Name;
-- Handle name insertion (% insertion character)
procedure Set_Msg_Insertion_Reserved_Name;
-- Handle insertion of reserved word name (* insertion character)
procedure Set_Msg_Insertion_Reserved_Word
(Text : String;
J : in out Integer);
-- Handle reserved word insertion (upper case letters). The Text argument
-- is the current error message input text, and J is an index which on
-- entry points to the first character of the reserved word, and on exit
-- points past the last character of the reserved word. Note that RM and
-- SPARK are treated specially and not considered to be keywords.
procedure Set_Msg_Insertion_Run_Time_Name;
-- If package System contains a definition for Run_Time_Name (see package
-- Targparm for details), then this procedure will insert a message of
-- the form (name) into the current error message, with name set in mixed
-- case (upper case after any spaces). If no run time name is defined,
-- then this routine has no effect).
procedure Set_Msg_Insertion_Uint;
-- Handle Uint insertion (^ insertion character)
procedure Set_Msg_Int (Line : Int);
-- Set the decimal representation of the argument in the error message
-- buffer with no leading zeroes output.
procedure Set_Msg_Name_Buffer;
-- Output name from Name_Buffer, with surrounding quotes unless manual
-- quotation mode is in effect.
procedure Set_Msg_Quote;
-- Set quote if in normal quote mode, nothing if in manual quote mode
procedure Set_Msg_Str (Text : String);
-- Add a sequence of characters to the current message. This routine does
-- not check for special insertion characters (they are just treated as
-- text characters if they occur).
procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id);
-- Given a message id, move to next message id, but skip any deleted
-- messages, so that this results in E on output being the first non-
-- deleted message following the input value of E, or No_Error_Msg if
-- the input value of E was either already No_Error_Msg, or was the
-- last non-deleted message.
procedure Set_Specific_Warning_Off
(Loc : Source_Ptr;
Msg : String;
Reason : String_Id;
Config : Boolean;
Used : Boolean := False);
-- This is called in response to the two argument form of pragma Warnings
-- where the first argument is OFF, and the second argument is a string
-- which identifies a specific warning to be suppressed. The first argument
-- is the start of the suppression range, and the second argument is the
-- string from the pragma. Loc is the location of the pragma (which is the
-- start of the range to suppress). Reason is the reason string from the
-- pragma, or the null string if no reason is given. Config is True for the
-- configuration pragma case (where there is no requirement for a matching
-- OFF pragma). Used is set True to disable the check that the warning
-- actually has has the effect of suppressing a warning.
procedure Set_Specific_Warning_On
(Loc : Source_Ptr;
Msg : String;
Err : out Boolean);
-- This is called in response to the two argument form of pragma Warnings
-- where the first argument is ON, and the second argument is a string
-- which identifies a specific warning to be suppressed. The first argument
-- is the end of the suppression range, and the second argument is the
-- string from the pragma. Err is set to True on return to report the error
-- of no matching Warnings Off pragma preceding this one.
procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id);
-- Called in response to a pragma Warnings (Off) to record the source
-- location from which warnings are to be turned off. Reason is the
-- Reason from the pragma, or the null string if none is given.
procedure Set_Warnings_Mode_On (Loc : Source_Ptr);
-- Called in response to a pragma Warnings (On) to record the source
-- location from which warnings are to be turned back on.
function Warnings_Suppressed (Loc : Source_Ptr) return String_Id;
-- Determines if given location is covered by a warnings off suppression
-- range in the warnings table (or is suppressed by compilation option,
-- which generates a warning range for the whole source file). This routine
-- only deals with the general ON/OFF case, not specific warnings. The
-- returned result is No_String if warnings are not suppressed. If warnings
-- are suppressed for the given location, then then corresponding Reason
-- parameter from the pragma is returned (or the null string if no Reason
-- parameter was present).
function Warning_Specifically_Suppressed
(Loc : Source_Ptr;
Msg : String_Ptr;
Tag : String := "") return String_Id;
-- Determines if given message to be posted at given location is suppressed
-- by specific ON/OFF Warnings pragmas specifying this particular message.
-- If the warning is not suppressed then No_String is returned, otherwise
-- the corresponding warning string is returned (or the null string if no
-- Warning argument was present in the pragma). Tag is the error message
-- tag for the message in question or the null string if there is no tag.
--
-- Note: we have a null default for Tag to deal with calls from an old
-- branch of gnat2why, which does not know about tags in the calls but
-- which uses the latest version of erroutc.
function Warning_Treated_As_Error (Msg : String) return Boolean;
-- Returns True if the warning message Msg matches any of the strings
-- given by Warning_As_Error pragmas, as stored in the Warnings_As_Errors
-- table by Set_Warning_As_Error.
type Error_Msg_Proc is
access procedure (Msg : String; Flag_Location : Source_Ptr);
procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc);
-- Checks that specific warnings are consistent (for non-configuration
-- case, properly closed, and used). The argument is a pointer to the
-- Error_Msg procedure to be called if any inconsistencies are detected.
end Erroutc;
gprbuild-gpl-2014-src/gnat/styleg.ads 0000644 0000767 0000145 00000020300 12323721731 017057 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S T Y L E G --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This generic package collects the routines used for style checking, as
-- activated by the relevant command line option. These are gathered in
-- a separate package so that they can more easily be customized. Calls
-- to these subprograms are only made if Opt.Style_Check is set True.
-- Styleg does not depends on the GNAT tree (Atree, Sinfo, ...).
with Types; use Types;
generic
with procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
-- Output a message at specified location
with procedure Error_Msg_S (Msg : String);
-- Output a message at current scan pointer location
with procedure Error_Msg_SC (Msg : String);
-- Output a message at the start of the current token
with procedure Error_Msg_SP (Msg : String);
-- Output a message at the start of the previous token
package Styleg is
procedure Check_Abs_Not;
-- Called after scanning an ABS or NOT operator to check spacing
procedure Check_Apostrophe;
-- Called after scanning an apostrophe to check spacing
procedure Check_Arrow;
-- Called after scanning out an arrow to check spacing
procedure Check_Attribute_Name (Reserved : Boolean);
-- The current token is an attribute designator. Check that it
-- is capitalized in an appropriate manner. Reserved is set if
-- the attribute designator is a reserved word (access, digits,
-- delta or range) to allow differing rules for the two cases.
procedure Check_Boolean_Operator (Node : Node_Id);
-- Node is a node for an AND or OR operator. Check that the usage meets
-- the style rules.
procedure Check_Box;
-- Called after scanning out a box to check spacing
procedure Check_Binary_Operator;
-- Called after scanning out a binary operator other than a plus, minus
-- or exponentiation operator. Intended for checking spacing rules.
procedure Check_Exponentiation_Operator;
-- Called after scanning out an exponentiation operator. Intended for
-- checking spacing rules.
procedure Check_Colon;
-- Called after scanning out colon to check spacing
procedure Check_Colon_Equal;
-- Called after scanning out colon equal to check spacing
procedure Check_Comma;
-- Called after scanning out comma to check spacing
procedure Check_Comment;
-- Called with Scan_Ptr pointing to the first minus sign of a comment.
-- Intended for checking any specific rules for comment placement/format.
procedure Check_Dot_Dot;
-- Called after scanning out dot dot to check spacing
procedure Check_EOF;
-- Called after scanning out EOF mark
procedure Check_HT;
-- Called with Scan_Ptr pointing to a horizontal tab character
procedure Check_Indentation;
-- Called at the start of a new statement or declaration, with Token_Ptr
-- pointing to the first token of the statement or declaration. The check
-- is that the starting column is appropriate to the indentation rules if
-- Token_Ptr is the first token on the line.
procedure Check_Left_Paren;
-- Called after scanning out a left parenthesis to check spacing
procedure Check_Line_Max_Length (Len : Int);
-- Called with Scan_Ptr pointing to the first line terminator character
-- terminating the current line. Used to check for appropriate line length.
-- The parameter Len is the length of the current line.
procedure Check_Line_Terminator (Len : Int);
-- Called with Scan_Ptr pointing to the first line terminator terminating
-- the current line, used to check for appropriate line terminator usage.
-- The parameter Len is the length of the current line.
procedure Check_Not_In;
-- Called with Scan_Ptr pointing to an IN token, and Prev_Token_Ptr
-- pointing to a NOT token. Used to check proper layout of NOT IN.
procedure Check_Pragma_Name;
-- The current token is a pragma identifier. Check that it is spelled
-- properly (i.e. with an appropriate casing convention).
procedure Check_Right_Paren;
-- Called after scanning out a right parenthesis to check spacing
procedure Check_Semicolon;
-- Called after scanning out a semicolon to check spacing
procedure Check_Then (If_Loc : Source_Ptr);
-- Called to check that THEN and IF keywords are appropriately positioned.
-- The parameters show the first characters of the two keywords. This
-- procedure is called with Token_Ptr pointing to the THEN keyword.
procedure Check_Separate_Stmt_Lines;
pragma Inline (Check_Separate_Stmt_Lines);
-- Called after scanning THEN (not preceded by AND) or ELSE (not preceded
-- by OR). Used to check that no tokens follow on the same line (which
-- would interfere with coverage testing). Handles case of THEN ABORT as
-- an exception, as well as PRAGMA after ELSE.
procedure Check_Unary_Plus_Or_Minus;
-- Called after scanning a unary plus or minus to check spacing
procedure Check_Vertical_Bar;
-- Called after scanning a vertical bar to check spacing
procedure Check_Xtra_Parens (Loc : Source_Ptr);
-- Called after scanning an if, case, or quantified expression that has at
-- least one level of parentheses around the entire expression.
function Mode_In_Check return Boolean;
pragma Inline (Mode_In_Check);
-- Determines whether style checking is active and the Mode_In_Check is
-- set, forbidding the explicit use of mode IN.
procedure No_End_Name (Name : Node_Id);
-- Called if an END is encountered where a name is allowed but not present.
-- The parameter is the node whose name is the name that is permitted in
-- the END line, and the scan pointer is positioned so that if an error
-- message is to be generated in this situation, it should be generated
-- using Error_Msg_SP.
procedure No_Exit_Name (Name : Node_Id);
-- Called when exiting a named loop, but a name is not present on the EXIT.
-- The parameter is the node whose name should have followed EXIT, and the
-- scan pointer is positioned so that if an error message is to be
-- generated, it should be generated using Error_Msg_SP.
procedure Non_Lower_Case_Keyword;
-- Called if a reserved keyword is scanned which is not spelled in all
-- lower case letters. On entry Token_Ptr points to the keyword token.
-- This is not used for keywords appearing as attribute designators,
-- where instead Check_Attribute_Name (True) is called.
end Styleg;
gprbuild-gpl-2014-src/gnat/makeutl.adb 0000644 0000767 0000145 00000346303 12323721731 017207 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M A K E U T L --
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2014, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with ALI; use ALI;
with Atree; use Atree;
with Debug;
with Err_Vars; use Err_Vars;
with Errutil;
with Fname;
with Hostparm;
with Osint; use Osint;
with Output; use Output;
with Opt; use Opt;
with Prj.Com;
with Prj.Err;
with Prj.Ext;
with Prj.Util; use Prj.Util;
with Sinput.P;
with Tempdir;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Unchecked_Deallocation;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.HTable;
with GNAT.Regexp; use GNAT.Regexp;
package body Makeutl is
type Linker_Options_Data is record
Project : Project_Id;
Options : String_List_Id;
end record;
Linker_Option_Initial_Count : constant := 20;
Linker_Options_Buffer : String_List_Access :=
new String_List (1 .. Linker_Option_Initial_Count);
Last_Linker_Option : Natural := 0;
package Linker_Opts is new Table.Table (
Table_Component_Type => Linker_Options_Data,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Make.Linker_Opts");
procedure Add_Linker_Option (Option : String);
---------
-- Add --
---------
procedure Add
(Option : String_Access;
To : in out String_List_Access;
Last : in out Natural)
is
begin
if Last = To'Last then
declare
New_Options : constant String_List_Access :=
new String_List (1 .. To'Last * 2);
begin
New_Options (To'Range) := To.all;
-- Set all elements of the original options to null to avoid
-- deallocation of copies.
To.all := (others => null);
Free (To);
To := New_Options;
end;
end if;
Last := Last + 1;
To (Last) := Option;
end Add;
procedure Add
(Option : String;
To : in out String_List_Access;
Last : in out Natural)
is
begin
Add (Option => new String'(Option), To => To, Last => Last);
end Add;
-----------------------
-- Add_Linker_Option --
-----------------------
procedure Add_Linker_Option (Option : String) is
begin
if Option'Length > 0 then
if Last_Linker_Option = Linker_Options_Buffer'Last then
declare
New_Buffer : constant String_List_Access :=
new String_List
(1 .. Linker_Options_Buffer'Last +
Linker_Option_Initial_Count);
begin
New_Buffer (Linker_Options_Buffer'Range) :=
Linker_Options_Buffer.all;
Linker_Options_Buffer.all := (others => null);
Free (Linker_Options_Buffer);
Linker_Options_Buffer := New_Buffer;
end;
end if;
Last_Linker_Option := Last_Linker_Option + 1;
Linker_Options_Buffer (Last_Linker_Option) := new String'(Option);
end if;
end Add_Linker_Option;
-------------------
-- Absolute_Path --
-------------------
function Absolute_Path
(Path : Path_Name_Type;
Project : Project_Id) return String
is
begin
Get_Name_String (Path);
declare
Path_Name : constant String := Name_Buffer (1 .. Name_Len);
begin
if Is_Absolute_Path (Path_Name) then
return Path_Name;
else
declare
Parent_Directory : constant String :=
Get_Name_String
(Project.Directory.Display_Name);
begin
return Parent_Directory & Path_Name;
end;
end if;
end;
end Absolute_Path;
----------------------------
-- Aggregate_Libraries_In --
----------------------------
function Aggregate_Libraries_In (Tree : Project_Tree_Ref) return Boolean is
List : Project_List;
begin
List := Tree.Projects;
while List /= null loop
if List.Project.Qualifier = Aggregate_Library then
return True;
end if;
List := List.Next;
end loop;
return False;
end Aggregate_Libraries_In;
-------------------------
-- Base_Name_Index_For --
-------------------------
function Base_Name_Index_For
(Main : String;
Main_Index : Int;
Index_Separator : Character) return File_Name_Type
is
Result : File_Name_Type;
begin
Name_Len := 0;
Add_Str_To_Name_Buffer (Base_Name (Main));
-- Remove the extension, if any, that is the last part of the base name
-- starting with a dot and following some characters.
for J in reverse 2 .. Name_Len loop
if Name_Buffer (J) = '.' then
Name_Len := J - 1;
exit;
end if;
end loop;
-- Add the index info, if index is different from 0
if Main_Index > 0 then
Add_Char_To_Name_Buffer (Index_Separator);
declare
Img : constant String := Main_Index'Img;
begin
Add_Str_To_Name_Buffer (Img (2 .. Img'Last));
end;
end if;
Result := Name_Find;
return Result;
end Base_Name_Index_For;
------------------------------
-- Check_Source_Info_In_ALI --
------------------------------
function Check_Source_Info_In_ALI
(The_ALI : ALI_Id;
Tree : Project_Tree_Ref) return Name_Id
is
Result : Name_Id := No_Name;
Unit_Name : Name_Id;
begin
-- Loop through units
for U in ALIs.Table (The_ALI).First_Unit ..
ALIs.Table (The_ALI).Last_Unit
loop
-- Check if the file name is one of the source of the unit
Get_Name_String (Units.Table (U).Uname);
Name_Len := Name_Len - 2;
Unit_Name := Name_Find;
if File_Not_A_Source_Of (Tree, Unit_Name, Units.Table (U).Sfile) then
return No_Name;
end if;
if Result = No_Name then
Result := Unit_Name;
end if;
-- Loop to do same check for each of the withed units
for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop
declare
WR : ALI.With_Record renames Withs.Table (W);
begin
if WR.Sfile /= No_File then
Get_Name_String (WR.Uname);
Name_Len := Name_Len - 2;
Unit_Name := Name_Find;
if File_Not_A_Source_Of (Tree, Unit_Name, WR.Sfile) then
return No_Name;
end if;
end if;
end;
end loop;
end loop;
-- Loop to check subunits and replaced sources
for D in ALIs.Table (The_ALI).First_Sdep ..
ALIs.Table (The_ALI).Last_Sdep
loop
declare
SD : Sdep_Record renames Sdep.Table (D);
begin
Unit_Name := SD.Subunit_Name;
if Unit_Name = No_Name then
-- Check if this source file has been replaced by a source with
-- a different file name.
if Tree /= null and then Tree.Replaced_Source_Number > 0 then
declare
Replacement : constant File_Name_Type :=
Replaced_Source_HTable.Get
(Tree.Replaced_Sources, SD.Sfile);
begin
if Replacement /= No_File then
if Verbose_Mode then
Write_Line
("source file"
& Get_Name_String (SD.Sfile)
& " has been replaced by "
& Get_Name_String (Replacement));
end if;
return No_Name;
end if;
end;
end if;
-- Check that a dependent source for a unit that is from a
-- project is indeed a source of this unit.
Unit_Name := SD.Unit_Name;
if Unit_Name /= No_Name
and then not Fname.Is_Internal_File_Name (SD.Sfile)
and then File_Not_A_Source_Of (Tree, Unit_Name, SD.Sfile)
then
return No_Name;
end if;
else
-- For separates, the file is no longer associated with the
-- unit ("proc-sep.adb" is not associated with unit "proc.sep")
-- so we need to check whether the source file still exists in
-- the source tree: it will if it matches the naming scheme
-- (and then will be for the same unit).
if Find_Source
(In_Tree => Tree,
Project => No_Project,
Base_Name => SD.Sfile) = No_Source
then
-- If this is not a runtime file or if, when gnatmake switch
-- -a is used, we are not able to find this subunit in the
-- source directories, then recompilation is needed.
if not Fname.Is_Internal_File_Name (SD.Sfile)
or else
(Check_Readonly_Files
and then Full_Source_Name (SD.Sfile) = No_File)
then
if Verbose_Mode then
Write_Line
("While parsing ALI file, file "
& Get_Name_String (SD.Sfile)
& " is indicated as containing subunit "
& Get_Name_String (Unit_Name)
& " but this does not match what was found while"
& " parsing the project. Will recompile");
end if;
return No_Name;
end if;
end if;
end if;
end;
end loop;
return Result;
end Check_Source_Info_In_ALI;
--------------------------------
-- Create_Binder_Mapping_File --
--------------------------------
function Create_Binder_Mapping_File
(Project_Tree : Project_Tree_Ref) return Path_Name_Type
is
Mapping_Path : Path_Name_Type := No_Path;
Mapping_FD : File_Descriptor := Invalid_FD;
-- A File Descriptor for an eventual mapping file
ALI_Unit : Unit_Name_Type := No_Unit_Name;
-- The unit name of an ALI file
ALI_Name : File_Name_Type := No_File;
-- The file name of the ALI file
ALI_Project : Project_Id := No_Project;
-- The project of the ALI file
Bytes : Integer;
OK : Boolean := False;
Unit : Unit_Index;
Status : Boolean;
-- For call to Close
Iter : Source_Iterator := For_Each_Source
(In_Tree => Project_Tree,
Language => Name_Ada,
Encapsulated_Libs => False,
Locally_Removed => False);
Source : Prj.Source_Id;
begin
Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path);
Record_Temp_File (Project_Tree.Shared, Mapping_Path);
if Mapping_FD /= Invalid_FD then
OK := True;
loop
Source := Element (Iter);
exit when Source = No_Source;
Unit := Source.Unit;
if Source.Replaced_By /= No_Source
or else Unit = No_Unit_Index
or else Unit.Name = No_Name
then
ALI_Name := No_File;
-- If this is a body, put it in the mapping
elsif Source.Kind = Impl
and then Unit.File_Names (Impl) /= No_Source
and then Unit.File_Names (Impl).Project /= No_Project
then
Get_Name_String (Unit.Name);
Add_Str_To_Name_Buffer ("%b");
ALI_Unit := Name_Find;
ALI_Name :=
Lib_File_Name (Unit.File_Names (Impl).Display_File);
ALI_Project := Unit.File_Names (Impl).Project;
-- Otherwise, if this is a spec and there is no body, put it in
-- the mapping.
elsif Source.Kind = Spec
and then Unit.File_Names (Impl) = No_Source
and then Unit.File_Names (Spec) /= No_Source
and then Unit.File_Names (Spec).Project /= No_Project
then
Get_Name_String (Unit.Name);
Add_Str_To_Name_Buffer ("%s");
ALI_Unit := Name_Find;
ALI_Name :=
Lib_File_Name (Unit.File_Names (Spec).Display_File);
ALI_Project := Unit.File_Names (Spec).Project;
else
ALI_Name := No_File;
end if;
-- If we have something to put in the mapping then do it now. If
-- the project is extended, look for the ALI file in the project,
-- then in the extending projects in order, and use the last one
-- found.
if ALI_Name /= No_File then
-- Look in the project and the projects that are extending it
-- to find the real ALI file.
declare
ALI : constant String := Get_Name_String (ALI_Name);
ALI_Path : Name_Id := No_Name;
begin
loop
-- For library projects, use the library ALI directory,
-- for other projects, use the object directory.
if ALI_Project.Library then
Get_Name_String
(ALI_Project.Library_ALI_Dir.Display_Name);
else
Get_Name_String
(ALI_Project.Object_Directory.Display_Name);
end if;
Add_Str_To_Name_Buffer (ALI);
if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
ALI_Path := Name_Find;
end if;
ALI_Project := ALI_Project.Extended_By;
exit when ALI_Project = No_Project;
end loop;
if ALI_Path /= No_Name then
-- First line is the unit name
Get_Name_String (ALI_Unit);
Add_Char_To_Name_Buffer (ASCII.LF);
Bytes :=
Write
(Mapping_FD,
Name_Buffer (1)'Address,
Name_Len);
OK := Bytes = Name_Len;
exit when not OK;
-- Second line is the ALI file name
Get_Name_String (ALI_Name);
Add_Char_To_Name_Buffer (ASCII.LF);
Bytes :=
Write
(Mapping_FD,
Name_Buffer (1)'Address,
Name_Len);
OK := (Bytes = Name_Len);
exit when not OK;
-- Third line is the ALI path name
Get_Name_String (ALI_Path);
Add_Char_To_Name_Buffer (ASCII.LF);
Bytes :=
Write
(Mapping_FD,
Name_Buffer (1)'Address,
Name_Len);
OK := (Bytes = Name_Len);
-- 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;
end if;
Next (Iter);
end loop;
Close (Mapping_FD, Status);
OK := OK and Status;
end if;
-- If the creation of the mapping file was successful, we add the switch
-- to the arguments of gnatbind.
if OK then
return Mapping_Path;
else
return No_Path;
end if;
end Create_Binder_Mapping_File;
-----------------
-- Create_Name --
-----------------
function Create_Name (Name : String) return File_Name_Type is
begin
Name_Len := 0;
Add_Str_To_Name_Buffer (Name);
return Name_Find;
end Create_Name;
function Create_Name (Name : String) return Name_Id is
begin
Name_Len := 0;
Add_Str_To_Name_Buffer (Name);
return Name_Find;
end Create_Name;
function Create_Name (Name : String) return Path_Name_Type is
begin
Name_Len := 0;
Add_Str_To_Name_Buffer (Name);
return Name_Find;
end Create_Name;
---------------------------
-- Ensure_Absolute_Path --
---------------------------
procedure Ensure_Absolute_Path
(Switch : in out String_Access;
Parent : String;
Do_Fail : Fail_Proc;
For_Gnatbind : Boolean := False;
Including_Non_Switch : Boolean := True;
Including_RTS : Boolean := False)
is
begin
if Switch /= null then
declare
Sw : String (1 .. Switch'Length);
Start : Positive;
begin
Sw := Switch.all;
if Sw (1) = '-' then
if Sw'Length >= 3
and then (Sw (2) = 'I'
or else (not For_Gnatbind
and then (Sw (2) = 'L'
or else
Sw (2) = 'A')))
then
Start := 3;
if Sw = "-I-" then
return;
end if;
elsif Sw'Length >= 4
and then (Sw (2 .. 3) = "aL"
or else
Sw (2 .. 3) = "aO"
or else
Sw (2 .. 3) = "aI"
or else
(For_Gnatbind and then Sw (2 .. 3) = "A="))
then
Start := 4;
elsif Including_RTS
and then Sw'Length >= 7
and then Sw (2 .. 6) = "-RTS="
then
Start := 7;
else
return;
end if;
-- Because relative path arguments to --RTS= may be relative to
-- the search directory prefix, those relative path arguments
-- are converted only when they include directory information.
if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
if Parent'Length = 0 then
Do_Fail
("relative search path switches ("""
& Sw
& """) are not allowed");
elsif Including_RTS then
for J in Start .. Sw'Last loop
if Sw (J) = Directory_Separator then
Switch :=
new String'
(Sw (1 .. Start - 1)
& Parent
& Directory_Separator
& Sw (Start .. Sw'Last));
return;
end if;
end loop;
else
Switch :=
new String'
(Sw (1 .. Start - 1)
& Parent
& Directory_Separator
& Sw (Start .. Sw'Last));
end if;
end if;
elsif Including_Non_Switch then
if not Is_Absolute_Path (Sw) then
if Parent'Length = 0 then
Do_Fail
("relative paths (""" & Sw & """) are not allowed");
else
Switch := new String'(Parent & Directory_Separator & Sw);
end if;
end if;
end if;
end;
end if;
end Ensure_Absolute_Path;
----------------------------
-- Executable_Prefix_Path --
----------------------------
function Executable_Prefix_Path return String is
Exec_Name : constant String := Command_Name;
function Get_Install_Dir (S : String) return String;
-- S is the executable name preceded by the absolute or relative path,
-- e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin"
-- lies (in the example "C:\usr"). If the executable is not in a "bin"
-- directory, return "".
---------------------
-- Get_Install_Dir --
---------------------
function Get_Install_Dir (S : String) return String is
Exec : String := S;
Path_Last : Integer := 0;
begin
for J in reverse Exec'Range loop
if Exec (J) = Directory_Separator then
Path_Last := J - 1;
exit;
end if;
end loop;
if Path_Last >= Exec'First + 2 then
To_Lower (Exec (Path_Last - 2 .. Path_Last));
end if;
if Path_Last < Exec'First + 2
or else Exec (Path_Last - 2 .. Path_Last) /= "bin"
or else (Path_Last - 3 >= Exec'First
and then Exec (Path_Last - 3) /= Directory_Separator)
then
return "";
end if;
return Normalize_Pathname
(Exec (Exec'First .. Path_Last - 4),
Resolve_Links => Opt.Follow_Links_For_Dirs)
& Directory_Separator;
end Get_Install_Dir;
-- Beginning of Executable_Prefix_Path
begin
-- For VMS, the path returned is always /gnu/
if Hostparm.OpenVMS then
return "/gnu/";
end if;
-- First determine if a path prefix was placed in front of the
-- executable name.
for J in reverse Exec_Name'Range loop
if Exec_Name (J) = Directory_Separator then
return Get_Install_Dir (Exec_Name);
end if;
end loop;
-- If we get here, the user has typed the executable name with no
-- directory prefix.
declare
Path : String_Access := Locate_Exec_On_Path (Exec_Name);
begin
if Path = null then
return "";
else
declare
Dir : constant String := Get_Install_Dir (Path.all);
begin
Free (Path);
return Dir;
end;
end if;
end;
end Executable_Prefix_Path;
------------------
-- Fail_Program --
------------------
procedure Fail_Program
(Project_Tree : Project_Tree_Ref;
S : String;
Flush_Messages : Boolean := True)
is
begin
if Flush_Messages then
if Total_Errors_Detected /= 0 or else Warnings_Detected /= 0 then
Errutil.Finalize;
end if;
end if;
Finish_Program (Project_Tree, E_Fatal, S => S);
end Fail_Program;
--------------------
-- Finish_Program --
--------------------
procedure Finish_Program
(Project_Tree : Project_Tree_Ref;
Exit_Code : Osint.Exit_Code_Type := Osint.E_Success;
S : String := "")
is
begin
if not Debug.Debug_Flag_N then
Delete_Temp_Config_Files (Project_Tree);
if Project_Tree /= null then
Delete_All_Temp_Files (Project_Tree.Shared);
end if;
end if;
if S'Length > 0 then
if Exit_Code /= E_Success then
Osint.Fail (S);
else
Write_Str (S);
end if;
end if;
-- Output Namet statistics
Namet.Finalize;
Exit_Program (Exit_Code);
end Finish_Program;
--------------------------
-- File_Not_A_Source_Of --
--------------------------
function File_Not_A_Source_Of
(Project_Tree : Project_Tree_Ref;
Uname : Name_Id;
Sfile : File_Name_Type) return Boolean
is
Unit : constant Unit_Index :=
Units_Htable.Get (Project_Tree.Units_HT, Uname);
At_Least_One_File : Boolean := False;
begin
if Unit /= No_Unit_Index then
for F in Unit.File_Names'Range loop
if Unit.File_Names (F) /= null then
At_Least_One_File := True;
if Unit.File_Names (F).File = Sfile then
return False;
end if;
end if;
end loop;
if not At_Least_One_File then
-- The unit was probably created initially for a separate unit
-- (which are initially created as IMPL when both suffixes are the
-- same). Later on, Override_Kind changed the type of the file,
-- and the unit is no longer valid in fact.
return False;
end if;
Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile));
return True;
end if;
return False;
end File_Not_A_Source_Of;
---------------------
-- Get_Directories --
---------------------
procedure Get_Directories
(Project_Tree : Project_Tree_Ref;
For_Project : Project_Id;
Activity : Activity_Type;
Languages : Name_Ids)
is
procedure Recursive_Add
(Project : Project_Id;
Tree : Project_Tree_Ref;
Extended : in out Boolean);
-- Add all the source directories of a project to the path only if
-- this project has not been visited. Calls itself recursively for
-- projects being extended, and imported projects.
procedure Add_Dir (Value : Path_Name_Type);
-- Add directory Value in table Directories, if it is defined and not
-- already there.
-------------
-- Add_Dir --
-------------
procedure Add_Dir (Value : Path_Name_Type) is
Add_It : Boolean := True;
begin
if Value /= No_Path then
for Index in 1 .. Directories.Last loop
if Directories.Table (Index) = Value then
Add_It := False;
exit;
end if;
end loop;
if Add_It then
Directories.Increment_Last;
Directories.Table (Directories.Last) := Value;
end if;
end if;
end Add_Dir;
-------------------
-- Recursive_Add --
-------------------
procedure Recursive_Add
(Project : Project_Id;
Tree : Project_Tree_Ref;
Extended : in out Boolean)
is
Current : String_List_Id;
Dir : String_Element;
OK : Boolean := False;
Lang_Proc : Language_Ptr := Project.Languages;
begin
-- Add to path all directories of this project
if Activity = Compilation then
Lang_Loop :
while Lang_Proc /= No_Language_Index loop
for J in Languages'Range loop
OK := Lang_Proc.Name = Languages (J);
exit Lang_Loop when OK;
end loop;
Lang_Proc := Lang_Proc.Next;
end loop Lang_Loop;
if OK then
Current := Project.Source_Dirs;
while Current /= Nil_String loop
Dir := Tree.Shared.String_Elements.Table (Current);
Add_Dir (Path_Name_Type (Dir.Value));
Current := Dir.Next;
end loop;
end if;
elsif Project.Library then
if Activity = SAL_Binding and then Extended then
Add_Dir (Project.Object_Directory.Display_Name);
else
Add_Dir (Project.Library_ALI_Dir.Display_Name);
end if;
else
Add_Dir (Project.Object_Directory.Display_Name);
end if;
if Project.Extends = No_Project then
Extended := False;
end if;
end Recursive_Add;
procedure For_All_Projects is
new For_Every_Project_Imported (Boolean, Recursive_Add);
Extended : Boolean := True;
-- Start of processing for Get_Directories
begin
Directories.Init;
For_All_Projects (For_Project, Project_Tree, Extended);
end Get_Directories;
------------------
-- Get_Switches --
------------------
procedure Get_Switches
(Source : Prj.Source_Id;
Pkg_Name : Name_Id;
Project_Tree : Project_Tree_Ref;
Value : out Variable_Value;
Is_Default : out Boolean)
is
begin
Get_Switches
(Source_File => Source.File,
Source_Lang => Source.Language.Name,
Source_Prj => Source.Project,
Pkg_Name => Pkg_Name,
Project_Tree => Project_Tree,
Value => Value,
Is_Default => Is_Default);
end Get_Switches;
------------------
-- Get_Switches --
------------------
procedure Get_Switches
(Source_File : File_Name_Type;
Source_Lang : Name_Id;
Source_Prj : Project_Id;
Pkg_Name : Name_Id;
Project_Tree : Project_Tree_Ref;
Value : out Variable_Value;
Is_Default : out Boolean;
Test_Without_Suffix : Boolean := False;
Check_ALI_Suffix : Boolean := False)
is
Project : constant Project_Id :=
Ultimate_Extending_Project_Of (Source_Prj);
Pkg : constant Package_Id :=
Prj.Util.Value_Of
(Name => Pkg_Name,
In_Packages => Project.Decl.Packages,
Shared => Project_Tree.Shared);
Lang : Language_Ptr;
begin
Is_Default := False;
if Source_File /= No_File then
Value := Prj.Util.Value_Of
(Name => Name_Id (Source_File),
Attribute_Or_Array_Name => Name_Switches,
In_Package => Pkg,
Shared => Project_Tree.Shared,
Allow_Wildcards => True);
end if;
if Value = Nil_Variable_Value and then Test_Without_Suffix then
Lang :=
Get_Language_From_Name (Project, Get_Name_String (Source_Lang));
if Lang /= null then
declare
Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
SF_Name : constant String := Get_Name_String (Source_File);
Last : Positive := SF_Name'Length;
Name : String (1 .. Last + 3);
Spec_Suffix : String := Get_Name_String (Naming.Spec_Suffix);
Body_Suffix : String := Get_Name_String (Naming.Body_Suffix);
Truncated : Boolean := False;
begin
Canonical_Case_File_Name (Spec_Suffix);
Canonical_Case_File_Name (Body_Suffix);
Name (1 .. Last) := SF_Name;
if Last > Body_Suffix'Length
and then
Name (Last - Body_Suffix'Length + 1 .. Last) = Body_Suffix
then
Truncated := True;
Last := Last - Body_Suffix'Length;
end if;
if not Truncated
and then Last > Spec_Suffix'Length
and then
Name (Last - Spec_Suffix'Length + 1 .. Last) = Spec_Suffix
then
Truncated := True;
Last := Last - Spec_Suffix'Length;
end if;
if Truncated then
Name_Len := 0;
Add_Str_To_Name_Buffer (Name (1 .. Last));
Value := Prj.Util.Value_Of
(Name => Name_Find,
Attribute_Or_Array_Name => Name_Switches,
In_Package => Pkg,
Shared => Project_Tree.Shared,
Allow_Wildcards => True);
end if;
if Value = Nil_Variable_Value and then Check_ALI_Suffix then
Last := SF_Name'Length;
while Name (Last) /= '.' loop
Last := Last - 1;
end loop;
Name_Len := 0;
Add_Str_To_Name_Buffer (Name (1 .. Last));
Add_Str_To_Name_Buffer ("ali");
Value := Prj.Util.Value_Of
(Name => Name_Find,
Attribute_Or_Array_Name => Name_Switches,
In_Package => Pkg,
Shared => Project_Tree.Shared,
Allow_Wildcards => True);
end if;
end;
end if;
end if;
if Value = Nil_Variable_Value then
Is_Default := True;
Value :=
Prj.Util.Value_Of
(Name => Source_Lang,
Attribute_Or_Array_Name => Name_Switches,
In_Package => Pkg,
Shared => Project_Tree.Shared,
Force_Lower_Case_Index => True);
end if;
if Value = Nil_Variable_Value then
Value :=
Prj.Util.Value_Of
(Name => All_Other_Names,
Attribute_Or_Array_Name => Name_Switches,
In_Package => Pkg,
Shared => Project_Tree.Shared,
Force_Lower_Case_Index => True);
end if;
if Value = Nil_Variable_Value then
Value :=
Prj.Util.Value_Of
(Name => Source_Lang,
Attribute_Or_Array_Name => Name_Default_Switches,
In_Package => Pkg,
Shared => Project_Tree.Shared);
end if;
end Get_Switches;
------------
-- Inform --
------------
procedure Inform (N : File_Name_Type; Msg : String) is
begin
Inform (Name_Id (N), Msg);
end Inform;
procedure Inform (N : Name_Id := No_Name; Msg : String) is
begin
Osint.Write_Program_Name;
Write_Str (": ");
if N /= No_Name then
Write_Str ("""");
declare
Name : constant String := Get_Name_String (N);
begin
if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then
Write_Str (File_Name (Name));
else
Write_Str (Name);
end if;
end;
Write_Str (""" ");
end if;
Write_Str (Msg);
Write_Eol;
end Inform;
------------------------------
-- Initialize_Source_Record --
------------------------------
procedure Initialize_Source_Record (Source : Prj.Source_Id) is
procedure Set_Object_Project
(Obj_Dir : String;
Obj_Proj : Project_Id;
Obj_Path : Path_Name_Type;
Stamp : Time_Stamp_Type);
-- Update information about object file, switches file,...
------------------------
-- Set_Object_Project --
------------------------
procedure Set_Object_Project
(Obj_Dir : String;
Obj_Proj : Project_Id;
Obj_Path : Path_Name_Type;
Stamp : Time_Stamp_Type) is
begin
Source.Object_Project := Obj_Proj;
Source.Object_Path := Obj_Path;
Source.Object_TS := Stamp;
if Source.Language.Config.Dependency_Kind /= None then
declare
Dep_Path : constant String :=
Normalize_Pathname
(Name =>
Get_Name_String (Source.Dep_Name),
Resolve_Links => Opt.Follow_Links_For_Files,
Directory => Obj_Dir);
begin
Source.Dep_Path := Create_Name (Dep_Path);
Source.Dep_TS := Osint.Unknown_Attributes;
end;
end if;
-- Get the path of the switches file, even if Opt.Check_Switches is
-- not set, as switch -s may be in the Builder switches that have not
-- been scanned yet.
declare
Switches_Path : constant String :=
Normalize_Pathname
(Name =>
Get_Name_String (Source.Switches),
Resolve_Links => Opt.Follow_Links_For_Files,
Directory => Obj_Dir);
begin
Source.Switches_Path := Create_Name (Switches_Path);
if Stamp /= Empty_Time_Stamp then
Source.Switches_TS := File_Stamp (Source.Switches_Path);
end if;
end;
end Set_Object_Project;
Obj_Proj : Project_Id;
begin
-- Nothing to do if source record has already been fully initialized
if Source.Initialized then
return;
end if;
-- Systematically recompute the time stamp
Source.Source_TS := File_Stamp (Source.Path.Display_Name);
-- Parse the source file to check whether we have a subunit
if Source.Language.Config.Kind = Unit_Based
and then Source.Kind = Impl
and then Is_Subunit (Source)
then
Source.Kind := Sep;
end if;
if Source.Language.Config.Object_Generated
and then Is_Compilable (Source)
then
-- First, get the correct object file name and dependency file name
-- if the source is in a multi-unit file.
if Source.Index /= 0 then
Source.Object :=
Object_Name
(Source_File_Name => Source.File,
Source_Index => Source.Index,
Index_Separator =>
Source.Language.Config.Multi_Unit_Object_Separator,
Object_File_Suffix =>
Source.Language.Config.Object_File_Suffix);
Source.Dep_Name :=
Dependency_Name
(Source.Object, Source.Language.Config.Dependency_Kind);
end if;
-- Find the object file for that source. It could be either in the
-- current project or in an extended project (it might actually not
-- exist yet in the ultimate extending project, but if not found
-- elsewhere that's where we'll expect to find it).
Obj_Proj := Source.Project;
while Obj_Proj /= No_Project loop
if Obj_Proj.Object_Directory /= No_Path_Information then
declare
Dir : constant String :=
Get_Name_String (Obj_Proj.Object_Directory.Display_Name);
Object_Path : constant String :=
Normalize_Pathname
(Name => Get_Name_String (Source.Object),
Resolve_Links => Opt.Follow_Links_For_Files,
Directory => Dir);
Obj_Path : constant Path_Name_Type :=
Create_Name (Object_Path);
Stamp : Time_Stamp_Type := Empty_Time_Stamp;
begin
-- For specs, we do not check object files if there is a
-- body. This saves a system call. On the other hand, we do
-- need to know the object_path, in case the user has passed
-- the .ads on the command line to compile the spec only.
if Source.Kind /= Spec
or else Source.Unit = No_Unit_Index
or else Source.Unit.File_Names (Impl) = No_Source
then
Stamp := File_Stamp (Obj_Path);
end if;
if Stamp /= Empty_Time_Stamp
or else (Obj_Proj.Extended_By = No_Project
and then Source.Object_Project = No_Project)
then
Set_Object_Project (Dir, Obj_Proj, Obj_Path, Stamp);
end if;
end;
end if;
Obj_Proj := Obj_Proj.Extended_By;
end loop;
elsif Source.Language.Config.Dependency_Kind = Makefile then
declare
Object_Dir : constant String :=
Get_Name_String (Source.Project.Object_Directory.Display_Name);
Dep_Path : constant String :=
Normalize_Pathname
(Name => Get_Name_String (Source.Dep_Name),
Resolve_Links => Opt.Follow_Links_For_Files,
Directory => Object_Dir);
begin
Source.Dep_Path := Create_Name (Dep_Path);
Source.Dep_TS := Osint.Unknown_Attributes;
end;
end if;
Source.Initialized := True;
end Initialize_Source_Record;
----------------------------
-- Is_External_Assignment --
----------------------------
function Is_External_Assignment
(Env : Prj.Tree.Environment;
Argv : String) return Boolean
is
Start : Positive := 3;
Finish : Natural := Argv'Last;
pragma Assert (Argv'First = 1);
pragma Assert (Argv (1 .. 2) = "-X");
begin
if Argv'Last < 5 then
return False;
elsif Argv (3) = '"' then
if Argv (Argv'Last) /= '"' or else Argv'Last < 7 then
return False;
else
Start := 4;
Finish := Argv'Last - 1;
end if;
end if;
return Prj.Ext.Check
(Self => Env.External,
Declaration => Argv (Start .. Finish));
end Is_External_Assignment;
----------------
-- Is_Subunit --
----------------
function Is_Subunit (Source : Prj.Source_Id) return Boolean is
Src_Ind : Source_File_Index;
begin
if Source.Kind = Sep then
return True;
-- A Spec, a file based language source or a body with a spec cannot be
-- a subunit.
elsif Source.Kind = Spec
or else Source.Unit = No_Unit_Index
or else Other_Part (Source) /= No_Source
then
return False;
end if;
-- Here, we are assuming that the language is Ada, as it is the only
-- unit based language that we know.
Src_Ind :=
Sinput.P.Load_Project_File
(Get_Name_String (Source.Path.Display_Name));
return Sinput.P.Source_File_Is_Subunit (Src_Ind);
end Is_Subunit;
-----------------------------
-- Linker_Options_Switches --
-----------------------------
function Linker_Options_Switches
(Project : Project_Id;
Do_Fail : Fail_Proc;
In_Tree : Project_Tree_Ref) return String_List
is
procedure Recursive_Add
(Proj : Project_Id;
In_Tree : Project_Tree_Ref;
Dummy : in out Boolean);
-- The recursive routine used to add linker options
-------------------
-- Recursive_Add --
-------------------
procedure Recursive_Add
(Proj : Project_Id;
In_Tree : Project_Tree_Ref;
Dummy : in out Boolean)
is
pragma Unreferenced (Dummy);
Linker_Package : Package_Id;
Options : Variable_Value;
begin
Linker_Package :=
Prj.Util.Value_Of
(Name => Name_Linker,
In_Packages => Proj.Decl.Packages,
Shared => In_Tree.Shared);
Options :=
Prj.Util.Value_Of
(Name => Name_Ada,
Index => 0,
Attribute_Or_Array_Name => Name_Linker_Options,
In_Package => Linker_Package,
Shared => In_Tree.Shared);
-- If attribute is present, add the project with the attribute to
-- table Linker_Opts.
if Options /= Nil_Variable_Value then
Linker_Opts.Increment_Last;
Linker_Opts.Table (Linker_Opts.Last) :=
(Project => Proj, Options => Options.Values);
end if;
end Recursive_Add;
procedure For_All_Projects is
new For_Every_Project_Imported (Boolean, Recursive_Add);
Dummy : Boolean := False;
-- Start of processing for Linker_Options_Switches
begin
Linker_Opts.Init;
For_All_Projects (Project, In_Tree, Dummy, Imported_First => True);
Last_Linker_Option := 0;
for Index in reverse 1 .. Linker_Opts.Last loop
declare
Options : String_List_Id;
Proj : constant Project_Id :=
Linker_Opts.Table (Index).Project;
Option : Name_Id;
Dir_Path : constant String :=
Get_Name_String (Proj.Directory.Name);
begin
Options := Linker_Opts.Table (Index).Options;
while Options /= Nil_String loop
Option := In_Tree.Shared.String_Elements.Table (Options).Value;
Get_Name_String (Option);
-- Do not consider empty linker options
if Name_Len /= 0 then
Add_Linker_Option (Name_Buffer (1 .. Name_Len));
-- Object files and -L switches specified with relative
-- paths must be converted to absolute paths.
Ensure_Absolute_Path
(Switch =>
Linker_Options_Buffer (Last_Linker_Option),
Parent => Dir_Path,
Do_Fail => Do_Fail,
For_Gnatbind => False);
end if;
Options := In_Tree.Shared.String_Elements.Table (Options).Next;
end loop;
end;
end loop;
return Linker_Options_Buffer (1 .. Last_Linker_Option);
end Linker_Options_Switches;
-----------
-- Mains --
-----------
package body Mains is
package Names is new Table.Table
(Table_Component_Type => Main_Info,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Makeutl.Mains.Names");
-- The table that stores the mains
Current : Natural := 0;
-- The index of the last main retrieved from the table
Count_Of_Mains_With_No_Tree : Natural := 0;
-- Number of main units for which we do not know the project tree
--------------
-- Add_Main --
--------------
procedure Add_Main
(Name : String;
Index : Int := 0;
Location : Source_Ptr := No_Location;
Project : Project_Id := No_Project;
Tree : Project_Tree_Ref := null)
is
begin
if Current_Verbosity = High then
Debug_Output ("Add_Main """ & Name & """ " & Index'Img
& " with_tree? "
& Boolean'Image (Tree /= null));
end if;
Name_Len := 0;
Add_Str_To_Name_Buffer (Name);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
Names.Increment_Last;
Names.Table (Names.Last) :=
(Name_Find, Index, Location, No_Source, Project, Tree);
if Tree /= null then
Builder_Data (Tree).Number_Of_Mains :=
Builder_Data (Tree).Number_Of_Mains + 1;
else
Mains.Count_Of_Mains_With_No_Tree :=
Mains.Count_Of_Mains_With_No_Tree + 1;
end if;
end Add_Main;
--------------------
-- Complete_Mains --
--------------------
procedure Complete_Mains
(Flags : Processing_Flags;
Root_Project : Project_Id;
Project_Tree : Project_Tree_Ref)
is
procedure Do_Complete (Project : Project_Id; Tree : Project_Tree_Ref);
-- Check the mains for this specific project
procedure Complete_All is new For_Project_And_Aggregated
(Do_Complete);
procedure Add_Multi_Unit_Sources
(Tree : Project_Tree_Ref;
Source : Prj.Source_Id);
-- Add all units from the same file as the multi-unit Source
function Find_File_Add_Extension
(Tree : Project_Tree_Ref;
Base_Main : String) return Prj.Source_Id;
-- Search for Main in the project, adding body or spec extensions
----------------------------
-- Add_Multi_Unit_Sources --
----------------------------
procedure Add_Multi_Unit_Sources
(Tree : Project_Tree_Ref;
Source : Prj.Source_Id)
is
Iter : Source_Iterator;
Src : Prj.Source_Id;
begin
Debug_Output
("found multi-unit source file in project", Source.Project.Name);
Iter := For_Each_Source
(In_Tree => Tree, Project => Source.Project);
while Element (Iter) /= No_Source loop
Src := Element (Iter);
if Src.File = Source.File
and then Src.Index /= Source.Index
then
if Src.File = Source.File then
Debug_Output
("add main in project, index=" & Src.Index'Img);
end if;
Names.Increment_Last;
Names.Table (Names.Last) :=
(File => Src.File,
Index => Src.Index,
Location => No_Location,
Source => Src,
Project => Src.Project,
Tree => Tree);
Builder_Data (Tree).Number_Of_Mains :=
Builder_Data (Tree).Number_Of_Mains + 1;
end if;
Next (Iter);
end loop;
end Add_Multi_Unit_Sources;
-----------------------------
-- Find_File_Add_Extension --
-----------------------------
function Find_File_Add_Extension
(Tree : Project_Tree_Ref;
Base_Main : String) return Prj.Source_Id
is
Spec_Source : Prj.Source_Id := No_Source;
Source : Prj.Source_Id;
Iter : Source_Iterator;
Suffix : File_Name_Type;
begin
Source := No_Source;
Iter := For_Each_Source (Tree); -- In all projects
loop
Source := Prj.Element (Iter);
exit when Source = No_Source;
if Source.Kind = Impl then
Get_Name_String (Source.File);
if Name_Len > Base_Main'Length
and then Name_Buffer (1 .. Base_Main'Length) = Base_Main
then
Suffix :=
Source.Language.Config.Naming_Data.Body_Suffix;
if Suffix /= No_File then
declare
Suffix_Str : String := Get_Name_String (Suffix);
begin
Canonical_Case_File_Name (Suffix_Str);
exit when
Name_Buffer (Base_Main'Length + 1 .. Name_Len) =
Suffix_Str;
end;
end if;
end if;
elsif Source.Kind = Spec
and then Source.Language.Config.Kind = Unit_Based
then
-- An Ada spec needs to be taken into account unless there
-- is also a body. So we delay the decision for them.
Get_Name_String (Source.File);
if Name_Len > Base_Main'Length
and then Name_Buffer (1 .. Base_Main'Length) = Base_Main
then
Suffix := Source.Language.Config.Naming_Data.Spec_Suffix;
if Suffix /= No_File then
declare
Suffix_Str : String := Get_Name_String (Suffix);
begin
Canonical_Case_File_Name (Suffix_Str);
if Name_Buffer (Base_Main'Length + 1 .. Name_Len) =
Suffix_Str
then
Spec_Source := Source;
end if;
end;
end if;
end if;
end if;
Next (Iter);
end loop;
if Source = No_Source then
Source := Spec_Source;
end if;
return Source;
end Find_File_Add_Extension;
-----------------
-- Do_Complete --
-----------------
procedure Do_Complete
(Project : Project_Id; Tree : Project_Tree_Ref)
is
J : Integer;
begin
if Mains.Number_Of_Mains (Tree) > 0
or else Mains.Count_Of_Mains_With_No_Tree > 0
then
-- Traverse in reverse order, since in the case of multi-unit
-- files we will be adding extra files at the end, and there's
-- no need to process them in turn.
J := Names.Last;
Main_Loop : loop
declare
File : Main_Info := Names.Table (J);
Main_Id : File_Name_Type := File.File;
Main : constant String :=
Get_Name_String (Main_Id);
Base : constant String := Base_Name (Main);
Source : Prj.Source_Id := No_Source;
Is_Absolute : Boolean := False;
begin
if Base /= Main then
Is_Absolute := True;
if Is_Absolute_Path (Main) then
Main_Id := Create_Name (Base);
-- Not an absolute path
else
-- Always resolve links here, so that users can be
-- specify any name on the command line. If the
-- project itself uses links, the user will be
-- using -eL anyway, and thus files are also stored
-- with resolved names.
declare
Absolute : constant String :=
Normalize_Pathname
(Name => Main,
Directory => "",
Resolve_Links => True,
Case_Sensitive => False);
begin
File.File := Create_Name (Absolute);
Main_Id := Create_Name (Base);
end;
end if;
end if;
-- If no project or tree was specified for the main, it
-- came from the command line.
-- Note that the assignments below will not modify inside
-- the table itself.
if File.Project = null then
File.Project := Project;
end if;
if File.Tree = null then
File.Tree := Tree;
end if;
if File.Source = null then
if Current_Verbosity = High then
Debug_Output
("search for main """ & Main
& '"' & File.Index'Img & " in "
& Get_Name_String (Debug_Name (File.Tree))
& ", project", Project.Name);
end if;
-- First, look for the main as specified. We need to
-- search for the base name though, and if needed
-- check later that we found the correct file.
declare
Sources : constant Source_Ids :=
Find_All_Sources
(In_Tree => File.Tree,
Project => File.Project,
Base_Name => Main_Id,
Index => File.Index,
In_Imported_Only => True);
begin
if Is_Absolute then
for J in Sources'Range loop
if File_Name_Type (Sources (J).Path.Name) =
File.File
then
Source := Sources (J);
exit;
end if;
end loop;
elsif Sources'Length > 1 then
-- This is only allowed if the units are from
-- the same multi-unit source file.
Source := Sources (1);
for J in 2 .. Sources'Last loop
if Sources (J).Path /= Source.Path
or else Sources (J).Index = Source.Index
then
Error_Msg_File_1 := Main_Id;
Prj.Err.Error_Msg
(Flags, "several main sources {",
No_Location, File.Project);
exit Main_Loop;
end if;
end loop;
elsif Sources'Length = 1 then
Source := Sources (Sources'First);
end if;
end;
if Source = No_Source then
Source := Find_File_Add_Extension
(File.Tree, Get_Name_String (Main_Id));
end if;
if Is_Absolute
and then Source /= No_Source
and then
File_Name_Type (Source.Path.Name) /= File.File
then
Debug_Output
("Found a non-matching file",
Name_Id (Source.Path.Display_Name));
Source := No_Source;
end if;
if Source /= No_Source then
if not Is_Allowed_Language
(Source.Language.Name)
then
-- Remove any main that is not in the list of
-- restricted languages.
Names.Table (J .. Names.Last - 1) :=
Names.Table (J + 1 .. Names.Last);
Names.Set_Last (Names.Last - 1);
else
-- If we have found a multi-unit source file but
-- did not specify an index initially, we'll
-- need to compile all the units from the same
-- source file.
if Source.Index /= 0 and then File.Index = 0 then
Add_Multi_Unit_Sources (File.Tree, Source);
end if;
-- Now update the original Main, otherwise it
-- will be reported as not found.
Debug_Output
("found main in project", Source.Project.Name);
Names.Table (J).File := Source.File;
Names.Table (J).Project := Source.Project;
if Names.Table (J).Tree = null then
Names.Table (J).Tree := File.Tree;
Builder_Data (File.Tree).Number_Of_Mains :=
Builder_Data (File.Tree).Number_Of_Mains
+ 1;
Mains.Count_Of_Mains_With_No_Tree :=
Mains.Count_Of_Mains_With_No_Tree - 1;
end if;
Names.Table (J).Source := Source;
Names.Table (J).Index := Source.Index;
end if;
elsif File.Location /= No_Location then
-- If the main is declared in package Builder of
-- the main project, report an error. If the main
-- is on the command line, it may be a main from
-- another project, so do nothing: if the main does
-- not exist in another project, an error will be
-- reported later.
Error_Msg_File_1 := Main_Id;
Error_Msg_Name_1 := File.Project.Name;
Prj.Err.Error_Msg
(Flags, "{ is not a source of project %%",
File.Location, File.Project);
end if;
end if;
end;
J := J - 1;
exit Main_Loop when J < Names.First;
end loop Main_Loop;
end if;
if Total_Errors_Detected > 0 then
Fail_Program (Tree, "problems with main sources");
end if;
end Do_Complete;
-- Start of processing for Complete_Mains
begin
Complete_All (Root_Project, Project_Tree);
if Mains.Count_Of_Mains_With_No_Tree > 0 then
for J in Names.First .. Names.Last loop
if Names.Table (J).Source = No_Source then
Fail_Program
(Project_Tree, '"' & Get_Name_String (Names.Table (J).File)
& """ is not a source of any project");
end if;
end loop;
end if;
end Complete_Mains;
------------
-- Delete --
------------
procedure Delete is
begin
Names.Set_Last (0);
Mains.Reset;
end Delete;
-----------------------
-- Fill_From_Project --
-----------------------
procedure Fill_From_Project
(Root_Project : Project_Id;
Project_Tree : Project_Tree_Ref)
is
procedure Add_Mains_From_Project
(Project : Project_Id;
Tree : Project_Tree_Ref);
-- Add the main units from this project into Mains.
-- This takes into account the aggregated projects
----------------------------
-- Add_Mains_From_Project --
----------------------------
procedure Add_Mains_From_Project
(Project : Project_Id;
Tree : Project_Tree_Ref)
is
List : String_List_Id;
Element : String_Element;
begin
if Number_Of_Mains (Tree) = 0
and then Mains.Count_Of_Mains_With_No_Tree = 0
then
Debug_Output ("Add_Mains_From_Project", Project.Name);
List := Project.Mains;
if List /= Prj.Nil_String then
-- The attribute Main is not an empty list. Get the mains in
-- the list.
while List /= Prj.Nil_String loop
Element := Tree.Shared.String_Elements.Table (List);
Debug_Output ("Add_Main", Element.Value);
if Project.Library then
Fail_Program
(Tree,
"cannot specify a main program "
& "for a library project file");
end if;
Add_Main (Name => Get_Name_String (Element.Value),
Index => Element.Index,
Location => Element.Location,
Project => Project,
Tree => Tree);
List := Element.Next;
end loop;
end if;
end if;
if Total_Errors_Detected > 0 then
Fail_Program (Tree, "problems with main sources");
end if;
end Add_Mains_From_Project;
procedure Fill_All is new For_Project_And_Aggregated
(Add_Mains_From_Project);
-- Start of processing for Fill_From_Project
begin
Fill_All (Root_Project, Project_Tree);
end Fill_From_Project;
---------------
-- Next_Main --
---------------
function Next_Main return String is
Info : constant Main_Info := Next_Main;
begin
if Info = No_Main_Info then
return "";
else
return Get_Name_String (Info.File);
end if;
end Next_Main;
function Next_Main return Main_Info is
begin
if Current >= Names.Last then
return No_Main_Info;
else
Current := Current + 1;
-- If not using projects, and in the gnatmake case, the main file
-- may have not have the extension. Try ".adb" first then ".ads"
if Names.Table (Current).Project = No_Project then
declare
Orig_Main : constant File_Name_Type :=
Names.Table (Current).File;
Current_Main : File_Name_Type;
begin
if Strip_Suffix (Orig_Main) = Orig_Main then
Get_Name_String (Orig_Main);
Add_Str_To_Name_Buffer (".adb");
Current_Main := Name_Find;
if Full_Source_Name (Current_Main) = No_File then
Get_Name_String (Orig_Main);
Add_Str_To_Name_Buffer (".ads");
Current_Main := Name_Find;
if Full_Source_Name (Current_Main) /= No_File then
Names.Table (Current).File := Current_Main;
end if;
else
Names.Table (Current).File := Current_Main;
end if;
end if;
end;
end if;
return Names.Table (Current);
end if;
end Next_Main;
---------------------
-- Number_Of_Mains --
---------------------
function Number_Of_Mains (Tree : Project_Tree_Ref) return Natural is
begin
if Tree = null then
return Names.Last;
else
return Builder_Data (Tree).Number_Of_Mains;
end if;
end Number_Of_Mains;
-----------
-- Reset --
-----------
procedure Reset is
begin
Current := 0;
end Reset;
--------------------------
-- Set_Multi_Unit_Index --
--------------------------
procedure Set_Multi_Unit_Index
(Project_Tree : Project_Tree_Ref := null;
Index : Int := 0)
is
begin
if Index /= 0 then
if Names.Last = 0 then
Fail_Program
(Project_Tree,
"cannot specify a multi-unit index but no main "
& "on the command line");
elsif Names.Last > 1 then
Fail_Program
(Project_Tree,
"cannot specify several mains with a multi-unit index");
else
Names.Table (Names.Last).Index := Index;
end if;
end if;
end Set_Multi_Unit_Index;
end Mains;
-----------------------
-- Path_Or_File_Name --
-----------------------
function Path_Or_File_Name (Path : Path_Name_Type) return String is
Path_Name : constant String := Get_Name_String (Path);
begin
if Debug.Debug_Flag_F then
return File_Name (Path_Name);
else
return Path_Name;
end if;
end Path_Or_File_Name;
-------------------
-- Unit_Index_Of --
-------------------
function Unit_Index_Of (ALI_File : File_Name_Type) return Int is
Start : Natural;
Finish : Natural;
Result : Int := 0;
begin
Get_Name_String (ALI_File);
-- First, find the last dot
Finish := Name_Len;
while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop
Finish := Finish - 1;
end loop;
if Finish = 1 then
return 0;
end if;
-- Now check that the dot is preceded by digits
Start := Finish;
Finish := Finish - 1;
while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop
Start := Start - 1;
end loop;
-- If there are no digits, or if the digits are not preceded by the
-- character that precedes a unit index, this is not the ALI file of
-- a unit in a multi-unit source.
if Start > Finish
or else Start = 1
or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character
then
return 0;
end if;
-- Build the index from the digit(s)
while Start <= Finish loop
Result := Result * 10 +
Character'Pos (Name_Buffer (Start)) - Character'Pos ('0');
Start := Start + 1;
end loop;
return Result;
end Unit_Index_Of;
-----------------
-- Verbose_Msg --
-----------------
procedure Verbose_Msg
(N1 : Name_Id;
S1 : String;
N2 : Name_Id := No_Name;
S2 : String := "";
Prefix : String := " -> ";
Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
is
begin
if not Opt.Verbose_Mode
or else Minimum_Verbosity > Opt.Verbosity_Level
then
return;
end if;
Write_Str (Prefix);
Write_Str ("""");
Write_Name (N1);
Write_Str (""" ");
Write_Str (S1);
if N2 /= No_Name then
Write_Str (" """);
Write_Name (N2);
Write_Str (""" ");
end if;
Write_Str (S2);
Write_Eol;
end Verbose_Msg;
procedure Verbose_Msg
(N1 : File_Name_Type;
S1 : String;
N2 : File_Name_Type := No_File;
S2 : String := "";
Prefix : String := " -> ";
Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
is
begin
Verbose_Msg
(Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
end Verbose_Msg;
-----------
-- Queue --
-----------
package body Queue is
type Q_Record is record
Info : Source_Info;
Processed : Boolean;
end record;
package Q is new Table.Table
(Table_Component_Type => Q_Record,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 1000,
Table_Increment => 100,
Table_Name => "Makeutl.Queue.Q");
-- This is the actual Queue
package Busy_Obj_Dirs is new GNAT.HTable.Simple_HTable
(Header_Num => Prj.Header_Num,
Element => Boolean,
No_Element => False,
Key => Path_Name_Type,
Hash => Hash,
Equal => "=");
type Mark_Key is record
File : File_Name_Type;
Index : Int;
end record;
-- Identify either a mono-unit source (when Index = 0) or a specific
-- unit (index = 1's origin index of unit) in a multi-unit source.
Max_Mask_Num : constant := 2048;
subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1;
function Hash (Key : Mark_Key) return Mark_Num;
package Marks is new GNAT.HTable.Simple_HTable
(Header_Num => Mark_Num,
Element => Boolean,
No_Element => False,
Key => Mark_Key,
Hash => Hash,
Equal => "=");
-- A hash table to keep tracks of the marked units.
-- These are the units that have already been processed, when using the
-- gnatmake format. When using the gprbuild format, we can directly
-- store in the source_id whether the file has already been processed.
procedure Mark (Source_File : File_Name_Type; Index : Int := 0);
-- Mark a unit, identified by its source file and, when Index is not 0,
-- the index of the unit in the source file. Marking is used to signal
-- that the unit has already been inserted in the Q.
function Is_Marked
(Source_File : File_Name_Type;
Index : Int := 0) return Boolean;
-- Returns True if the unit was previously marked
Q_Processed : Natural := 0;
Q_Initialized : Boolean := False;
Q_First : Natural := 1;
-- Points to the first valid element in the queue
One_Queue_Per_Obj_Dir : Boolean := False;
-- See parameter to Initialize
function Available_Obj_Dir (S : Source_Info) return Boolean;
-- Whether the object directory for S is available for a build
procedure Debug_Display (S : Source_Info);
-- A debug display for S
function Was_Processed (S : Source_Info) return Boolean;
-- Whether S has already been processed. This marks the source as
-- processed, if it hasn't already been processed.
function Insert_No_Roots (Source : Source_Info) return Boolean;
-- Insert Source, but do not look for its roots (see doc for Insert)
-------------------
-- Was_Processed --
-------------------
function Was_Processed (S : Source_Info) return Boolean is
begin
case S.Format is
when Format_Gprbuild =>
if S.Id.In_The_Queue then
return True;
end if;
S.Id.In_The_Queue := True;
when Format_Gnatmake =>
if Is_Marked (S.File, S.Index) then
return True;
end if;
Mark (S.File, Index => S.Index);
end case;
return False;
end Was_Processed;
-----------------------
-- Available_Obj_Dir --
-----------------------
function Available_Obj_Dir (S : Source_Info) return Boolean is
begin
case S.Format is
when Format_Gprbuild =>
return not Busy_Obj_Dirs.Get
(S.Id.Project.Object_Directory.Name);
when Format_Gnatmake =>
return S.Project = No_Project
or else
not Busy_Obj_Dirs.Get (S.Project.Object_Directory.Name);
end case;
end Available_Obj_Dir;
-------------------
-- Debug_Display --
-------------------
procedure Debug_Display (S : Source_Info) is
begin
case S.Format is
when Format_Gprbuild =>
Write_Name (S.Id.File);
if S.Id.Index /= 0 then
Write_Str (", ");
Write_Int (S.Id.Index);
end if;
when Format_Gnatmake =>
Write_Name (S.File);
if S.Index /= 0 then
Write_Str (", ");
Write_Int (S.Index);
end if;
end case;
end Debug_Display;
----------
-- Hash --
----------
function Hash (Key : Mark_Key) return Mark_Num is
begin
return Union_Id (Key.File) mod Max_Mask_Num;
end Hash;
---------------
-- Is_Marked --
---------------
function Is_Marked
(Source_File : File_Name_Type;
Index : Int := 0) return Boolean
is
begin
return Marks.Get (K => (File => Source_File, Index => Index));
end Is_Marked;
----------
-- Mark --
----------
procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is
begin
Marks.Set (K => (File => Source_File, Index => Index), E => True);
end Mark;
-------------
-- Extract --
-------------
procedure Extract
(Found : out Boolean;
Source : out Source_Info)
is
begin
Found := False;
if One_Queue_Per_Obj_Dir then
for J in Q_First .. Q.Last loop
if not Q.Table (J).Processed
and then Available_Obj_Dir (Q.Table (J).Info)
then
Found := True;
Source := Q.Table (J).Info;
Q.Table (J).Processed := True;
if J = Q_First then
while Q_First <= Q.Last
and then Q.Table (Q_First).Processed
loop
Q_First := Q_First + 1;
end loop;
end if;
exit;
end if;
end loop;
elsif Q_First <= Q.Last then
Source := Q.Table (Q_First).Info;
Q.Table (Q_First).Processed := True;
Q_First := Q_First + 1;
Found := True;
end if;
if Found then
Q_Processed := Q_Processed + 1;
end if;
if Found and then Debug.Debug_Flag_Q then
Write_Str (" Q := Q - [ ");
Debug_Display (Source);
Write_Str (" ]");
Write_Eol;
Write_Str (" Q_First =");
Write_Int (Int (Q_First));
Write_Eol;
Write_Str (" Q.Last =");
Write_Int (Int (Q.Last));
Write_Eol;
end if;
end Extract;
---------------
-- Processed --
---------------
function Processed return Natural is
begin
return Q_Processed;
end Processed;
----------------
-- Initialize --
----------------
procedure Initialize
(Queue_Per_Obj_Dir : Boolean;
Force : Boolean := False)
is
begin
if Force or else not Q_Initialized then
Q_Initialized := True;
for J in 1 .. Q.Last loop
case Q.Table (J).Info.Format is
when Format_Gprbuild =>
Q.Table (J).Info.Id.In_The_Queue := False;
when Format_Gnatmake =>
null;
end case;
end loop;
Q.Init;
Q_Processed := 0;
Q_First := 1;
One_Queue_Per_Obj_Dir := Queue_Per_Obj_Dir;
end if;
end Initialize;
---------------------
-- Insert_No_Roots --
---------------------
function Insert_No_Roots (Source : Source_Info) return Boolean is
begin
pragma Assert
(Source.Format = Format_Gnatmake or else Source.Id /= No_Source);
-- Only insert in the Q if it is not already done, to avoid
-- simultaneous compilations if -jnnn is used.
if Was_Processed (Source) then
return False;
end if;
-- For gprbuild, check if a source has already been inserted in the
-- queue from the same project in a different project tree.
if Source.Format = Format_Gprbuild then
for J in 1 .. Q.Last loop
if Source.Id.Path.Name = Q.Table (J).Info.Id.Path.Name
and then Source.Id.Index = Q.Table (J).Info.Id.Index
and then Source.Id.Project.Path.Name =
Q.Table (J).Info.Id.Project.Path.Name
then
-- No need to insert this source in the queue, but still
-- return True as we may need to insert its roots.
return True;
end if;
end loop;
end if;
if Current_Verbosity = High then
Write_Str ("Adding """);
Debug_Display (Source);
Write_Line (""" to the queue");
end if;
Q.Append (New_Val => (Info => Source, Processed => False));
if Debug.Debug_Flag_Q then
Write_Str (" Q := Q + [ ");
Debug_Display (Source);
Write_Str (" ] ");
Write_Eol;
Write_Str (" Q_First =");
Write_Int (Int (Q_First));
Write_Eol;
Write_Str (" Q.Last =");
Write_Int (Int (Q.Last));
Write_Eol;
end if;
return True;
end Insert_No_Roots;
------------
-- Insert --
------------
function Insert
(Source : Source_Info;
With_Roots : Boolean := False) return Boolean
is
Root_Arr : Array_Element_Id;
Roots : Variable_Value;
List : String_List_Id;
Elem : String_Element;
Unit_Name : Name_Id;
Pat_Root : Boolean;
Root_Pattern : Regexp;
Root_Found : Boolean;
Roots_Found : Boolean;
Root_Source : Prj.Source_Id;
Iter : Source_Iterator;
Dummy : Boolean;
pragma Unreferenced (Dummy);
begin
if not Insert_No_Roots (Source) then
-- Was already in the queue
return False;
end if;
if With_Roots and then Source.Format = Format_Gprbuild then
Debug_Output ("looking for roots of", Name_Id (Source.Id.File));
Root_Arr :=
Prj.Util.Value_Of
(Name => Name_Roots,
In_Arrays => Source.Id.Project.Decl.Arrays,
Shared => Source.Tree.Shared);
Roots :=
Prj.Util.Value_Of
(Index => Name_Id (Source.Id.File),
Src_Index => 0,
In_Array => Root_Arr,
Shared => Source.Tree.Shared);
-- If there is no roots for the specific main, try the language
if Roots = Nil_Variable_Value then
Roots :=
Prj.Util.Value_Of
(Index => Source.Id.Language.Name,
Src_Index => 0,
In_Array => Root_Arr,
Shared => Source.Tree.Shared,
Force_Lower_Case_Index => True);
end if;
-- Then try "*"
if Roots = Nil_Variable_Value then
Name_Len := 1;
Name_Buffer (1) := '*';
Roots :=
Prj.Util.Value_Of
(Index => Name_Find,
Src_Index => 0,
In_Array => Root_Arr,
Shared => Source.Tree.Shared,
Force_Lower_Case_Index => True);
end if;
if Roots = Nil_Variable_Value then
Debug_Output (" -> no roots declared");
else
List := Roots.Values;
Pattern_Loop :
while List /= Nil_String loop
Elem := Source.Tree.Shared.String_Elements.Table (List);
Get_Name_String (Elem.Value);
To_Lower (Name_Buffer (1 .. Name_Len));
Unit_Name := Name_Find;
-- Check if it is a unit name or a pattern
Pat_Root := False;
for J in 1 .. Name_Len loop
if Name_Buffer (J) not in 'a' .. 'z' and then
Name_Buffer (J) not in '0' .. '9' and then
Name_Buffer (J) /= '_' and then
Name_Buffer (J) /= '.'
then
Pat_Root := True;
exit;
end if;
end loop;
if Pat_Root then
begin
Root_Pattern :=
Compile
(Pattern => Name_Buffer (1 .. Name_Len),
Glob => True);
exception
when Error_In_Regexp =>
Err_Vars.Error_Msg_Name_1 := Unit_Name;
Errutil.Error_Msg
("invalid pattern %", Roots.Location);
exit Pattern_Loop;
end;
end if;
Roots_Found := False;
Iter := For_Each_Source (Source.Tree);
Source_Loop :
loop
Root_Source := Prj.Element (Iter);
exit Source_Loop when Root_Source = No_Source;
Root_Found := False;
if Pat_Root then
Root_Found := Root_Source.Unit /= No_Unit_Index
and then Match
(Get_Name_String (Root_Source.Unit.Name),
Root_Pattern);
else
Root_Found :=
Root_Source.Unit /= No_Unit_Index
and then Root_Source.Unit.Name = Unit_Name;
end if;
if Root_Found then
case Root_Source.Kind is
when Impl =>
null;
when Spec =>
Root_Found := Other_Part (Root_Source) = No_Source;
when Sep =>
Root_Found := False;
end case;
end if;
if Root_Found then
Roots_Found := True;
Debug_Output
(" -> ", Name_Id (Root_Source.Display_File));
Dummy := Queue.Insert_No_Roots
(Source => (Format => Format_Gprbuild,
Tree => Source.Tree,
Id => Root_Source));
Initialize_Source_Record (Root_Source);
if Other_Part (Root_Source) /= No_Source then
Initialize_Source_Record (Other_Part (Root_Source));
end if;
-- Save the root for the binder
Source.Id.Roots := new Source_Roots'
(Root => Root_Source,
Next => Source.Id.Roots);
exit Source_Loop when not Pat_Root;
end if;
Next (Iter);
end loop Source_Loop;
if not Roots_Found then
if Pat_Root then
if not Quiet_Output then
Error_Msg_Name_1 := Unit_Name;
Errutil.Error_Msg
("?no unit matches pattern %", Roots.Location);
end if;
else
Errutil.Error_Msg
("Unit " & Get_Name_String (Unit_Name)
& " does not exist", Roots.Location);
end if;
end if;
List := Elem.Next;
end loop Pattern_Loop;
end if;
end if;
return True;
end Insert;
------------
-- Insert --
------------
procedure Insert
(Source : Source_Info;
With_Roots : Boolean := False)
is
Discard : Boolean;
pragma Unreferenced (Discard);
begin
Discard := Insert (Source, With_Roots);
end Insert;
--------------
-- Is_Empty --
--------------
function Is_Empty return Boolean is
begin
return Q_Processed >= Q.Last;
end Is_Empty;
------------------------
-- Is_Virtually_Empty --
------------------------
function Is_Virtually_Empty return Boolean is
begin
if One_Queue_Per_Obj_Dir then
for J in Q_First .. Q.Last loop
if not Q.Table (J).Processed
and then Available_Obj_Dir (Q.Table (J).Info)
then
return False;
end if;
end loop;
return True;
else
return Is_Empty;
end if;
end Is_Virtually_Empty;
----------------------
-- Set_Obj_Dir_Busy --
----------------------
procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type) is
begin
if One_Queue_Per_Obj_Dir then
Busy_Obj_Dirs.Set (Obj_Dir, True);
end if;
end Set_Obj_Dir_Busy;
----------------------
-- Set_Obj_Dir_Free --
----------------------
procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type) is
begin
if One_Queue_Per_Obj_Dir then
Busy_Obj_Dirs.Set (Obj_Dir, False);
end if;
end Set_Obj_Dir_Free;
----------
-- Size --
----------
function Size return Natural is
begin
return Q.Last;
end Size;
-------------
-- Element --
-------------
function Element (Rank : Positive) return File_Name_Type is
begin
if Rank <= Q.Last then
case Q.Table (Rank).Info.Format is
when Format_Gprbuild =>
return Q.Table (Rank).Info.Id.File;
when Format_Gnatmake =>
return Q.Table (Rank).Info.File;
end case;
else
return No_File;
end if;
end Element;
------------------
-- Remove_Marks --
------------------
procedure Remove_Marks is
begin
Marks.Reset;
end Remove_Marks;
----------------------------
-- Insert_Project_Sources --
----------------------------
procedure Insert_Project_Sources
(Project : Project_Id;
Project_Tree : Project_Tree_Ref;
All_Projects : Boolean;
Unique_Compile : Boolean)
is
procedure Do_Insert (Project : Project_Id; Tree : Project_Tree_Ref);
---------------
-- Do_Insert --
---------------
procedure Do_Insert (Project : Project_Id; Tree : Project_Tree_Ref) is
Unit_Based : constant Boolean :=
Unique_Compile
or else not Builder_Data (Tree).Closure_Needed;
-- When Unit_Based is True, put in the queue all compilable
-- sources including the unit based (Ada) one. When Unit_Based is
-- False, put the Ada sources only when they are in a library
-- project.
Iter : Source_Iterator;
Source : Prj.Source_Id;
begin
-- Nothing to do when "-u" was specified and some files were
-- specified on the command line
if Unique_Compile
and then Mains.Number_Of_Mains (Tree) > 0
then
return;
end if;
Iter := For_Each_Source (Tree);
loop
Source := Prj.Element (Iter);
exit when Source = No_Source;
if Is_Allowed_Language (Source.Language.Name)
and then Is_Compilable (Source)
and then
(All_Projects
or else Is_Extending (Project, Source.Project))
and then not Source.Locally_Removed
and then Source.Replaced_By = No_Source
and then
(not Source.Project.Externally_Built
or else
(Is_Extending (Project, Source.Project)
and then not Project.Externally_Built))
and then Source.Kind /= Sep
and then Source.Path /= No_Path_Information
then
if Source.Kind = Impl
or else (Source.Unit /= No_Unit_Index
and then Source.Kind = Spec
and then (Other_Part (Source) = No_Source
or else
Other_Part (Source).Locally_Removed))
then
if (Unit_Based
or else Source.Unit = No_Unit_Index
or else Source.Project.Library)
and then not Is_Subunit (Source)
then
Queue.Insert
(Source => (Format => Format_Gprbuild,
Tree => Tree,
Id => Source));
end if;
end if;
end if;
Next (Iter);
end loop;
end Do_Insert;
procedure Insert_All is new For_Project_And_Aggregated (Do_Insert);
begin
Insert_All (Project, Project_Tree);
end Insert_Project_Sources;
-------------------------------
-- Insert_Withed_Sources_For --
-------------------------------
procedure Insert_Withed_Sources_For
(The_ALI : ALI.ALI_Id;
Project_Tree : Project_Tree_Ref;
Excluding_Shared_SALs : Boolean := False)
is
Sfile : File_Name_Type;
Afile : File_Name_Type;
Src_Id : Prj.Source_Id;
begin
-- Insert in the queue the unmarked source files (i.e. those which
-- have never been inserted in the queue and hence never considered).
for J in ALI.ALIs.Table (The_ALI).First_Unit ..
ALI.ALIs.Table (The_ALI).Last_Unit
loop
for K in ALI.Units.Table (J).First_With ..
ALI.Units.Table (J).Last_With
loop
Sfile := ALI.Withs.Table (K).Sfile;
-- Skip generics
if Sfile /= No_File then
Afile := ALI.Withs.Table (K).Afile;
Src_Id := Source_Files_Htable.Get
(Project_Tree.Source_Files_HT, Sfile);
while Src_Id /= No_Source loop
Initialize_Source_Record (Src_Id);
if Is_Compilable (Src_Id)
and then Src_Id.Dep_Name = Afile
then
case Src_Id.Kind is
when Spec =>
declare
Bdy : constant Prj.Source_Id :=
Other_Part (Src_Id);
begin
if Bdy /= No_Source
and then not Bdy.Locally_Removed
then
Src_Id := Other_Part (Src_Id);
end if;
end;
when Impl =>
if Is_Subunit (Src_Id) then
Src_Id := No_Source;
end if;
when Sep =>
Src_Id := No_Source;
end case;
exit;
end if;
Src_Id := Src_Id.Next_With_File_Name;
end loop;
-- If Excluding_Shared_SALs is True, do not insert in the
-- queue the sources of a shared Stand-Alone Library.
if Src_Id /= No_Source
and then (not Excluding_Shared_SALs
or else Src_Id.Project.Standalone_Library = No
or else Src_Id.Project.Library_Kind = Static)
then
Queue.Insert
(Source => (Format => Format_Gprbuild,
Tree => Project_Tree,
Id => Src_Id));
end if;
end if;
end loop;
end loop;
end Insert_Withed_Sources_For;
end Queue;
----------
-- Free --
----------
procedure Free (Data : in out Builder_Project_Tree_Data) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Binding_Data_Record, Binding_Data);
TmpB, Binding : Binding_Data := Data.Binding;
begin
while Binding /= null loop
TmpB := Binding.Next;
Unchecked_Free (Binding);
Binding := TmpB;
end loop;
end Free;
------------------
-- Builder_Data --
------------------
function Builder_Data
(Tree : Project_Tree_Ref) return Builder_Data_Access
is
begin
if Tree.Appdata = null then
Tree.Appdata := new Builder_Project_Tree_Data;
end if;
return Builder_Data_Access (Tree.Appdata);
end Builder_Data;
--------------------------------
-- Compute_Compilation_Phases --
--------------------------------
procedure Compute_Compilation_Phases
(Tree : Project_Tree_Ref;
Root_Project : Project_Id;
Option_Unique_Compile : Boolean := False; -- Was "-u" specified ?
Option_Compile_Only : Boolean := False; -- Was "-c" specified ?
Option_Bind_Only : Boolean := False;
Option_Link_Only : Boolean := False)
is
procedure Do_Compute (Project : Project_Id; Tree : Project_Tree_Ref);
----------------
-- Do_Compute --
----------------
procedure Do_Compute (Project : Project_Id; Tree : Project_Tree_Ref) is
Data : constant Builder_Data_Access := Builder_Data (Tree);
All_Phases : constant Boolean :=
not Option_Compile_Only
and then not Option_Bind_Only
and then not Option_Link_Only;
-- Whether the command line asked for all three phases. Depending on
-- the project settings, we might still disable some of the phases.
Has_Mains : constant Boolean := Data.Number_Of_Mains > 0;
-- Whether there are some main units defined for this project tree
-- (either from one of the projects, or from the command line)
begin
if Option_Unique_Compile then
-- If -u or -U is specified on the command line, disregard any -c,
-- -b or -l switch: only perform compilation.
Data.Closure_Needed := False;
Data.Need_Compilation := True;
Data.Need_Binding := False;
Data.Need_Linking := False;
else
Data.Closure_Needed := Has_Mains;
Data.Need_Compilation := All_Phases or Option_Compile_Only;
Data.Need_Binding := All_Phases or Option_Bind_Only;
Data.Need_Linking := (All_Phases or Option_Link_Only)
and Has_Mains;
end if;
if Current_Verbosity = High then
Debug_Output ("compilation phases: "
& " compile=" & Data.Need_Compilation'Img
& " bind=" & Data.Need_Binding'Img
& " link=" & Data.Need_Linking'Img
& " closure=" & Data.Closure_Needed'Img
& " mains=" & Data.Number_Of_Mains'Img,
Project.Name);
end if;
end Do_Compute;
procedure Compute_All is new For_Project_And_Aggregated (Do_Compute);
begin
Compute_All (Root_Project, Tree);
end Compute_Compilation_Phases;
------------------------------
-- Compute_Builder_Switches --
------------------------------
procedure Compute_Builder_Switches
(Project_Tree : Project_Tree_Ref;
Env : in out Prj.Tree.Environment;
Main_Project : Project_Id;
Only_For_Lang : Name_Id := No_Name)
is
Builder_Package : constant Package_Id :=
Value_Of (Name_Builder, Main_Project.Decl.Packages,
Project_Tree.Shared);
Global_Compilation_Array : Array_Element_Id;
Global_Compilation_Elem : Array_Element;
Global_Compilation_Switches : Variable_Value;
Default_Switches_Array : Array_Id;
Builder_Switches_Lang : Name_Id := No_Name;
List : String_List_Id;
Element : String_Element;
Index : Name_Id;
Source : Prj.Source_Id;
Lang : Name_Id := No_Name; -- language index for Switches
Switches_For_Lang : Variable_Value := Nil_Variable_Value;
-- Value of Builder'Default_Switches(lang)
Name : Name_Id := No_Name; -- main file index for Switches
Switches_For_Main : Variable_Value := Nil_Variable_Value;
-- Switches for a specific main. When there are several mains, Name is
-- set to No_Name, and Switches_For_Main might be left with an actual
-- value (so that we can display a warning that it was ignored).
Other_Switches : Variable_Value := Nil_Variable_Value;
-- Value of Builder'Switches(others)
Defaults : Variable_Value := Nil_Variable_Value;
Switches : Variable_Value := Nil_Variable_Value;
-- The computed builder switches
Success : Boolean := False;
begin
if Builder_Package /= No_Package then
Mains.Reset;
-- If there is no main, and there is only one compilable language,
-- use this language as the switches index.
if Mains.Number_Of_Mains (Project_Tree) = 0 then
if Only_For_Lang = No_Name then
declare
Language : Language_Ptr := Main_Project.Languages;
begin
while Language /= No_Language_Index loop
if Language.Config.Compiler_Driver /= No_File
and then Language.Config.Compiler_Driver /= Empty_File
then
if Lang /= No_Name then
Lang := No_Name;
exit;
else
Lang := Language.Name;
end if;
end if;
Language := Language.Next;
end loop;
end;
else
Lang := Only_For_Lang;
end if;
else
for Index in 1 .. Mains.Number_Of_Mains (Project_Tree) loop
Source := Mains.Next_Main.Source;
if Source /= No_Source then
if Switches_For_Main = Nil_Variable_Value then
Switches_For_Main := Value_Of
(Name => Name_Id (Source.File),
Attribute_Or_Array_Name => Name_Switches,
In_Package => Builder_Package,
Shared => Project_Tree.Shared,
Force_Lower_Case_Index => False,
Allow_Wildcards => True);
-- If not found, try without extension.
-- That's because gnatmake accepts truncated file names
-- in Builder'Switches
if Switches_For_Main = Nil_Variable_Value
and then Source.Unit /= null
then
Switches_For_Main := Value_Of
(Name => Source.Unit.Name,
Attribute_Or_Array_Name => Name_Switches,
In_Package => Builder_Package,
Shared => Project_Tree.Shared,
Force_Lower_Case_Index => False,
Allow_Wildcards => True);
end if;
end if;
if Index = 1 then
Lang := Source.Language.Name;
Name := Name_Id (Source.File);
else
Name := No_Name; -- Can't use main specific switches
if Lang /= Source.Language.Name then
Lang := No_Name;
end if;
end if;
end if;
end loop;
end if;
Global_Compilation_Array := Value_Of
(Name => Name_Global_Compilation_Switches,
In_Arrays => Project_Tree.Shared.Packages.Table
(Builder_Package).Decl.Arrays,
Shared => Project_Tree.Shared);
Default_Switches_Array :=
Project_Tree.Shared.Packages.Table (Builder_Package).Decl.Arrays;
while Default_Switches_Array /= No_Array
and then
Project_Tree.Shared.Arrays.Table (Default_Switches_Array).Name /=
Name_Default_Switches
loop
Default_Switches_Array :=
Project_Tree.Shared.Arrays.Table (Default_Switches_Array).Next;
end loop;
if Global_Compilation_Array /= No_Array_Element
and then Default_Switches_Array /= No_Array
then
Prj.Err.Error_Msg
(Env.Flags,
"Default_Switches forbidden in presence of "
& "Global_Compilation_Switches. Use Switches instead.",
Project_Tree.Shared.Arrays.Table
(Default_Switches_Array).Location);
Fail_Program
(Project_Tree, "*** illegal combination of Builder attributes");
end if;
if Lang /= No_Name then
Switches_For_Lang := Prj.Util.Value_Of
(Name => Lang,
Index => 0,
Attribute_Or_Array_Name => Name_Switches,
In_Package => Builder_Package,
Shared => Project_Tree.Shared,
Force_Lower_Case_Index => True);
Defaults := Prj.Util.Value_Of
(Name => Lang,
Index => 0,
Attribute_Or_Array_Name => Name_Default_Switches,
In_Package => Builder_Package,
Shared => Project_Tree.Shared,
Force_Lower_Case_Index => True);
end if;
Other_Switches := Prj.Util.Value_Of
(Name => All_Other_Names,
Index => 0,
Attribute_Or_Array_Name => Name_Switches,
In_Package => Builder_Package,
Shared => Project_Tree.Shared);
if not Quiet_Output
and then Mains.Number_Of_Mains (Project_Tree) > 1
and then Switches_For_Main /= Nil_Variable_Value
then
-- More than one main, but we had main-specific switches that
-- are ignored.
if Switches_For_Lang /= Nil_Variable_Value then
Write_Line
("Warning: using Builder'Switches("""
& Get_Name_String (Lang)
& """), as there are several mains");
elsif Other_Switches /= Nil_Variable_Value then
Write_Line
("Warning: using Builder'Switches(others), "
& "as there are several mains");
elsif Defaults /= Nil_Variable_Value then
Write_Line
("Warning: using Builder'Default_Switches("""
& Get_Name_String (Lang)
& """), as there are several mains");
else
Write_Line
("Warning: using no switches from package "
& "Builder, as there are several mains");
end if;
end if;
Builder_Switches_Lang := Lang;
if Name /= No_Name then
-- Get the switches for the single main
Switches := Switches_For_Main;
end if;
if Switches = Nil_Variable_Value or else Switches.Default then
-- Get the switches for the common language of the mains
Switches := Switches_For_Lang;
end if;
if Switches = Nil_Variable_Value or else Switches.Default then
Switches := Other_Switches;
end if;
-- For backward compatibility with gnatmake, if no Switches
-- are declared, check for Default_Switches ().
if Switches = Nil_Variable_Value or else Switches.Default then
Switches := Defaults;
end if;
-- If switches have been found, scan them
if Switches /= Nil_Variable_Value and then not Switches.Default then
List := Switches.Values;
while List /= Nil_String loop
Element := Project_Tree.Shared.String_Elements.Table (List);
Get_Name_String (Element.Value);
if Name_Len /= 0 then
declare
-- Add_Switch might itself be using the name_buffer, so
-- we make a temporary here.
Switch : constant String := Name_Buffer (1 .. Name_Len);
begin
Success := Add_Switch
(Switch => Switch,
For_Lang => Builder_Switches_Lang,
For_Builder => True,
Has_Global_Compilation_Switches =>
Global_Compilation_Array /= No_Array_Element);
end;
if not Success then
for J in reverse 1 .. Name_Len loop
Name_Buffer (J + J) := Name_Buffer (J);
Name_Buffer (J + J - 1) := ''';
end loop;
Name_Len := Name_Len + Name_Len;
Prj.Err.Error_Msg
(Env.Flags,
'"' & Name_Buffer (1 .. Name_Len)
& """ is not a builder switch. Consider moving "
& "it to Global_Compilation_Switches.",
Element.Location);
Fail_Program
(Project_Tree,
"*** illegal switch """
& Get_Name_String (Element.Value) & '"');
end if;
end if;
List := Element.Next;
end loop;
end if;
-- Reset the Builder Switches language
Builder_Switches_Lang := No_Name;
-- Take into account attributes Global_Compilation_Switches
while Global_Compilation_Array /= No_Array_Element loop
Global_Compilation_Elem :=
Project_Tree.Shared.Array_Elements.Table
(Global_Compilation_Array);
Get_Name_String (Global_Compilation_Elem.Index);
To_Lower (Name_Buffer (1 .. Name_Len));
Index := Name_Find;
if Only_For_Lang = No_Name or else Index = Only_For_Lang then
Global_Compilation_Switches := Global_Compilation_Elem.Value;
if Global_Compilation_Switches /= Nil_Variable_Value
and then not Global_Compilation_Switches.Default
then
-- We have found an attribute
-- Global_Compilation_Switches for a language: put the
-- switches in the appropriate table.
List := Global_Compilation_Switches.Values;
while List /= Nil_String loop
Element :=
Project_Tree.Shared.String_Elements.Table (List);
if Element.Value /= No_Name then
Success := Add_Switch
(Switch => Get_Name_String (Element.Value),
For_Lang => Index,
For_Builder => False,
Has_Global_Compilation_Switches =>
Global_Compilation_Array /= No_Array_Element);
end if;
List := Element.Next;
end loop;
end if;
end if;
Global_Compilation_Array := Global_Compilation_Elem.Next;
end loop;
end if;
end Compute_Builder_Switches;
---------------------
-- Write_Path_File --
---------------------
procedure Write_Path_File (FD : File_Descriptor) is
Last : Natural;
Status : Boolean;
begin
Name_Len := 0;
for Index in Directories.First .. Directories.Last loop
Add_Str_To_Name_Buffer (Get_Name_String (Directories.Table (Index)));
Add_Char_To_Name_Buffer (ASCII.LF);
end loop;
Last := Write (FD, Name_Buffer (1)'Address, Name_Len);
if Last = Name_Len then
Close (FD, Status);
else
Status := False;
end if;
if not Status then
Prj.Com.Fail ("could not write temporary file");
end if;
end Write_Path_File;
end Makeutl;
gprbuild-gpl-2014-src/gnat/sem_aux.adb 0000644 0000767 0000145 00000126724 12323721731 017211 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ A U X --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- --
-- --
-- --
-- --
-- --
-- --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Snames; use Snames;
with Stand; use Stand;
with Uintp; use Uintp;
package body Sem_Aux is
----------------------
-- Ancestor_Subtype --
----------------------
function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id is
begin
-- If this is first subtype, or is a base type, then there is no
-- ancestor subtype, so we return Empty to indicate this fact.
if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then
return Empty;
end if;
declare
D : constant Node_Id := Declaration_Node (Typ);
begin
-- If we have a subtype declaration, get the ancestor subtype
if Nkind (D) = N_Subtype_Declaration then
if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
return Entity (Subtype_Mark (Subtype_Indication (D)));
else
return Entity (Subtype_Indication (D));
end if;
-- If not, then no subtype indication is available
else
return Empty;
end if;
end;
end Ancestor_Subtype;
--------------------
-- Available_View --
--------------------
function Available_View (Ent : Entity_Id) return Entity_Id is
begin
-- Obtain the non-limited (non-abstract) view of a state or variable
if Ekind (Ent) = E_Abstract_State
and then Present (Non_Limited_View (Ent))
then
return Non_Limited_View (Ent);
-- The non-limited view of an incomplete type may itself be incomplete
-- in which case obtain its full view.
elsif Is_Incomplete_Type (Ent)
and then Present (Non_Limited_View (Ent))
then
return Get_Full_View (Non_Limited_View (Ent));
-- If it is class_wide, check whether the specific type comes from a
-- limited_with.
elsif Is_Class_Wide_Type (Ent)
and then Is_Incomplete_Type (Etype (Ent))
and then From_Limited_With (Etype (Ent))
and then Present (Non_Limited_View (Etype (Ent)))
then
return Class_Wide_Type (Non_Limited_View (Etype (Ent)));
-- In all other cases, return entity unchanged
else
return Ent;
end if;
end Available_View;
--------------------
-- Constant_Value --
--------------------
function Constant_Value (Ent : Entity_Id) return Node_Id is
D : constant Node_Id := Declaration_Node (Ent);
Full_D : Node_Id;
begin
-- If we have no declaration node, then return no constant value. Not
-- clear how this can happen, but it does sometimes and this is the
-- safest approach.
if No (D) then
return Empty;
-- Normal case where a declaration node is present
elsif Nkind (D) = N_Object_Renaming_Declaration then
return Renamed_Object (Ent);
-- If this is a component declaration whose entity is a constant, it is
-- a prival within a protected function (and so has no constant value).
elsif Nkind (D) = N_Component_Declaration then
return Empty;
-- If there is an expression, return it
elsif Present (Expression (D)) then
return (Expression (D));
-- For a constant, see if we have a full view
elsif Ekind (Ent) = E_Constant
and then Present (Full_View (Ent))
then
Full_D := Parent (Full_View (Ent));
-- The full view may have been rewritten as an object renaming
if Nkind (Full_D) = N_Object_Renaming_Declaration then
return Name (Full_D);
else
return Expression (Full_D);
end if;
-- Otherwise we have no expression to return
else
return Empty;
end if;
end Constant_Value;
---------------------------------
-- Corresponding_Unsigned_Type --
---------------------------------
function Corresponding_Unsigned_Type (Typ : Entity_Id) return Entity_Id is
pragma Assert (Is_Signed_Integer_Type (Typ));
Siz : constant Uint := Esize (Base_Type (Typ));
begin
if Siz = Esize (Standard_Short_Short_Integer) then
return Standard_Short_Short_Unsigned;
elsif Siz = Esize (Standard_Short_Integer) then
return Standard_Short_Unsigned;
elsif Siz = Esize (Standard_Unsigned) then
return Standard_Unsigned;
elsif Siz = Esize (Standard_Long_Integer) then
return Standard_Long_Unsigned;
elsif Siz = Esize (Standard_Long_Long_Integer) then
return Standard_Long_Long_Unsigned;
else
raise Program_Error;
end if;
end Corresponding_Unsigned_Type;
-----------------------------
-- Enclosing_Dynamic_Scope --
-----------------------------
function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
S : Entity_Id;
begin
-- The following test is an error defense against some syntax errors
-- that can leave scopes very messed up.
if Ent = Standard_Standard then
return Ent;
end if;
-- Normal case, search enclosing scopes
-- Note: the test for Present (S) should not be required, it defends
-- against an ill-formed tree.
S := Scope (Ent);
loop
-- If we somehow got an empty value for Scope, the tree must be
-- malformed. Rather than blow up we return Standard in this case.
if No (S) then
return Standard_Standard;
-- Quit if we get to standard or a dynamic scope. We must also
-- handle enclosing scopes that have a full view; required to
-- locate enclosing scopes that are synchronized private types
-- whose full view is a task type.
elsif S = Standard_Standard
or else Is_Dynamic_Scope (S)
or else (Is_Private_Type (S)
and then Present (Full_View (S))
and then Is_Dynamic_Scope (Full_View (S)))
then
return S;
-- Otherwise keep climbing
else
S := Scope (S);
end if;
end loop;
end Enclosing_Dynamic_Scope;
------------------------
-- First_Discriminant --
------------------------
function First_Discriminant (Typ : Entity_Id) return Entity_Id is
Ent : Entity_Id;
begin
pragma Assert
(Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ));
Ent := First_Entity (Typ);
-- The discriminants are not necessarily contiguous, because access
-- discriminants will generate itypes. They are not the first entities
-- either because the tag must be ahead of them.
if Chars (Ent) = Name_uTag then
Ent := Next_Entity (Ent);
end if;
-- Skip all hidden stored discriminants if any
while Present (Ent) loop
exit when Ekind (Ent) = E_Discriminant
and then not Is_Completely_Hidden (Ent);
Ent := Next_Entity (Ent);
end loop;
pragma Assert (Ekind (Ent) = E_Discriminant);
return Ent;
end First_Discriminant;
-------------------------------
-- First_Stored_Discriminant --
-------------------------------
function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
Ent : Entity_Id;
function Has_Completely_Hidden_Discriminant
(Typ : Entity_Id) return Boolean;
-- Scans the Discriminants to see whether any are Completely_Hidden
-- (the mechanism for describing non-specified stored discriminants)
----------------------------------------
-- Has_Completely_Hidden_Discriminant --
----------------------------------------
function Has_Completely_Hidden_Discriminant
(Typ : Entity_Id) return Boolean
is
Ent : Entity_Id;
begin
pragma Assert (Ekind (Typ) = E_Discriminant);
Ent := Typ;
while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
if Is_Completely_Hidden (Ent) then
return True;
end if;
Ent := Next_Entity (Ent);
end loop;
return False;
end Has_Completely_Hidden_Discriminant;
-- Start of processing for First_Stored_Discriminant
begin
pragma Assert
(Has_Discriminants (Typ)
or else Has_Unknown_Discriminants (Typ));
Ent := First_Entity (Typ);
if Chars (Ent) = Name_uTag then
Ent := Next_Entity (Ent);
end if;
if Has_Completely_Hidden_Discriminant (Ent) then
while Present (Ent) loop
exit when Is_Completely_Hidden (Ent);
Ent := Next_Entity (Ent);
end loop;
end if;
pragma Assert (Ekind (Ent) = E_Discriminant);
return Ent;
end First_Stored_Discriminant;
-------------------
-- First_Subtype --
-------------------
function First_Subtype (Typ : Entity_Id) return Entity_Id is
B : constant Entity_Id := Base_Type (Typ);
F : constant Node_Id := Freeze_Node (B);
Ent : Entity_Id;
begin
-- If the base type has no freeze node, it is a type in Standard, and
-- always acts as its own first subtype, except where it is one of the
-- predefined integer types. If the type is formal, it is also a first
-- subtype, and its base type has no freeze node. On the other hand, a
-- subtype of a generic formal is not its own first subtype. Its base
-- type, if anonymous, is attached to the formal type decl. from which
-- the first subtype is obtained.
if No (F) then
if B = Base_Type (Standard_Integer) then
return Standard_Integer;
elsif B = Base_Type (Standard_Long_Integer) then
return Standard_Long_Integer;
elsif B = Base_Type (Standard_Short_Short_Integer) then
return Standard_Short_Short_Integer;
elsif B = Base_Type (Standard_Short_Integer) then
return Standard_Short_Integer;
elsif B = Base_Type (Standard_Long_Long_Integer) then
return Standard_Long_Long_Integer;
elsif Is_Generic_Type (Typ) then
if Present (Parent (B)) then
return Defining_Identifier (Parent (B));
else
return Defining_Identifier (Associated_Node_For_Itype (B));
end if;
else
return B;
end if;
-- Otherwise we check the freeze node, if it has a First_Subtype_Link
-- then we use that link, otherwise (happens with some Itypes), we use
-- the base type itself.
else
Ent := First_Subtype_Link (F);
if Present (Ent) then
return Ent;
else
return B;
end if;
end if;
end First_Subtype;
-------------------------
-- First_Tag_Component --
-------------------------
function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
Comp : Entity_Id;
Ctyp : Entity_Id;
begin
Ctyp := Typ;
pragma Assert (Is_Tagged_Type (Ctyp));
if Is_Class_Wide_Type (Ctyp) then
Ctyp := Root_Type (Ctyp);
end if;
if Is_Private_Type (Ctyp) then
Ctyp := Underlying_Type (Ctyp);
-- If the underlying type is missing then the source program has
-- errors and there is nothing else to do (the full-type declaration
-- associated with the private type declaration is missing).
if No (Ctyp) then
return Empty;
end if;
end if;
Comp := First_Entity (Ctyp);
while Present (Comp) loop
if Is_Tag (Comp) then
return Comp;
end if;
Comp := Next_Entity (Comp);
end loop;
-- No tag component found
return Empty;
end First_Tag_Component;
---------------------
-- Get_Binary_Nkind --
---------------------
function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind is
begin
case Chars (Op) is
when Name_Op_Add =>
return N_Op_Add;
when Name_Op_Concat =>
return N_Op_Concat;
when Name_Op_Expon =>
return N_Op_Expon;
when Name_Op_Subtract =>
return N_Op_Subtract;
when Name_Op_Mod =>
return N_Op_Mod;
when Name_Op_Multiply =>
return N_Op_Multiply;
when Name_Op_Divide =>
return N_Op_Divide;
when Name_Op_Rem =>
return N_Op_Rem;
when Name_Op_And =>
return N_Op_And;
when Name_Op_Eq =>
return N_Op_Eq;
when Name_Op_Ge =>
return N_Op_Ge;
when Name_Op_Gt =>
return N_Op_Gt;
when Name_Op_Le =>
return N_Op_Le;
when Name_Op_Lt =>
return N_Op_Lt;
when Name_Op_Ne =>
return N_Op_Ne;
when Name_Op_Or =>
return N_Op_Or;
when Name_Op_Xor =>
return N_Op_Xor;
when others =>
raise Program_Error;
end case;
end Get_Binary_Nkind;
------------------
-- Get_Rep_Item --
------------------
function Get_Rep_Item
(E : Entity_Id;
Nam : Name_Id;
Check_Parents : Boolean := True) return Node_Id
is
N : Node_Id;
begin
N := First_Rep_Item (E);
while Present (N) loop
-- Only one of Priority / Interrupt_Priority can be specified, so
-- return whichever one is present to catch illegal duplication.
if Nkind (N) = N_Pragma
and then
(Pragma_Name (N) = Nam
or else (Nam = Name_Priority
and then Pragma_Name (N) = Name_Interrupt_Priority)
or else (Nam = Name_Interrupt_Priority
and then Pragma_Name (N) = Name_Priority))
then
if Check_Parents then
return N;
-- If Check_Parents is False, return N if the pragma doesn't
-- appear in the Rep_Item chain of the parent.
else
declare
Par : constant Entity_Id := Nearest_Ancestor (E);
-- This node represents the parent type of type E (if any)
begin
if No (Par) then
return N;
elsif not Present_In_Rep_Item (Par, N) then
return N;
end if;
end;
end if;
elsif Nkind (N) = N_Attribute_Definition_Clause
and then
(Chars (N) = Nam
or else (Nam = Name_Priority
and then Chars (N) = Name_Interrupt_Priority))
then
if Check_Parents or else Entity (N) = E then
return N;
end if;
elsif Nkind (N) = N_Aspect_Specification
and then
(Chars (Identifier (N)) = Nam
or else
(Nam = Name_Priority
and then Chars (Identifier (N)) = Name_Interrupt_Priority))
then
if Check_Parents then
return N;
elsif Entity (N) = E then
return N;
end if;
end if;
Next_Rep_Item (N);
end loop;
return Empty;
end Get_Rep_Item;
function Get_Rep_Item
(E : Entity_Id;
Nam1 : Name_Id;
Nam2 : Name_Id;
Check_Parents : Boolean := True) return Node_Id
is
Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents);
Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents);
N : Node_Id;
begin
-- Check both Nam1_Item and Nam2_Item are present
if No (Nam1_Item) then
return Nam2_Item;
elsif No (Nam2_Item) then
return Nam1_Item;
end if;
-- Return the first node encountered in the list
N := First_Rep_Item (E);
while Present (N) loop
if N = Nam1_Item or else N = Nam2_Item then
return N;
end if;
Next_Rep_Item (N);
end loop;
return Empty;
end Get_Rep_Item;
--------------------
-- Get_Rep_Pragma --
--------------------
function Get_Rep_Pragma
(E : Entity_Id;
Nam : Name_Id;
Check_Parents : Boolean := True) return Node_Id
is
N : Node_Id;
begin
N := Get_Rep_Item (E, Nam, Check_Parents);
if Present (N) and then Nkind (N) = N_Pragma then
return N;
end if;
return Empty;
end Get_Rep_Pragma;
function Get_Rep_Pragma
(E : Entity_Id;
Nam1 : Name_Id;
Nam2 : Name_Id;
Check_Parents : Boolean := True) return Node_Id
is
Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents);
Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents);
N : Node_Id;
begin
-- Check both Nam1_Item and Nam2_Item are present
if No (Nam1_Item) then
return Nam2_Item;
elsif No (Nam2_Item) then
return Nam1_Item;
end if;
-- Return the first node encountered in the list
N := First_Rep_Item (E);
while Present (N) loop
if N = Nam1_Item or else N = Nam2_Item then
return N;
end if;
Next_Rep_Item (N);
end loop;
return Empty;
end Get_Rep_Pragma;
---------------------
-- Get_Unary_Nkind --
---------------------
function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is
begin
case Chars (Op) is
when Name_Op_Abs =>
return N_Op_Abs;
when Name_Op_Subtract =>
return N_Op_Minus;
when Name_Op_Not =>
return N_Op_Not;
when Name_Op_Add =>
return N_Op_Plus;
when others =>
raise Program_Error;
end case;
end Get_Unary_Nkind;
---------------------------------
-- Has_External_Tag_Rep_Clause --
---------------------------------
function Has_External_Tag_Rep_Clause (T : Entity_Id) return Boolean is
begin
pragma Assert (Is_Tagged_Type (T));
return Has_Rep_Item (T, Name_External_Tag, Check_Parents => False);
end Has_External_Tag_Rep_Clause;
------------------
-- Has_Rep_Item --
------------------
function Has_Rep_Item
(E : Entity_Id;
Nam : Name_Id;
Check_Parents : Boolean := True) return Boolean
is
begin
return Present (Get_Rep_Item (E, Nam, Check_Parents));
end Has_Rep_Item;
function Has_Rep_Item
(E : Entity_Id;
Nam1 : Name_Id;
Nam2 : Name_Id;
Check_Parents : Boolean := True) return Boolean
is
begin
return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
end Has_Rep_Item;
--------------------
-- Has_Rep_Pragma --
--------------------
function Has_Rep_Pragma
(E : Entity_Id;
Nam : Name_Id;
Check_Parents : Boolean := True) return Boolean
is
begin
return Present (Get_Rep_Pragma (E, Nam, Check_Parents));
end Has_Rep_Pragma;
function Has_Rep_Pragma
(E : Entity_Id;
Nam1 : Name_Id;
Nam2 : Name_Id;
Check_Parents : Boolean := True) return Boolean
is
begin
return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
end Has_Rep_Pragma;
--------------------------------
-- Has_Unconstrained_Elements --
--------------------------------
function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is
U_T : constant Entity_Id := Underlying_Type (T);
begin
if No (U_T) then
return False;
elsif Is_Record_Type (U_T) then
return Has_Discriminants (U_T) and then not Is_Constrained (U_T);
elsif Is_Array_Type (U_T) then
return Has_Unconstrained_Elements (Component_Type (U_T));
else
return False;
end if;
end Has_Unconstrained_Elements;
----------------------
-- Has_Variant_Part --
----------------------
function Has_Variant_Part (Typ : Entity_Id) return Boolean is
FSTyp : Entity_Id;
Decl : Node_Id;
TDef : Node_Id;
CList : Node_Id;
begin
if not Is_Type (Typ) then
return False;
end if;
FSTyp := First_Subtype (Typ);
if not Has_Discriminants (FSTyp) then
return False;
end if;
-- Proceed with cautious checks here, return False if tree is not
-- as expected (may be caused by prior errors).
Decl := Declaration_Node (FSTyp);
if Nkind (Decl) /= N_Full_Type_Declaration then
return False;
end if;
TDef := Type_Definition (Decl);
if Nkind (TDef) /= N_Record_Definition then
return False;
end if;
CList := Component_List (TDef);
if Nkind (CList) /= N_Component_List then
return False;
else
return Present (Variant_Part (CList));
end if;
end Has_Variant_Part;
---------------------
-- In_Generic_Body --
---------------------
function In_Generic_Body (Id : Entity_Id) return Boolean is
S : Entity_Id;
begin
-- Climb scopes looking for generic body
S := Id;
while Present (S) and then S /= Standard_Standard loop
-- Generic package body
if Ekind (S) = E_Generic_Package
and then In_Package_Body (S)
then
return True;
-- Generic subprogram body
elsif Is_Subprogram (S)
and then Nkind (Unit_Declaration_Node (S))
= N_Generic_Subprogram_Declaration
then
return True;
end if;
S := Scope (S);
end loop;
-- False if top of scope stack without finding a generic body
return False;
end In_Generic_Body;
-------------------------------
-- Initialization_Suppressed --
-------------------------------
function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
begin
return Suppress_Initialization (Typ)
or else Suppress_Initialization (Base_Type (Typ));
end Initialization_Suppressed;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
Obsolescent_Warnings.Init;
end Initialize;
-------------
-- Is_Body --
-------------
function Is_Body (N : Node_Id) return Boolean is
begin
return
Nkind (N) in N_Body_Stub
or else Nkind_In (N, N_Entry_Body,
N_Package_Body,
N_Protected_Body,
N_Subprogram_Body,
N_Task_Body);
end Is_Body;
---------------------
-- Is_By_Copy_Type --
---------------------
function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
begin
-- If Id is a private type whose full declaration has not been seen,
-- we assume for now that it is not a By_Copy type. Clearly this
-- attribute should not be used before the type is frozen, but it is
-- needed to build the associated record of a protected type. Another
-- place where some lookahead for a full view is needed ???
return
Is_Elementary_Type (Ent)
or else (Is_Private_Type (Ent)
and then Present (Underlying_Type (Ent))
and then Is_Elementary_Type (Underlying_Type (Ent)));
end Is_By_Copy_Type;
--------------------------
-- Is_By_Reference_Type --
--------------------------
function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
Btype : constant Entity_Id := Base_Type (Ent);
begin
if Error_Posted (Ent) or else Error_Posted (Btype) then
return False;
elsif Is_Private_Type (Btype) then
declare
Utyp : constant Entity_Id := Underlying_Type (Btype);
begin
if No (Utyp) then
return False;
else
return Is_By_Reference_Type (Utyp);
end if;
end;
elsif Is_Incomplete_Type (Btype) then
declare
Ftyp : constant Entity_Id := Full_View (Btype);
begin
if No (Ftyp) then
return False;
else
return Is_By_Reference_Type (Ftyp);
end if;
end;
elsif Is_Concurrent_Type (Btype) then
return True;
elsif Is_Record_Type (Btype) then
if Is_Limited_Record (Btype)
or else Is_Tagged_Type (Btype)
or else Is_Volatile (Btype)
then
return True;
else
declare
C : Entity_Id;
begin
C := First_Component (Btype);
while Present (C) loop
-- For each component, test if its type is a by reference
-- type and if its type is volatile. Also test the component
-- itself for being volatile. This happens for example when
-- a Volatile aspect is added to a component.
if Is_By_Reference_Type (Etype (C))
or else Is_Volatile (Etype (C))
or else Is_Volatile (C)
then
return True;
end if;
C := Next_Component (C);
end loop;
end;
return False;
end if;
elsif Is_Array_Type (Btype) then
return
Is_Volatile (Btype)
or else Is_By_Reference_Type (Component_Type (Btype))
or else Is_Volatile (Component_Type (Btype))
or else Has_Volatile_Components (Btype);
else
return False;
end if;
end Is_By_Reference_Type;
---------------------
-- Is_Derived_Type --
---------------------
function Is_Derived_Type (Ent : E) return B is
Par : Node_Id;
begin
if Is_Type (Ent)
and then Base_Type (Ent) /= Root_Type (Ent)
and then not Is_Class_Wide_Type (Ent)
then
if not Is_Numeric_Type (Root_Type (Ent)) then
return True;
else
Par := Parent (First_Subtype (Ent));
return Present (Par)
and then Nkind (Par) = N_Full_Type_Declaration
and then Nkind (Type_Definition (Par)) =
N_Derived_Type_Definition;
end if;
else
return False;
end if;
end Is_Derived_Type;
-----------------------
-- Is_Generic_Formal --
-----------------------
function Is_Generic_Formal (E : Entity_Id) return Boolean is
Kind : Node_Kind;
begin
if No (E) then
return False;
else
Kind := Nkind (Parent (E));
return
Nkind_In (Kind, N_Formal_Object_Declaration,
N_Formal_Package_Declaration,
N_Formal_Type_Declaration)
or else Is_Formal_Subprogram (E);
end if;
end Is_Generic_Formal;
-------------------------------
-- Is_Immutably_Limited_Type --
-------------------------------
function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
Btype : constant Entity_Id := Available_View (Base_Type (Ent));
begin
if Is_Limited_Record (Btype) then
return True;
elsif Ekind (Btype) = E_Limited_Private_Type
and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
then
return not In_Package_Body (Scope ((Btype)));
elsif Is_Private_Type (Btype) then
-- AI05-0063: A type derived from a limited private formal type is
-- not immutably limited in a generic body.
if Is_Derived_Type (Btype)
and then Is_Generic_Type (Etype (Btype))
then
if not Is_Limited_Type (Etype (Btype)) then
return False;
-- A descendant of a limited formal type is not immutably limited
-- in the generic body, or in the body of a generic child.
elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
return not In_Package_Body (Scope (Btype));
else
return False;
end if;
else
declare
Utyp : constant Entity_Id := Underlying_Type (Btype);
begin
if No (Utyp) then
return False;
else
return Is_Immutably_Limited_Type (Utyp);
end if;
end;
end if;
elsif Is_Concurrent_Type (Btype) then
return True;
else
return False;
end if;
end Is_Immutably_Limited_Type;
---------------------------
-- Is_Indefinite_Subtype --
---------------------------
function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
K : constant Entity_Kind := Ekind (Ent);
begin
if Is_Constrained (Ent) then
return False;
elsif K in Array_Kind
or else K in Class_Wide_Kind
or else Has_Unknown_Discriminants (Ent)
then
return True;
-- Known discriminants: indefinite if there are no default values
elsif K in Record_Kind
or else Is_Incomplete_Or_Private_Type (Ent)
or else Is_Concurrent_Type (Ent)
then
return (Has_Discriminants (Ent)
and then
No (Discriminant_Default_Value (First_Discriminant (Ent))));
else
return False;
end if;
end Is_Indefinite_Subtype;
---------------------
-- Is_Limited_Type --
---------------------
function Is_Limited_Type (Ent : Entity_Id) return Boolean is
Btype : constant E := Base_Type (Ent);
Rtype : constant E := Root_Type (Btype);
begin
if not Is_Type (Ent) then
return False;
elsif Ekind (Btype) = E_Limited_Private_Type
or else Is_Limited_Composite (Btype)
then
return True;
elsif Is_Concurrent_Type (Btype) then
return True;
-- The Is_Limited_Record flag normally indicates that the type is
-- limited. The exception is that a type does not inherit limitedness
-- from its interface ancestor. So the type may be derived from a
-- limited interface, but is not limited.
elsif Is_Limited_Record (Ent)
and then not Is_Interface (Ent)
then
return True;
-- Otherwise we will look around to see if there is some other reason
-- for it to be limited, except that if an error was posted on the
-- entity, then just assume it is non-limited, because it can cause
-- trouble to recurse into a murky entity resulting from other errors.
elsif Error_Posted (Ent) then
return False;
elsif Is_Record_Type (Btype) then
if Is_Limited_Interface (Ent) then
return True;
-- AI-419: limitedness is not inherited from a limited interface
elsif Is_Limited_Record (Rtype) then
return not Is_Interface (Rtype)
or else Is_Protected_Interface (Rtype)
or else Is_Synchronized_Interface (Rtype)
or else Is_Task_Interface (Rtype);
elsif Is_Class_Wide_Type (Btype) then
return Is_Limited_Type (Rtype);
else
declare
C : E;
begin
C := First_Component (Btype);
while Present (C) loop
if Is_Limited_Type (Etype (C)) then
return True;
end if;
C := Next_Component (C);
end loop;
end;
return False;
end if;
elsif Is_Array_Type (Btype) then
return Is_Limited_Type (Component_Type (Btype));
else
return False;
end if;
end Is_Limited_Type;
---------------------
-- Is_Limited_View --
---------------------
function Is_Limited_View (Ent : Entity_Id) return Boolean is
Btype : constant Entity_Id := Available_View (Base_Type (Ent));
begin
if Is_Limited_Record (Btype) then
return True;
elsif Ekind (Btype) = E_Limited_Private_Type
and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
then
return not In_Package_Body (Scope ((Btype)));
elsif Is_Private_Type (Btype) then
-- AI05-0063: A type derived from a limited private formal type is
-- not immutably limited in a generic body.
if Is_Derived_Type (Btype)
and then Is_Generic_Type (Etype (Btype))
then
if not Is_Limited_Type (Etype (Btype)) then
return False;
-- A descendant of a limited formal type is not immutably limited
-- in the generic body, or in the body of a generic child.
elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
return not In_Package_Body (Scope (Btype));
else
return False;
end if;
else
declare
Utyp : constant Entity_Id := Underlying_Type (Btype);
begin
if No (Utyp) then
return False;
else
return Is_Limited_View (Utyp);
end if;
end;
end if;
elsif Is_Concurrent_Type (Btype) then
return True;
elsif Is_Record_Type (Btype) then
-- Note that we return True for all limited interfaces, even though
-- (unsynchronized) limited interfaces can have descendants that are
-- nonlimited, because this is a predicate on the type itself, and
-- things like functions with limited interface results need to be
-- handled as build in place even though they might return objects
-- of a type that is not inherently limited.
if Is_Class_Wide_Type (Btype) then
return Is_Limited_View (Root_Type (Btype));
else
declare
C : Entity_Id;
begin
C := First_Component (Btype);
while Present (C) loop
-- Don't consider components with interface types (which can
-- only occur in the case of a _parent component anyway).
-- They don't have any components, plus it would cause this
-- function to return true for nonlimited types derived from
-- limited interfaces.
if not Is_Interface (Etype (C))
and then Is_Limited_View (Etype (C))
then
return True;
end if;
C := Next_Component (C);
end loop;
end;
return False;
end if;
elsif Is_Array_Type (Btype) then
return Is_Limited_View (Component_Type (Btype));
else
return False;
end if;
end Is_Limited_View;
----------------------
-- Nearest_Ancestor --
----------------------
function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
D : constant Node_Id := Declaration_Node (Typ);
begin
-- If we have a subtype declaration, get the ancestor subtype
if Nkind (D) = N_Subtype_Declaration then
if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
return Entity (Subtype_Mark (Subtype_Indication (D)));
else
return Entity (Subtype_Indication (D));
end if;
-- If derived type declaration, find who we are derived from
elsif Nkind (D) = N_Full_Type_Declaration
and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
then
declare
DTD : constant Entity_Id := Type_Definition (D);
SI : constant Entity_Id := Subtype_Indication (DTD);
begin
if Is_Entity_Name (SI) then
return Entity (SI);
else
return Entity (Subtype_Mark (SI));
end if;
end;
-- If derived type and private type, get the full view to find who we
-- are derived from.
elsif Is_Derived_Type (Typ)
and then Is_Private_Type (Typ)
and then Present (Full_View (Typ))
then
return Nearest_Ancestor (Full_View (Typ));
-- Otherwise, nothing useful to return, return Empty
else
return Empty;
end if;
end Nearest_Ancestor;
---------------------------
-- Nearest_Dynamic_Scope --
---------------------------
function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
begin
if Is_Dynamic_Scope (Ent) then
return Ent;
else
return Enclosing_Dynamic_Scope (Ent);
end if;
end Nearest_Dynamic_Scope;
------------------------
-- Next_Tag_Component --
------------------------
function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
Comp : Entity_Id;
begin
pragma Assert (Is_Tag (Tag));
-- Loop to look for next tag component
Comp := Next_Entity (Tag);
while Present (Comp) loop
if Is_Tag (Comp) then
pragma Assert (Chars (Comp) /= Name_uTag);
return Comp;
end if;
Comp := Next_Entity (Comp);
end loop;
-- No tag component found
return Empty;
end Next_Tag_Component;
--------------------------
-- Number_Discriminants --
--------------------------
function Number_Discriminants (Typ : Entity_Id) return Pos is
N : Int;
Discr : Entity_Id;
begin
N := 0;
Discr := First_Discriminant (Typ);
while Present (Discr) loop
N := N + 1;
Discr := Next_Discriminant (Discr);
end loop;
return N;
end Number_Discriminants;
----------------------------------------------
-- Object_Type_Has_Constrained_Partial_View --
----------------------------------------------
function Object_Type_Has_Constrained_Partial_View
(Typ : Entity_Id;
Scop : Entity_Id) return Boolean
is
begin
return Has_Constrained_Partial_View (Typ)
or else (In_Generic_Body (Scop)
and then Is_Generic_Type (Base_Type (Typ))
and then Is_Private_Type (Base_Type (Typ))
and then not Is_Tagged_Type (Typ)
and then not (Is_Array_Type (Typ)
and then not Is_Constrained (Typ))
and then Has_Discriminants (Typ));
end Object_Type_Has_Constrained_Partial_View;
---------------------------
-- Package_Specification --
---------------------------
function Package_Specification (Pack_Id : Entity_Id) return Node_Id is
N : Node_Id;
begin
N := Parent (Pack_Id);
while Nkind (N) /= N_Package_Specification loop
N := Parent (N);
if No (N) then
raise Program_Error;
end if;
end loop;
return N;
end Package_Specification;
---------------
-- Tree_Read --
---------------
procedure Tree_Read is
begin
Obsolescent_Warnings.Tree_Read;
end Tree_Read;
----------------
-- Tree_Write --
----------------
procedure Tree_Write is
begin
Obsolescent_Warnings.Tree_Write;
end Tree_Write;
--------------------
-- Ultimate_Alias --
--------------------
function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
E : Entity_Id := Prim;
begin
while Present (Alias (E)) loop
pragma Assert (Alias (E) /= E);
E := Alias (E);
end loop;
return E;
end Ultimate_Alias;
--------------------------
-- Unit_Declaration_Node --
--------------------------
function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
N : Node_Id := Parent (Unit_Id);
begin
-- Predefined operators do not have a full function declaration
if Ekind (Unit_Id) = E_Operator then
return N;
end if;
-- Isn't there some better way to express the following ???
while Nkind (N) /= N_Abstract_Subprogram_Declaration
and then Nkind (N) /= N_Formal_Package_Declaration
and then Nkind (N) /= N_Function_Instantiation
and then Nkind (N) /= N_Generic_Package_Declaration
and then Nkind (N) /= N_Generic_Subprogram_Declaration
and then Nkind (N) /= N_Package_Declaration
and then Nkind (N) /= N_Package_Body
and then Nkind (N) /= N_Package_Instantiation
and then Nkind (N) /= N_Package_Renaming_Declaration
and then Nkind (N) /= N_Procedure_Instantiation
and then Nkind (N) /= N_Protected_Body
and then Nkind (N) /= N_Subprogram_Declaration
and then Nkind (N) /= N_Subprogram_Body
and then Nkind (N) /= N_Subprogram_Body_Stub
and then Nkind (N) /= N_Subprogram_Renaming_Declaration
and then Nkind (N) /= N_Task_Body
and then Nkind (N) /= N_Task_Type_Declaration
and then Nkind (N) not in N_Formal_Subprogram_Declaration
and then Nkind (N) not in N_Generic_Renaming_Declaration
loop
N := Parent (N);
-- We don't use Assert here, because that causes an infinite loop
-- when assertions are turned off. Better to crash.
if No (N) then
raise Program_Error;
end if;
end loop;
return N;
end Unit_Declaration_Node;
end Sem_Aux;
gprbuild-gpl-2014-src/gnat/prj-nmsc.adb 0000644 0000767 0000145 00001142040 12323721731 017267 0 ustar gnatmail gnat ------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . N M S C --
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2013, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Err_Vars; use Err_Vars;
with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
with Prj.Com;
with Prj.Env; use Prj.Env;
with Prj.Err; use Prj.Err;
with Prj.Tree; use Prj.Tree;
with Prj.Util; use Prj.Util;
with Sinput.P;
with Snames; use Snames;
with Targparm; use Targparm;
with Ada; use Ada;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Directories; use Ada.Directories;
with Ada.Strings; use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Dynamic_HTables;
with GNAT.Regexp; use GNAT.Regexp;
with GNAT.Table;
package body Prj.Nmsc is
No_Continuation_String : aliased String := "";
Continuation_String : aliased String := "\";
-- Used in Check_Library for continuation error messages at the same
-- location.
type Name_Location is record
Name : File_Name_Type;
-- Key is duplicated, so that it is known when using functions Get_First
-- and Get_Next, as these functions only return an Element.
Location : Source_Ptr;
Source : Source_Id := No_Source;
Listed : Boolean := False;
Found : Boolean := False;
end record;
No_Name_Location : constant Name_Location :=
(Name => No_File,
Location => No_Location,
Source => No_Source,
Listed => False,
Found => False);
package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => Header_Num,
Element => Name_Location,
No_Element => No_Name_Location,
Key => File_Name_Type,
Hash => Hash,
Equal => "=");
-- File name information found in string list attribute (Source_Files or
-- Source_List_File). Used to check that all referenced files were indeed
-- found on the disk.
type Unit_Exception is record
Name : Name_Id;
-- Key is duplicated, so that it is known when using functions Get_First
-- and Get_Next, as these functions only return an Element.
Spec : File_Name_Type;
Impl : File_Name_Type;
end record;
No_Unit_Exception : constant Unit_Exception := (No_Name, No_File, No_File);
package Unit_Exceptions_Htable is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => Header_Num,
Element => Unit_Exception,
No_Element => No_Unit_Exception,
Key => Name_Id,
Hash => Hash,
Equal => "=");
-- Record special naming schemes for Ada units (name of spec file and name
-- of implementation file). The elements in this list come from the naming
-- exceptions specified in the project files.
type File_Found is record
File : File_Name_Type := No_File;
Excl_File : File_Name_Type := No_File;
Excl_Line : Natural := 0;
Found : Boolean := False;
Location : Source_Ptr := No_Location;
end record;
No_File_Found : constant File_Found :=
(No_File, No_File, 0, False, No_Location);
package Excluded_Sources_Htable is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => Header_Num,
Element => File_Found,
No_Element => No_File_Found,
Key => File_Name_Type,
Hash => Hash,
Equal => "=");
-- A hash table to store the base names of excluded files, if any
package Object_File_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => Header_Num,
Element => Source_Id,
No_Element => No_Source,
Key => File_Name_Type,
Hash => Hash,
Equal => "=");
-- A hash table to store the object file names for a project, to check that
-- two different sources have different object file names.
type Project_Processing_Data is record
Project : Project_Id;
Source_Names : Source_Names_Htable.Instance;
Unit_Exceptions : Unit_Exceptions_Htable.Instance;
Excluded : Excluded_Sources_Htable.Instance;
Source_List_File_Location : Source_Ptr;
-- Location of the Source_List_File attribute, for error messages
end record;
-- This is similar to Tree_Processing_Data, but contains project-specific
-- information which is only useful while processing the project, and can
-- be discarded as soon as we have finished processing the project
type Tree_Processing_Data is record
Tree : Project_Tree_Ref;
Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
Flags : Prj.Processing_Flags;
In_Aggregate_Lib : Boolean;
end record;
-- Temporary data which is needed while parsing a project. It does not need
-- to be kept in memory once a project has been fully loaded, but is
-- necessary while performing consistency checks (duplicate sources,...)
-- This data must be initialized before processing any project, and the
-- same data is used for processing all projects in the tree.
type Lib_Data is record
Name : Name_Id;
Proj : Project_Id;
Tree : Project_Tree_Ref;
end record;
package Lib_Data_Table is new GNAT.Table
(Table_Component_Type => Lib_Data,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100);
-- A table to record library names in order to check that two library
-- projects do not have the same library names.
procedure Initialize
(Data : out Tree_Processing_Data;
Tree : Project_Tree_Ref;
Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
Flags : Prj.Processing_Flags);
-- Initialize Data
procedure Free (Data : in out Tree_Processing_Data);
-- Free the memory occupied by Data
procedure Initialize
(Data : in out Project_Processing_Data;
Project : Project_Id);
procedure Free (Data : in out Project_Processing_Data);
-- Initialize or free memory for a project-specific data
procedure Find_Excluded_Sources
(Project : in out Project_Processing_Data;
Data : in out Tree_Processing_Data);
-- Find the list of files that should not be considered as source files
-- for this project. Sets the list in the Project.Excluded_Sources_Htable.
procedure Override_Kind (Source : Source_Id; Kind : Source_Kind);
-- Override the reference kind for a source file. This properly updates
-- the unit data if necessary.
procedure Load_Naming_Exceptions
(Project : in out Project_Processing_Data;
Data : in out Tree_Processing_Data);
-- All source files in Data.First_Source are considered as naming
-- exceptions, and copied into the Source_Names and Unit_Exceptions tables
-- as appropriate.
type Search_Type is (Search_Files, Search_Directories);
generic
with procedure Callback
(Path : Path_Information;
Pattern_Index : Natural);
procedure Expand_Subdirectory_Pattern
(Project : Project_Id;
Data : in out Tree_Processing_Data;
Patterns : String_List_Id;
Ignore : String_List_Id;
Search_For : Search_Type;
Resolve_Links : Boolean);
-- Search the subdirectories of Project's directory for files or
-- directories that match the globbing patterns found in Patterns (for
-- instance "**/*.adb"). Typically, Patterns will be the value of the
-- Source_Dirs or Excluded_Source_Dirs attributes.
--
-- Every time such a file or directory is found, the callback is called.
-- Resolve_Links indicates whether we should resolve links while
-- normalizing names.
--
-- In the callback, Pattern_Index is the index within Patterns where the
-- expanded pattern was found (1 for the first element of Patterns and
-- all its matching directories, then 2,...).
--
-- We use a generic and not an access-to-subprogram because in some cases
-- this code is compiled with the restriction No_Implicit_Dynamic_Code.
-- An error message is raised if a pattern does not match any file.
procedure Add_Source
(Id : out Source_Id;
Data : in out Tree_Processing_Data;
Project : Project_Id;
Source_Dir_Rank : Natural;
Lang_Id : Language_Ptr;
Kind : Source_Kind;
File_Name : File_Name_Type;
Display_File : File_Name_Type;
Naming_Exception : Naming_Exception_Type := No;
Path : Path_Information := No_Path_Information;
Alternate_Languages : Language_List := null;
Unit : Name_Id := No_Name;
Index : Int := 0;
Locally_Removed : Boolean := False;
Location : Source_Ptr := No_Location);
-- Add a new source to the different lists: list of all sources in the
-- project tree, list of source of a project and list of sources of a
-- language. If Path is specified, the file is also added to
-- Source_Paths_HT. Location is used for error messages
function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type;
-- Same as Osint.Canonical_Case_File_Name but applies to Name_Id.
-- This alters Name_Buffer.
function Suffix_Matches
(Filename : String;
Suffix : File_Name_Type) return Boolean;
-- True if the file name ends with the given suffix. Always returns False
-- if Suffix is No_Name.
procedure Replace_Into_Name_Buffer
(Str : String;
Pattern : String;
Replacement : Character);
-- Copy Str into Name_Buffer, replacing Pattern with Replacement. Str is
-- converted to lower-case at the same time.
procedure Check_Abstract_Project
(Project : Project_Id;
Data : in out Tree_Processing_Data);
-- Check abstract projects attributes
procedure Check_Configuration
(Project : Project_Id;
Data : in out Tree_Processing_Data);
-- Check the configuration attributes for the project
procedure Check_If_Externally_Built
(Project : Project_Id;
Data : in out Tree_Processing_Data);
-- Check attribute Externally_Built of project Project in project tree
-- Data.Tree and modify its data Data if it has the value "true".
procedure Check_Interfaces
(Project : Project_Id;
Data : in out Tree_Processing_Data);
-- If a list of sources is specified in attribute Interfaces, set
-- In_Interfaces only for the sources specified in the list.
procedure Check_Library_Attributes
(Project : Project_Id;
Data : in out Tree_Processing_Data);
-- Check the library attributes of project Project in project tree
-- and modify its data Data accordingly.
procedure Check_Package_Naming
(Project : Project_Id;
Data : in out Tree_Processing_Data);
-- Check the naming scheme part of Data, and initialize the naming scheme
-- data in the config of the various languages.
procedure Check_Programming_Languages
(Project : Project_Id;
Data : in out Tree_Processing_Data);
-- Check attribute Languages for the project with data Data in project
-- tree Data.Tree and set the components of Data for all the programming
-- languages indicated in attribute Languages, if any.
procedure Check_Stand_Alone_Library
(Project : Project_Id;
Data : in out Tree_Processing_Data);
-- Check if project Project in project tree Data.Tree is a Stand-Alone
-- Library project, and modify its data Data accordingly if it is one.
procedure Check_Unit_Name (Name : String; Unit : out Name_Id);
-- Check that a name is a valid unit name
function Compute_Directory_Last (Dir : String) return Natural;
-- Return the index of the last significant character in Dir. This is used
-- to avoid duplicate '/' (slash) characters at the end of directory names.
procedure Search_Directories
(Project : in out Project_Processing_Data;
Data : in out Tree_Processing_Data;
For_All_Sources : Boolean);
-- Search the source directories to find the sources. If For_All_Sources is
-- True, check each regular file name against the naming schemes of the
-- various languages. Otherwise consider only the file names in hash table
-- Source_Names. If Allow_Duplicate_Basenames then files with identical
-- base names are permitted within a project for source-based languages
-- (never for unit based languages).
procedure Check_File
(Project : in out Project_Processing_Data;
Data : in out Tree_Processing_Data;
Source_Dir_Rank : Natural;
Path : Path_Name_Type;
Display_Path : Path_Name_Type;
File_Name : File_Name_Type;
Display_File_Name : File_Name_Type;
Locally_Removed : Boolean;
For_All_Sources : Boolean);
-- Check if file File_Name is a valid source of the project. This is used
-- in multi-language mode only. When the file matches one of the naming
-- schemes, it is added to various htables through Add_Source and to
-- Source_Paths_Htable.
--
-- File_Name is the same as Display_File_Name, but has been normalized.
-- They do not include the directory information.
--
-- Path and Display_Path on the other hand are the full path to the file.
-- Path must have been normalized (canonical casing and possibly links
-- resolved).
--
-- Source_Directory is the directory in which the file was found. It is
-- neither normalized nor has had links resolved, and must not end with a
-- a directory separator, to avoid duplicates later on.
--
-- If For_All_Sources is True, then all possible file names are analyzed
-- otherwise only those currently set in the Source_Names hash table.
procedure Check_File_Naming_Schemes
(Project : Project_Processing_Data;
File_Name : File_Name_Type;
Alternate_Languages : out Language_List;
Language : out Language_Ptr;
Display_Language_Name : out Name_Id;
Unit : out Name_Id;
Lang_Kind : out Language_Kind;
Kind : out Source_Kind);
-- Check if the file name File_Name conforms to one of the naming schemes
-- of the project. If the file does not match one of the naming schemes,
-- set Language to No_Language_Index. Filename is the name of the file
-- being investigated. It has been normalized (case-folded). File_Name is
-- the same value.
procedure Get_Directories
(Project : Project_Id;
Data : in out Tree_Processing_Data);
-- Get the object directory, the exec directory and the source directories
-- of a project.
procedure Get_Mains
(Project : Project_Id;
Data : in out Tree_Processing_Data);
-- Get the mains of a project from attribute Main, if it exists, and put
-- them in the project data.
procedure Get_Sources_From_File
(Path : String;
Location : Source_Ptr;
Project : in out Project_Processing_Data;
Data : in out Tree_Processing_Data);
-- Get the list of sources from a text file and put them in hash table
-- Source_Names.
procedure Find_Sources
(Project : in out Project_Processing_Data;
Data : in out Tree_Processing_Data);
-- Process the Source_Files and Source_List_File attributes, and store the
-- list of source files into the Source_Names htable. When these attributes
-- are not defined, find all files matching the naming schemes in the
-- source directories. If Allow_Duplicate_Basenames, then files with the
-- same base names are authorized within a project for source-based
-- languages (never for unit based languages)
procedure Compute_Unit_Name
(File_Name : File_Name_Type;
Naming : Lang_Naming_Data;
Kind : out Source_Kind;
Unit : out Name_Id;
Project : Project_Processing_Data);
-- Check whether the file matches the naming scheme. If it does,
-- compute its unit name. If Unit is set to No_Name on exit, none of the
-- other out parameters are relevant.
procedure Check_Illegal_Suffix
(Project : Project_Id;
Suffix : File_Name_Type;
Dot_Replacement : File_Name_Type;
Attribute_Name : String;
Location : Source_Ptr;
Data : in out Tree_Processing_Data);
-- Display an error message if the given suffix is illegal for some reason.
-- The name of the attribute we are testing is specified in Attribute_Name,
-- which is used in the error message. Location is the location where the
-- suffix is defined.
procedure Locate_Directory
(Project : Project_Id;
Name : File_Name_Type;
Path : out Path_Information;
Dir_Exists : out Boolean;
Data : in out Tree_Processing_Data;
Create : String := "";
Location : Source_Ptr := No_Location;
Must_Exist : Boolean := True;
Externally_Built : Boolean := False);
-- Locate a directory. Name is the directory name. Relative paths are
-- resolved relative to the project's directory. If the directory does not
-- exist and Setup_Projects is True and Create is a non null string, an
-- attempt is made to create the directory. If the directory does not
-- exist, it is either created if Setup_Projects is False (and then
-- returned), or simply returned without checking for its existence (if
-- Must_Exist is False) or No_Path_Information is returned. In all cases,
-- Dir_Exists indicates whether the directory now exists. Create is also
-- used for debugging traces to show which path we are computing.
procedure Look_For_Sources
(Project : in out Project_Processing_Data;
Data : in out Tree_Processing_Data);
-- Find all the sources of project Project in project tree Data.Tree and
-- update its Data accordingly. This assumes that the special naming
-- exceptions have already been processed.
function Path_Name_Of
(File_Name : File_Name_Type;
Directory : Path_Name_Type) return String;
-- Returns the path name of a (non project) file. Returns an empty string
-- if file cannot be found.
procedure Remove_Source
(Tree : Project_Tree_Ref;
Id : Source_Id;
Replaced_By : Source_Id);
-- Remove a file from the list of sources of a project. This might be
-- because the file is replaced by another one in an extending project,
-- or because a file was added as a naming exception but was not found
-- in the end.
procedure Report_No_Sources
(Project : Project_Id;
Lang_Name : String;
Data : Tree_Processing_Data;
Location : Source_Ptr;
Continuation : Boolean := False);
-- Report an error or a warning depending on the value of When_No_Sources
-- when there are no sources for language Lang_Name.
procedure Show_Source_Dirs
(Project : Project_Id;
Shared : Shared_Project_Tree_Data_Access);
-- List all the source directories of a project
procedure Write_Attr (Name, Value : String);
-- Debug print a value for a specific property. Does nothing when not in
-- debug mode
procedure Error_Or_Warning
(Flags : Processing_Flags;
Kind : Error_Warning;
Msg : String;
Location : Source_Ptr;
Project : Project_Id);
-- Emits either an error or warning message (or nothing), depending on Kind
function No_Space_Img (N : Natural) return String;
-- Image of a Natural without the initial space
----------------------
-- Error_Or_Warning --
----------------------
procedure Error_Or_Warning
(Flags : Processing_Flags;
Kind : Error_Warning;
Msg : String;
Location : Source_Ptr;
Project : Project_Id) is
begin
case Kind is
when Error => Error_Msg (Flags, Msg, Location, Project);
when Warning => Error_Msg (Flags, "?" & Msg, Location, Project);
when Silent => null;
end case;
end Error_Or_Warning;
------------------------------
-- Replace_Into_Name_Buffer --
------------------------------
procedure Replace_Into_Name_Buffer
(Str : String;
Pattern : String;
Replacement : Character)
is
Max : constant Integer := Str'Last - Pattern'Length + 1;
J : Positive;
begin
Name_Len := 0;
J := Str'First;
while J <= Str'Last loop
Name_Len := Name_Len + 1;
if J <= Max
and then Str (J .. J + Pattern'Length - 1) = Pattern
then
Name_Buffer (Name_Len) := Replacement;
J := J + Pattern'Length;
else
Name_Buffer (Name_Len) := GNAT.Case_Util.To_Lower (Str (J));
J := J + 1;
end if;
end loop;
end Replace_Into_Name_Buffer;
--------------------
-- Suffix_Matches --
--------------------
function Suffix_Matches
(Filename : String;
Suffix : File_Name_Type) return Boolean
is
Min_Prefix_Length : Natural := 0;
begin
if Suffix = No_File or else Suffix = Empty_File then
return False;
end if;
declare
Suf : String := Get_Name_String (Suffix);
begin
-- On non case-sensitive systems, use proper suffix casing
Canonical_Case_File_Name (Suf);
-- The file name must end with the suffix (which is not an extension)
-- For instance a suffix "configure.in" must match a file with the
-- same name. To avoid dummy cases, though, a suffix starting with
-- '.' requires a file that is at least one character longer ('.cpp'
-- should not match a file with the same name).
if Suf (Suf'First) = '.' then
Min_Prefix_Length := 1;
end if;
return Filename'Length >= Suf'Length + Min_Prefix_Length
and then
Filename (Filename'Last - Suf'Length + 1 .. Filename'Last) = Suf;
end;
end Suffix_Matches;
----------------
-- Write_Attr --
----------------
procedure Write_Attr (Name, Value : String) is
begin
if Current_Verbosity = High then
Debug_Output (Name & " = """ & Value & '"');
end if;
end Write_Attr;
----------------
-- Add_Source --
----------------
procedure Add_Source
(Id : out Source_Id;
Data : in out Tree_Processing_Data;
Project : Project_Id;
Source_Dir_Rank : Natural;
Lang_Id : Language_Ptr;
Kind : Source_Kind;
File_Name : File_Name_Type;
Display_File : File_Name_Type;
Naming_Exception : Naming_Exception_Type := No;
Path : Path_Information := No_Path_Information;
Alternate_Languages : Language_List := null;
Unit : Name_Id := No_Name;
Index : Int := 0;
Locally_Removed : Boolean := False;
Location : Source_Ptr := No_Location)
is
Config : constant Language_Config := Lang_Id.Config;
UData : Unit_Index;
Add_Src : Boolean;
Source : Source_Id;
Prev_Unit : Unit_Index := No_Unit_Index;
Source_To_Replace : Source_Id := No_Source;
begin
-- Check if the same file name or unit is used in the prj tree
Add_Src := True;
if Unit /= No_Name then
Prev_Unit := Units_Htable.Get (Data.Tree.Units_HT, Unit);
end if;
if Prev_Unit /= No_Unit_Index
and then (Kind = Impl or else Kind = Spec)
and then Prev_Unit.File_Names (Kind) /= null
then
-- Suspicious, we need to check later whether this is authorized
Add_Src := False;
Source := Prev_Unit.File_Names (Kind);
else
Source := Source_Files_Htable.Get
(Data.Tree.Source_Files_HT, File_Name);
if Source /= No_Source and then Source.Index = Index then
Add_Src := False;
end if;
end if;
-- Always add the source if it is locally removed, to avoid incorrect
-- duplicate checks.
if Locally_Removed then
Add_Src := True;
-- A locally removed source may first replace a source in a project
-- being extended.
if Source /= No_Source
and then Is_Extending (Project, Source.Project)
and then Naming_Exception /= Inherited
then
Source_To_Replace := Source;
end if;
else
-- Duplication of file/unit in same project is allowed if order of
-- source directories is known, or if there is no compiler for the
-- language.
if Add_Src = False then
Add_Src := True;
if Project = Source.Project then
if Prev_Unit = No_Unit_Index then
if Data.Flags.Allow_Duplicate_Basenames then
Add_Src := True;
elsif Lang_Id.Config.Compiler_Driver = Empty_File then
Add_Src := True;
elsif Source_Dir_Rank /= Source.Source_Dir_Rank then
Add_Src := False;
else
Error_Msg_File_1 := File_Name;
Error_Msg
(Data.Flags, "duplicate source file name {",
Location, Project);
Add_Src := False;
end if;
else
if Source_Dir_Rank /= Source.Source_Dir_Rank then
Add_Src := False;
-- We might be seeing the same file through a different
-- path (for instance because of symbolic links).
elsif Source.Path.Name /= Path.Name then
if not Source.Duplicate_Unit then
Error_Msg_Name_1 := Unit;
Error_Msg
(Data.Flags,
"\duplicate unit %%",
Location,
Project);
Source.Duplicate_Unit := True;
end if;
Add_Src := False;
end if;
end if;
-- Do not allow the same unit name in different projects,
-- except if one is extending the other.
-- For a file based language, the same file name replaces a
-- file in a project being extended, but it is allowed to have
-- the same file name in unrelated projects.
elsif Is_Extending (Project, Source.Project) then
if not Locally_Removed
and then Naming_Exception /= Inherited
then
Source_To_Replace := Source;
end if;
elsif Prev_Unit /= No_Unit_Index
and then Prev_Unit.File_Names (Kind) /= null
and then not Source.Locally_Removed
and then Source.Replaced_By = No_Source
and then not Data.In_Aggregate_Lib
then
-- Path is set if this is a source we found on the disk, in
-- which case we can provide more explicit error message. Path
-- is unset when the source is added from one of the naming
-- exceptions in the project.
if Path /= No_Path_Information then
Error_Msg_Name_1 := Unit;
Error_Msg
(Data.Flags,
"unit %% cannot belong to several projects",
Location, Project);
Error_Msg_Name_1 := Project.Name;
Error_Msg_Name_2 := Name_Id (Path.Display_Name);
Error_Msg
(Data.Flags, "\ project %%, %%", Location, Project);
Error_Msg_Name_1 := Source.Project.Name;
Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name);
Error_Msg
(Data.Flags, "\ project %%, %%", Location, Project);
else
Error_Msg_Name_1 := Unit;
Error_Msg_Name_2 := Source.Project.Name;
Error_Msg
(Data.Flags, "unit %% already belongs to project %%",
Location, Project);
end if;
Add_Src := False;
elsif not Source.Locally_Removed
and then Source.Replaced_By /= No_Source
and then not Data.Flags.Allow_Duplicate_Basenames
and then Lang_Id.Config.Kind = Unit_Based
and then Source.Language.Config.Kind = Unit_Based
and then not Data.In_Aggregate_Lib
then
Error_Msg_File_1 := File_Name;
Error_Msg_File_2 := File_Name_Type (Source.Project.Name);
Error_Msg
(Data.Flags,
"{ is already a source of project {", Location, Project);
-- Add the file anyway, to avoid further warnings like
-- "language unknown".
Add_Src := True;
end if;
end if;
end if;
if not Add_Src then
return;
end if;
-- Add the new file
Id := new Source_Data;
if Current_Verbosity = High then
Debug_Indent;
Write_Str ("adding source File: ");
Write_Str (Get_Name_String (Display_File));
if Index /= 0 then
Write_Str (" at" & Index'Img);
end if;
if Lang_Id.Config.Kind = Unit_Based then
Write_Str (" Unit: ");
-- ??? in gprclean, it seems we sometimes pass an empty Unit name
-- (see test extended_projects).
if Unit /= No_Name then
Write_Str (Get_Name_String (Unit));
end if;
Write_Str (" Kind: ");
Write_Str (Source_Kind'Image (Kind));
end if;
Write_Eol;
end if;
Id.Project := Project;
Id.Location := Location;
Id.Source_Dir_Rank := Source_Dir_Rank;
Id.Language := Lang_Id;
Id.Kind := Kind;
Id.Alternate_Languages := Alternate_Languages;
Id.Locally_Removed := Locally_Removed;
Id.Index := Index;
Id.File := File_Name;
Id.Display_File := Display_File;
Id.Dep_Name := Dependency_Name
(File_Name, Lang_Id.Config.Dependency_Kind);
Id.Naming_Exception := Naming_Exception;
Id.Object := Object_Name
(File_Name, Config.Object_File_Suffix);
Id.Switches := Switches_Name (File_Name);
-- Add the source id to the Unit_Sources_HT hash table, if the unit name
-- is not null.
if Unit /= No_Name then
-- Note: we might be creating a dummy unit here, when we in fact have
-- a separate. For instance, file file-bar.adb will initially be
-- assumed to be the IMPL of unit "file.bar". Only later on (in
-- Check_Object_Files) will we parse those units that only have an
-- impl and no spec to make sure whether we have a Separate in fact
-- (that significantly reduces the number of times we need to parse
-- the files, since we are then only interested in those with no
-- spec). We still need those dummy units in the table, since that's
-- the name we find in the ALI file
UData := Units_Htable.Get (Data.Tree.Units_HT, Unit);
if UData = No_Unit_Index then
UData := new Unit_Data;
UData.Name := Unit;
if Naming_Exception /= Inherited then
Units_Htable.Set (Data.Tree.Units_HT, Unit, UData);
end if;
end if;
Id.Unit := UData;
-- Note that this updates Unit information as well
if Naming_Exception /= Inherited and then not Locally_Removed then
Override_Kind (Id, Kind);
end if;
end if;
if Path /= No_Path_Information then
Id.Path := Path;
Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, Path.Name, Id);
end if;
Id.Next_With_File_Name :=
Source_Files_Htable.Get (Data.Tree.Source_Files_HT, File_Name);
Source_Files_Htable.Set (Data.Tree.Source_Files_HT, File_Name, Id);
if Index /= 0 then
Project.Has_Multi_Unit_Sources := True;
end if;
-- Add the source to the language list
Id.Next_In_Lang := Lang_Id.First_Source;
Lang_Id.First_Source := Id;
if Source_To_Replace /= No_Source then
Remove_Source (Data.Tree, Source_To_Replace, Id);
end if;
if Data.Tree.Replaced_Source_Number > 0
and then
Replaced_Source_HTable.Get
(Data.Tree.Replaced_Sources, Id.File) /= No_File
then
Replaced_Source_HTable.Remove (Data.Tree.Replaced_Sources, Id.File);
Data.Tree.Replaced_Source_Number :=
Data.Tree.Replaced_Source_Number - 1;
end if;
end Add_Source;
------------------------------
-- Canonical_Case_File_Name --
------------------------------
function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type is
begin
if Osint.File_Names_Case_Sensitive then
return File_Name_Type (Name);
else
Get_Name_String (Name);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
return Name_Find;
end if;
end Canonical_Case_File_Name;
---------------------------------
-- Process_Aggregated_Projects --
---------------------------------
procedure Process_Aggregated_Projects
(Tree : Project_Tree_Ref;
Project : Project_Id;
Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
Flags : Processing_Flags)
is
Data : Tree_Processing_Data :=
(Tree => Tree,
Node_Tree => Node_Tree,
Flags => Flags,
In_Aggregate_Lib => False);
Project_Files : constant Prj.Variable_Value :=
Prj.Util.Value_Of
(Snames.Name_Project_Files,
Project.Decl.Attributes,
Tree.Shared);
Project_Path_For_Aggregate : Prj.Env.Project_Search_Path;
procedure Found_Project_File (Path : Path_Information; Rank : Natural);
-- Called for each project file aggregated by Project
procedure Expand_Project_Files is
new Expand_Subdirectory_Pattern (Callback => Found_Project_File);
-- Search for all project files referenced by the patterns given in
-- parameter. Calls Found_Project_File for each of them.
------------------------
-- Found_Project_File --
------------------------
procedure Found_Project_File (Path : Path_Information; Rank : Natural) is
pragma Unreferenced (Rank);
begin
if Path.Name /= Project.Path.Name then
Debug_Output ("aggregates: ", Name_Id (Path.Display_Name));
-- For usual "with" statement, this phase will have been done when
-- parsing the project itself. However, for aggregate projects, we
-- can only do this when processing the aggregate project, since
-- the exact list of project files or project directories can
-- depend on scenario variables.
--
-- We only load the projects explicitly here, but do not process
-- them. For the processing, Prj.Proc will take care of processing
-- them, within the same call to Recursive_Process (thus avoiding
-- the processing of a given project multiple times).
--
-- ??? We might already have loaded the project
Add_Aggregated_Project (Project, Path => Path.Name);
else
Debug_Output ("pattern returned the aggregate itself, ignored");
end if;
end Found_Project_File;
-- Start of processing for Check_Aggregate_Project
begin
pragma Assert (Project.Qualifier in Aggregate_Project);
if Project_Files.Default then
Error_Msg_Name_1 := Snames.Name_Project_Files;
Error_Msg
(Flags,
"Attribute %% must be specified in aggregate project",
Project.Location, Project);
return;
end if;
-- The aggregated projects are only searched relative to the directory
-- of the aggregate project, not in the default project path.
Initialize_Empty (Project_Path_For_Aggregate);
Free (Project.Aggregated_Projects);
-- Look for aggregated projects. For similarity with source files and
-- dirs, the aggregated project files are not searched for on the
-- project path, and are only found through the path specified in
-- the Project_Files attribute.
Expand_Project_Files
(Project => Project,
Data => Data,
Patterns => Project_Files.Values,
Ignore => Nil_String,
Search_For => Search_Files,
Resolve_Links => Opt.Follow_Links_For_Files);
Free (Project_Path_For_Aggregate);
end Process_Aggregated_Projects;
----------------------------
-- Check_Abstract_Project --
----------------------------
procedure Check_Abstract_Project
(Project : Project_Id;
Data : in out Tree_Processing_Data)
is
Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
Source_Dirs : constant Variable_Value :=
Util.Value_Of
(Name_Source_Dirs,
Project.Decl.Attributes, Shared);
Source_Files : constant Variable_Value :=
Util.Value_Of
(Name_Source_Files,
Project.Decl.Attributes, Shared);
Source_List_File : constant Variable_Value :=
Util.Value_Of
(Name_Source_List_File,
Project.Decl.Attributes, Shared);
Languages : constant Variable_Value :=
Util.Value_Of
(Name_Languages,
Project.Decl.Attributes, Shared);
begin
if Project.Source_Dirs /= Nil_String then
if Source_Dirs.Values = Nil_String
and then Source_Files.Values = Nil_String
and then Languages.Values = Nil_String
and then Source_List_File.Default
then
Project.Source_Dirs := Nil_String;
else
Error_Msg
(Data.Flags,
"at least one of Source_Files, Source_Dirs or Languages "
& "must be declared empty for an abstract project",
Project.Location, Project);
end if;
end if;
end Check_Abstract_Project;
-------------------------
-- Check_Configuration --
-------------------------
procedure Check_Configuration
(Project : Project_Id;
Data : in out Tree_Processing_Data)
is
Shared : constant Shared_Project_Tree_Data_Access :=
Data.Tree.Shared;
Dot_Replacement : File_Name_Type := No_File;
Casing : Casing_Type := All_Lower_Case;
Separate_Suffix : File_Name_Type := No_File;
Lang_Index : Language_Ptr := No_Language_Index;
-- The index of the language data being checked
Prev_Index : Language_Ptr := No_Language_Index;
-- The index of the previous language
procedure Process_Project_Level_Simple_Attributes;
-- Process the simple attributes at the project level
procedure Process_Project_Level_Array_Attributes;
-- Process the associate array attributes at the project level
procedure Process_Packages;
-- Read the packages of the project
----------------------
-- Process_Packages --
----------------------
procedure Process_Packages is
Packages : Package_Id;
Element : Package_Element;
procedure Process_Binder (Arrays : Array_Id);
-- Process the associated array attributes of package Binder
procedure Process_Builder (Attributes : Variable_Id);
-- Process the simple attributes of package Builder
procedure Process_Clean (Attributes : Variable_Id);
-- Process the simple attributes of package Clean
procedure Process_Clean (Arrays : Array_Id);
-- Process the associated array attributes of package Clean
procedure Process_Compiler (Arrays : Array_Id);
-- Process the associated array attributes of package Compiler
procedure Process_Naming (Attributes : Variable_Id);
-- Process the simple attributes of package Naming
procedure Process_Naming (Arrays : Array_Id);
-- Process the associated array attributes of package Naming
procedure Process_Linker (Attributes : Variable_Id);
-- Process the simple attributes of package Linker of a
-- configuration project.
--------------------
-- Process_Binder --
--------------------
procedure Process_Binder (Arrays : Array_Id) is
Current_Array_Id : Array_Id;
Current_Array : Array_Data;
Element_Id : Array_Element_Id;
Element : Array_Element;
begin
-- Process the associative array attribute of package Binder
Current_Array_Id := Arrays;
while Current_Array_Id /= No_Array loop
Current_Array := Shared.Arrays.Table (Current_Array_Id);
Element_Id := Current_Array.Value;
while Element_Id /= No_Array_Element loop
Element := Shared.Array_Elements.Table (Element_Id);
if Element.Index /= All_Other_Names then
-- Get the name of the language
Lang_Index :=
Get_Language_From_Name
(Project, Get_Name_String (Element.Index));
if Lang_Index /= No_Language_Index then
case Current_Array.Name is
when Name_Driver =>
-- Attribute Driver ()
Lang_Index.Config.Binder_Driver :=
File_Name_Type (Element.Value.Value);
when Name_Required_Switches =>
Put
(Into_List =>
Lang_Index.Config.Binder_Required_Switches,
From_List => Element.Value.Values,
In_Tree => Data.Tree);
when Name_Prefix =>
-- Attribute Prefix ()
Lang_Index.Config.Binder_Prefix :=
Element.Value.Value;
when Name_Objects_Path =>
-- Attribute Objects_Path ()
Lang_Index.Config.Objects_Path :=
Element.Value.Value;
when Name_Objects_Path_File =>
-- Attribute Objects_Path ()
Lang_Index.Config.Objects_Path_File :=
Element.Value.Value;
when others =>
null;
end case;
end if;
end if;
Element_Id := Element.Next;
end loop;
Current_Array_Id := Current_Array.Next;
end loop;
end Process_Binder;
---------------------
-- Process_Builder --
---------------------
procedure Process_Builder (Attributes : Variable_Id) is
Attribute_Id : Variable_Id;
Attribute : Variable;
begin
-- Process non associated array attribute from package Builder
Attribute_Id := Attributes;
while Attribute_Id /= No_Variable loop
Attribute := Shared.Variable_Elements.Table (Attribute_Id);
if not Attribute.Value.Default then
if Attribute.Name = Name_Executable_Suffix then
-- Attribute Executable_Suffix: the suffix of the
-- executables.
Project.Config.Executable_Suffix :=
Attribute.Value.Value;
end if;
end if;
Attribute_Id := Attribute.Next;
end loop;
end Process_Builder;
-------------------
-- Process_Clean --
-------------------
procedure Process_Clean (Attributes : Variable_Id) is
Attribute_Id : Variable_Id;
Attribute : Variable;
List : String_List_Id;
begin
-- Process non associated array attributes from package Clean
Attribute_Id := Attributes;
while Attribute_Id /= No_Variable loop
Attribute := Shared.Variable_Elements.Table (Attribute_Id);
if not Attribute.Value.Default then
if Attribute.Name = Name_Artifacts_In_Exec_Dir then
-- Attribute Artifacts_In_Exec_Dir: the list of file
-- names to be cleaned in the exec dir of the main
-- project.
List := Attribute.Value.Values;
if List /= Nil_String then
Put (Into_List =>
Project.Config.Artifacts_In_Exec_Dir,
From_List => List,
In_Tree => Data.Tree);
end if;
elsif Attribute.Name = Name_Artifacts_In_Object_Dir then
-- Attribute Artifacts_In_Exec_Dir: the list of file
-- names to be cleaned in the object dir of every
-- project.
List := Attribute.Value.Values;
if List /= Nil_String then
Put (Into_List =>
Project.Config.Artifacts_In_Object_Dir,
From_List => List,
In_Tree => Data.Tree);
end if;
end if;
end if;
Attribute_Id := Attribute.Next;
end loop;
end Process_Clean;
procedure Process_Clean (Arrays : Array_Id) is
Current_Array_Id : Array_Id;
Current_Array : Array_Data;
Element_Id : Array_Element_Id;
Element : Array_Element;
List : String_List_Id;
begin
-- Process the associated array attributes of package Clean
Current_Array_Id := Arrays;
while Current_Array_Id /= No_Array loop
Current_Array := Shared.Arrays.Table (Current_Array_Id);
Element_Id := Current_Array.Value;
while Element_Id /= No_Array_Element loop
Element := Shared.Array_Elements.Table (Element_Id);
-- Get the name of the language
Lang_Index :=
Get_Language_From_Name
(Project, Get_Name_String (Element.Index));
if Lang_Index /= No_Language_Index then
case Current_Array.Name is
-- Attribute Object_Artifact_Extensions ()
when Name_Object_Artifact_Extensions =>
List := Element.Value.Values;
if List /= Nil_String then
Put (Into_List =>
Lang_Index.Config.Clean_Object_Artifacts,
From_List => List,
In_Tree => Data.Tree);
end if;
-- Attribute Source_Artifact_Extensions ()
when Name_Source_Artifact_Extensions =>
List := Element.Value.Values;
if List /= Nil_String then
Put (Into_List =>
Lang_Index.Config.Clean_Source_Artifacts,
From_List => List,
In_Tree => Data.Tree);
end if;
when others =>
null;
end case;
end if;
Element_Id := Element.Next;
end loop;
Current_Array_Id := Current_Array.Next;
end loop;
end Process_Clean;
----------------------
-- Process_Compiler --
----------------------
procedure Process_Compiler (Arrays : Array_Id) is
Current_Array_Id : Array_Id;
Current_Array : Array_Data;
Element_Id : Array_Element_Id;
Element : Array_Element;
List : String_List_Id;
begin
-- Process the associative array attribute of package Compiler
Current_Array_Id := Arrays;
while Current_Array_Id /= No_Array loop
Current_Array := Shared.Arrays.Table (Current_Array_Id);
Element_Id := Current_Array.Value;
while Element_Id /= No_Array_Element loop
Element := Shared.Array_Elements.Table (Element_Id);
if Element.Index /= All_Other_Names then
-- Get the name of the language
Lang_Index := Get_Language_From_Name
(Project, Get_Name_String (Element.Index));
if Lang_Index /= No_Language_Index then
case Current_Array.Name is
-- Attribute Dependency_Kind ()
when Name_Dependency_Kind =>
Get_Name_String (Element.Value.Value);
begin
Lang_Index.Config.Dependency_Kind :=
Dependency_File_Kind'Value
(Name_Buffer (1 .. Name_Len));
exception
when Constraint_Error =>
Error_Msg
(Data.Flags,
"illegal value for Dependency_Kind",
Element.Value.Location,
Project);
end;
-- Attribute Dependency_Switches ()
when Name_Dependency_Switches =>
if Lang_Index.Config.Dependency_Kind = None then
Lang_Index.Config.Dependency_Kind := Makefile;
end if;
List := Element.Value.Values;
if List /= Nil_String then
Put (Into_List =>
Lang_Index.Config.Dependency_Option,
From_List => List,
In_Tree => Data.Tree);
end if;
-- Attribute Dependency_Driver ()
when Name_Dependency_Driver =>
if Lang_Index.Config.Dependency_Kind = None then
Lang_Index.Config.Dependency_Kind := Makefile;
end if;
List := Element.Value.Values;
if List /= Nil_String then
Put (Into_List =>
Lang_Index.Config.Compute_Dependency,
From_List => List,
In_Tree => Data.Tree);
end if;
-- Attribute Language_Kind ()
when Name_Language_Kind =>
Get_Name_String (Element.Value.Value);
begin
Lang_Index.Config.Kind :=
Language_Kind'Value
(Name_Buffer (1 .. Name_Len));
exception
when Constraint_Error =>
Error_Msg
(Data.Flags,
"illegal value for Language_Kind",
Element.Value.Location,
Project);
end;
-- Attribute Include_Switches ()
when Name_Include_Switches =>
List := Element.Value.Values;
if List = Nil_String then
Error_Msg
(Data.Flags, "include option cannot be null",
Element.Value.Location, Project);
end if;
Put (Into_List => Lang_Index.Config.Include_Option,
From_List => List,
In_Tree => Data.Tree);
-- Attribute Include_Path ()
when Name_Include_Path =>
Lang_Index.Config.Include_Path :=
Element.Value.Value;
-- Attribute Include_Path_File ()
when Name_Include_Path_File =>
Lang_Index.Config.Include_Path_File :=
Element.Value.Value;
-- Attribute Driver ()
when Name_Driver =>
Lang_Index.Config.Compiler_Driver :=
File_Name_Type (Element.Value.Value);
when Name_Required_Switches
| Name_Leading_Required_Switches
=>
Put (Into_List =>
Lang_Index.Config.
Compiler_Leading_Required_Switches,
From_List => Element.Value.Values,
In_Tree => Data.Tree);
when Name_Trailing_Required_Switches =>
Put (Into_List =>
Lang_Index.Config.
Compiler_Trailing_Required_Switches,
From_List => Element.Value.Values,
In_Tree => Data.Tree);
when Name_Multi_Unit_Switches =>
Put (Into_List =>
Lang_Index.Config.Multi_Unit_Switches,
From_List => Element.Value.Values,
In_Tree => Data.Tree);
when Name_Multi_Unit_Object_Separator =>
Get_Name_String (Element.Value.Value);
if Name_Len /= 1 then
Error_Msg
(Data.Flags,
"multi-unit object separator must have " &
"a single character",
Element.Value.Location, Project);
elsif Name_Buffer (1) = ' ' then
Error_Msg
(Data.Flags,
"multi-unit object separator cannot be " &
"a space",
Element.Value.Location, Project);
else
Lang_Index.Config.Multi_Unit_Object_Separator :=
Name_Buffer (1);
end if;
when Name_Path_Syntax =>
begin
Lang_Index.Config.Path_Syntax :=
Path_Syntax_Kind'Value
(Get_Name_String (Element.Value.Value));
exception
when Constraint_Error =>
Error_Msg
(Data.Flags,
"invalid value for Path_Syntax",
Element.Value.Location, Project);
end;
when Name_Source_File_Switches =>
Put (Into_List =>
Lang_Index.Config.Source_File_Switches,
From_List => Element.Value.Values,
In_Tree => Data.Tree);
when Name_Object_File_Suffix =>
if Get_Name_String (Element.Value.Value) = "" then
Error_Msg
(Data.Flags,
"object file suffix cannot be empty",
Element.Value.Location, Project);
else
Lang_Index.Config.Object_File_Suffix :=
Element.Value.Value;
end if;
when Name_Object_File_Switches =>
Put (Into_List =>
Lang_Index.Config.Object_File_Switches,
From_List => Element.Value.Values,
In_Tree => Data.Tree);
when Name_Object_Path_Switches =>
Put (Into_List =>
Lang_Index.Config.Object_Path_Switches,
From_List => Element.Value.Values,
In_Tree => Data.Tree);
-- Attribute Compiler_Pic_Option ()
when Name_Pic_Option =>
List := Element.Value.Values;
if List = Nil_String then
Error_Msg
(Data.Flags,
"compiler PIC option cannot be null",
Element.Value.Location, Project);
end if;
Put (Into_List =>
Lang_Index.Config.Compilation_PIC_Option,
From_List => List,
In_Tree => Data.Tree);
-- Attribute Mapping_File_Switches ()
when Name_Mapping_File_Switches =>
List := Element.Value.Values;
if List = Nil_String then
Error_Msg
(Data.Flags,
"mapping file switches cannot be null",
Element.Value.Location, Project);
end if;
Put (Into_List =>
Lang_Index.Config.Mapping_File_Switches,
From_List => List,
In_Tree => Data.Tree);
-- Attribute Mapping_Spec_Suffix ()
when Name_Mapping_Spec_Suffix =>
Lang_Index.Config.Mapping_Spec_Suffix :=
File_Name_Type (Element.Value.Value);
-- Attribute Mapping_Body_Suffix (