+2011-08-03 Robert Dewar <dewar@adacore.com>
+
+ * sem_aggr.adb, sem_ch3.adb, lib.ads, gnatcmd.adb, prj-proc.adb,
+ make.adb, lib-writ.adb, prj-part.adb, prj-part.ads, prj-ext.adb,
+ fname-uf.adb, prj-ext.ads, prj.adb, prj.ads, sem_attr.adb, alfa.adb,
+ prj-makr.adb, errout.adb, makeutl.adb, makeutl.ads, restrict.ads,
+ sem_ch6.adb, g-pehage.adb, clean.adb, put_alfa.adb, lib-xref-alfa.adb,
+ prj-nmsc.adb, prj-nmsc.ads, sem_ch8.adb, prj-pars.ads, exp_aggr.adb,
+ prj-attr.ads, sem_ch13.adb, get_alfa.adb, prj-env.adb, prj-env.ads,
+ alfa_test.adb, prj-tree.adb, prj-tree.ads, einfo.ads: Minor reformatting
+
+2011-08-03 Robert Dewar <dewar@adacore.com>
+
+ * repinfo.adb (List_Mechanism): Add handling of
+ Convention_Ada_Pass_By_XXX.
+ * sem_mech.adb (Set_Mechanism): Ditto.
+ * sem_prag.adb (Process_Convention): Add entries for
+ Convention_Ada_Pass_By_XXX.
+ * snames.adb-tmpl, snames.ads-tmpl: Ditto.
+
2011-08-03 Pascal Obry <obry@adacore.com>
* makeutl.adb: Minor reformatting.
procedure Debug_Put_ALFA is new Put_ALFA;
- -- Start of processing for palfa
+ -- Start of processing for palfa
begin
Debug_Put_ALFA;
procedure Put_Char (F : File_Type; C : Character) is
Item : Stream_Element_Array (1 .. 1);
+
begin
if C /= CR and then C /= EOF then
if C = LF then
function Nextc return Character is
C : Character;
+
begin
C := Get_Char (Infile);
end if;
if not OK
- or else not Prj.Ext.Check
- (Root_Environment.External,
- Ext_Asgn (Start .. Stop))
+ or else not
+ Prj.Ext.Check (Root_Environment.External,
+ Ext_Asgn (Start .. Stop))
then
Fail
("illegal external assignment '"
-- are suppressed.
-- Machine_Radix_10 (Flag84)
--- Present 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.
+-- Present 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)
-- Present in access types and subtypes. Empty unless Has_Task is
-- entity but not used in this context.
-- Modulus (Uint17) [base type only]
--- Present 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.
+-- Present 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)
--- Present in entities for types and subtypes. Set if objects of
--- the type must always be allocated on a byte boundary (more
--- accurately a storage unit boundary). The front end checks that
--- component clauses respect this rule, and the back end ensures
--- that record packing does not violate this rule. Currently the
--- flag is set only for packed arrays longer than 64 bits where
--- the component size is not a power of 2.
+-- Present in entities for types and subtypes. Set if objects of the type
+-- must always be allocated on a byte boundary (more accurately a storage
+-- unit boundary). The front end checks that component clauses respect
+-- this rule, and the back end ensures that record packing does not
+-- violate this rule. Currently the flag is set only for packed arrays
+-- longer than 64 bits where the component size is not a power of 2.
-- Must_Have_Preelab_Init (Flag208)
-- Present in entities for types and subtypes. Set in the full type of a
null;
-- If the main unit has not been read yet. the warning must be on
- -- a configuration file: gnat.adc or user-defined.
+ -- 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;
begin
Btype := Base_Type (Typ);
while Is_Derived_Type (Btype)
- and then Present (Stored_Constraint (Btype))
+ and then Present (Stored_Constraint (Btype))
loop
Parent_Type := Etype (Btype);
Key => Unit_Name_Type,
Hash => SFN_Hash,
Equal => "=");
- -- Hash table allowing rapid access to SFN_Table, the element value
- -- is an index into this table.
+ -- Hash table allowing rapid access to SFN_Table, the element value is an
+ -- index into this table.
type SFN_Pattern_Entry is record
Pat : String_Ptr; -- File name pattern (with asterisk in it)
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "SFN_Patterns");
- -- Table recording all calls to Set_File_Name_Pattern. Note that the
- -- first two entries are set to represent the standard GNAT rules
- -- for file naming.
+ -- Table recording calls to Set_File_Name_Pattern. Note that the first two
+ -- entries are set to represent the standard GNAT rules for file naming.
-----------------------
-- File_Name_Of_Body --
(Fname : File_Name_Type) return Expected_Unit_Type
is
begin
- -- In syntax checking only mode or in multiple unit per file mode,
- -- there can be more than one unit in a file, so the file name is
- -- not a useful guide to the nature of the unit.
+ -- In syntax checking only mode or in multiple unit per file mode, there
+ -- can be more than one unit in a file, so the file name is not a useful
+ -- guide to the nature of the unit.
if Operating_Mode = Check_Syntax
or else Multiple_Unit_Index /= 0
return Unknown;
end if;
- -- Search the file mapping table, if we find an entry for this
- -- file we know whether it is a spec or a body.
+ -- Search the file mapping table, if we find an entry for this file we
+ -- know whether it is a spec or a body.
for J in SFN_Table.First .. SFN_Table.Last loop
if Fname = SFN_Table.Table (J).F then
end if;
end loop;
- -- If no entry in file naming table, assume .ads/.adb for spec/body
- -- and return unknown if we have neither of these two cases.
+ -- If no entry in file naming table, assume .ads/.adb for spec/body and
+ -- return unknown if we have neither of these two cases.
Get_Name_String (Fname);
-- Set to 's' or 'b' for spec or body or to 'u' for a subunit
Unit_Char_Search : Character;
- -- Same as Unit_Char, except that in the case of 'u' for a subunit,
- -- we set Unit_Char_Search to 'b' if we do not find a subunit match.
+ -- Same as Unit_Char, except that in the case of 'u' for a subunit, we
+ -- set Unit_Char_Search to 'b' if we do not find a subunit match.
N : Int;
-- Path name and File name for mapping
begin
- -- Null or error name means that some previous error occurred
- -- This is an unrecoverable error, so signal it.
+ -- Null or error name means that some previous error occurred. This is
+ -- an unrecoverable error, so signal it.
if Uname in Error_Unit_Name_Or_No_Unit_Name then
raise Unrecoverable_Error;
Fname := Mapped_File_Name (Uname);
- -- If the unit name is already mapped, return the corresponding
- -- file name from the map.
+ -- If the unit name is already mapped, return the corresponding file
+ -- name from the map.
if Fname /= No_File then
return Fname;
-- _and_.ads
- -- which is bit peculiar, but we keep it that way. This means that
- -- we avoid bombs due to writing a bad file name, and w get expected
- -- error processing downstream, e.g. a compilation following gnatchop.
+ -- which is bit peculiar, but we keep it that way. This means that we
+ -- avoid bombs due to writing a bad file name, and w get expected error
+ -- processing downstream, e.g. a compilation following gnatchop.
if Name_Buffer (1) = '"' then
Get_Name_String (Uname);
-- Start of search through pattern table
begin
- -- Search pattern table to find a matching entry. In the general
- -- case we do two complete searches. The first time through we
- -- stop only if a matching file is found, the second time through
- -- we accept the first match regardless. Note that there will
- -- always be a match the second time around, because of the
- -- default entries at the end of the table.
+ -- Search pattern table to find a matching entry. In the general case
+ -- we do two complete searches. The first time through we stop only
+ -- if a matching file is found, the second time through we accept the
+ -- first match regardless. Note that there will always be a match the
+ -- second time around, because of the default entries at the end of
+ -- the table.
for No_File_Check in False .. True loop
Unit_Char_Search := Unit_Char;
J := J + Dotl;
- -- Skip past wide char sequences to avoid messing
- -- with dot characters that are part of a sequence.
+ -- Skip past wide char sequences to avoid messing with
+ -- dot characters that are part of a sequence.
elsif Name_Buffer (J) = ASCII.ESC
or else (Upper_Half_Encoding
Name_Len := Name_Len + Ext'Length;
end;
- -- Case of no extension present, straight krunch on
- -- the entire file name.
+ -- Case of no extension present, straight krunch on the
+ -- entire file name.
else
Krunch
Fnam := Name_Find;
-- If we are in the second search of the table, we accept
- -- the file name without checking, because we know that
- -- the file does not exist, except when May_Fail is True,
- -- in which case we return No_File.
+ -- the file name without checking, because we know that the
+ -- file does not exist, except when May_Fail is True, in
+ -- which case we return No_File.
if No_File_Check then
if May_Fail then
else
Pname := Find_File (Fnam, Source);
- -- If it does exist, we add it to the mappings and
- -- return the file name.
+ -- If it does exist, we add it to the mappings and return
+ -- the file name.
if Pname /= No_File then
- -- Add to mapping, so that we don't do another
- -- path search in Find_File for this file name
- -- and, if we use a mapping file, we are ready
- -- to update it at the end of this compilation
- -- for the benefit of other compilation processes.
+ -- Add to mapping, so that we don't do another path
+ -- search in Find_File for this file name and, if we
+ -- use a mapping file, we are ready to update it at
+ -- the end of this compilation for the benefit of
+ -- other compilation processes.
Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname);
return Fnam;
- -- If there are only two entries, they are those of
- -- the default GNAT naming scheme. The file does
- -- not exist, but there is no point doing the
- -- second search, because we will end up with the
- -- same file name. Just return the file name, or No_File
- -- if May_Fail is True.
+ -- If there are only two entries, they are those of the
+ -- default GNAT naming scheme. The file does not exist,
+ -- but there is no point doing the second search, because
+ -- we will end up with the same file name. Just return
+ -- the file name, or No_File if May_Fail is True.
elsif SFN_Patterns.Last = 2 then
if May_Fail then
return Fnam;
end if;
- -- The file does not exist, but there may be other
- -- naming scheme. Keep on searching.
+ -- The file does not exist, but there may be other naming
+ -- scheme. Keep on searching.
else
Fnam := No_File;
Pent := Pent + 1;
end loop;
- -- If search failed, and was for a subunit, repeat the search
- -- with Unit_Char_Search reset to 'b', since in the normal case
- -- we simply treat subunits as bodies.
+ -- If search failed, and was for a subunit, repeat the search with
+ -- Unit_Char_Search reset to 'b', since in the normal case we
+ -- simply treat subunits as bodies.
if Fnam = No_File and then Unit_Char_Search = 'u' then
Unit_Char_Search := 'b';
end loop;
- -- Something is wrong if search fails completely, since the
- -- default entries should catch all possibilities at this stage.
+ -- Something is wrong if search fails completely, since the default
+ -- entries should catch all possibilities at this stage.
raise Program_Error;
end;
SFN_Table.Init;
SFN_Patterns.Init;
- -- Add default entries to SFN_Patterns.Table to represent the
- -- standard default GNAT rules for file name translation.
+ -- Add default entries to SFN_Patterns.Table to represent the standard
+ -- default GNAT rules for file name translation.
SFN_Patterns.Append (New_Val =>
(Pat => new String'("*.ads"),
begin
SFN_Patterns.Increment_Last;
- -- Move up the last two entries (the default ones) and then
- -- put the new entry into the table just before them (we
- -- always have the default entries be the last ones).
+ -- Move up the last two entries (the default ones) and then put the new
+ -- entry into the table just before them (we always have the default
+ -- entries be the last ones).
SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L);
SFN_Patterns.Table (L) := SFN_Patterns.Table (L - 1);
New_Line (Output);
end if;
- -- Deallocate all the WT components (both initial and reduced
- -- ones) to avoid memory leaks.
+ -- Deallocate all the WT components (both initial and reduced ones) to
+ -- avoid memory leaks.
for W in 0 .. WT.Last loop
+
-- Note: WT.Table (NK) is a temporary variable, do not free it since
-- this would cause a double free.
with Ada.IO_Exceptions; use Ada.IO_Exceptions;
procedure Get_ALFA is
- C : Character;
+ C : Character;
use ASCII;
-- For CR/LF
-----------------------
function At_EOL return Boolean;
- -- Skips any spaces, then checks if we are the end of a line. If so,
- -- returns True (but does not skip over the EOL sequence). If not,
- -- then returns False.
+ -- Skips any spaces, then checks if at the end of a line. If so, returns
+ -- True (but does not skip the EOL sequence). If not, then returns False.
procedure Check (C : Character);
-- Checks that file is positioned at given character, and if so skips past
procedure Get_Name;
-- On entry the file is positioned to a name. On return, the file is
- -- positioned past the last character, and the name scanned is returned in
- -- Name_Str (1 .. Name_Len).
+ -- positioned past the last character, and the name scanned is returned
+ -- in Name_Str (1 .. Name_Len).
procedure Skip_EOL;
-- Called with the current character about to be read being LF or CR. Skips
XR_Entity_Line : Nat;
XR_Entity_Col : Nat;
- XR_File : Nat;
+ XR_File : Nat;
-- Keeps track of the current file (changed by nn|)
- XR_Scope : Nat;
+ XR_Scope : Nat;
-- Keeps track of the current scope (changed by nn:)
begin
Rtype := Getc;
Col := Get_Nat;
- pragma Assert (Rtype = 'r'
- or else Rtype = 'm'
- or else Rtype = 's');
+ pragma Assert
+ (Rtype = 'r' or else
+ Rtype = 'm' or else
+ Rtype = 's');
ALFA_Xref_Table.Append (
(Entity_Name => XR_Entity,
raise Data_Error;
end case;
- -- For cross reference lines, the end-of-line character has been skipped
- -- already.
+ -- For cross reference lines, the EOL character has been skipped already
if C /= ' ' then
Skip_EOL;
end if;
end loop;
- -- Here with all Xrefs stored, complete last entries in File and Scope
- -- tables.
+ -- Here with all Xrefs stored, complete last entries in File/Scope tables
if ALFA_File_Table.Last /= 0 then
ALFA_File_Table.Table (ALFA_File_Table.Last).To_Scope :=
Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags);
Prj.Env.Initialize_Default_Project_Path
- (Root_Environment.Project_Path, Target_Name => "");
+ (Root_Environment.Project_Path, Target_Name => "");
Project_Node_Tree := new Project_Node_Tree_Data;
Prj.Tree.Initialize (Project_Node_Tree);
-- Output ALFA information if needed
if Opt.Xref_Active and then ALFA_Mode then
- Collect_ALFA (Sdep_Table => Sdep_Table,
- Num_Sdep => Num_Sdep);
+ Collect_ALFA (Sdep_Table => Sdep_Table, Num_Sdep => Num_Sdep);
Output_ALFA;
end if;
-- Local Constants --
---------------------
- -- True for each entity kind used in ALFA
+ -- Table of ALFA_Entities, True for each entity kind used in ALFA
+
ALFA_Entities : constant array (Entity_Kind) of Boolean :=
(E_Void => False,
E_Variable => True,
From : Scope_Index;
S : constant Source_File_Index := Source_Index (U);
+
begin
-- Source file could be inexistant as a result of an error, if option
-- gnatQ is used.
T2 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op2)));
begin
- -- First test: if entity is in different unit, sort by unit. Notice
+ -- First test: if entity is in different unit, sort by unit. Note:
-- that we use Ent_Scope_File rather than Eun, as Eun may refer to
- -- the file where the generic scope is defined, and it may be
- -- different from the file where the enclosing scope is defined. It
- -- is the latter which matters for a correct order here.
+ -- the file where the generic scope is defined, which may differ from
+ -- the file where the enclosing scope is defined. It is the latter
+ -- which matters for a correct order here.
if T1.Ent_Scope_File /= T2.Ent_Scope_File then
return Dependency_Num (T1.Ent_Scope_File) <
elsif T1.Loc /= T2.Loc then
return T1.Loc < T2.Loc;
- -- Finally, for two locations at the same address, we prefer the one
- -- that does NOT have the type 'r' so that a modification or
- -- extension takes preference, when there are more than one reference
- -- at the same location. As a result, in the case of entities that
- -- are in-out actuals, the read reference follows the modify
- -- reference.
+ -- Finally, for two locations at the same address prefer the one that
+ -- does NOT have the type 'r', so that a modification or extension
+ -- takes preference, when there are more than one reference at the
+ -- same location. As a result, in the case of entities that are
+ -- in-out actuals, the read reference follows the modify reference.
else
return T2.Typ = 'r';
Rnums (J) := J;
end loop;
- -- Eliminate entries not appropriate for ALFA. Should be prior to
- -- sorting cross-references, as it discards useless references which do
- -- not have a proper format for the comparison function (like no
- -- location).
+ -- Eliminate entries not appropriate for ALFA. Done prior to sorting
+ -- cross-references, as it discards useless references which do not have
+ -- a proper format for the comparison function (like no location).
Eliminate_Before_Sort : declare
NR : Nat;
Sorting.Sort (Integer (Nrefs));
Eliminate_After_Sort : declare
- NR : Nat;
+ NR : Nat;
Crloc : Source_Ptr;
-- Current reference location
end if;
-- Eliminate the reference if it is at the same location as the
- -- previous one, unless it is a read-reference that indicates that
- -- the entity is an in-out actual in a call.
+ -- previous one, unless it is a read-reference indicating that the
+ -- entity is an in-out actual in a call.
NR := Nrefs;
Nrefs := 0;
-----------------------
function Cur_Scope return Node_Id;
- -- Return the scope entity which corresponds to index
- -- Cur_Scope_Idx in table ALFA_Scope_Table.
+ -- Return scope entity which corresponds to index Cur_Scope_Idx in
+ -- table ALFA_Scope_Table.
function Is_Future_Scope_Entity (E : Entity_Id) return Boolean;
-- Check whether entity E is in ALFA_Scope_Table at index
XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
begin
- -- If this assertion fails, this means that the scope which we
- -- are looking for is not in ALFA scope table, which reveals
- -- either a problem in the construction of the scope table, or an
- -- erroneous scope for the current cross-reference.
+ -- If this assertion fails, the scope which we are looking for is
+ -- not in ALFA scope table, which reveals either a problem in the
+ -- construction of the scope table, or an erroneous scope for the
+ -- current cross-reference.
pragma Assert (Is_Future_Scope_Entity (XE.Ent_Scope));
-- called after Sprint has been called with -gnatD set.
function Exact_Source_Name (Loc : Source_Ptr) return String;
- -- Return the name of an entity at location Loc exactly as written in the
- -- source.
+ -- Return name of entity at location Loc exactly as written in the source.
+ -- this includes copying the wide character encodings exactly as they were
+ -- used in the source, so the caller must be aware of the possibility of
+ -- such encodings.
function Compilation_Switches_Last return Nat;
-- Return the count of stored compilation switches
Prj.Tree.Initialize (Env, Gnatmake_Flags);
Prj.Env.Initialize_Default_Project_Path
- (Env.Project_Path, Target_Name => "");
+ (Env.Project_Path, Target_Name => "");
Project_Node_Tree := new Project_Node_Tree_Data;
Prj.Tree.Initialize (Project_Node_Tree);
-- --
------------------------------------------------------------------------------
-with Ada.Command_Line; use Ada.Command_Line;
-
-with GNAT.Case_Util; use GNAT.Case_Util;
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.HTable;
-
with ALI; use ALI;
with Debug;
with Fname;
with Table;
with Tempdir;
+with Ada.Command_Line; use Ada.Command_Line;
+
+with GNAT.Case_Util; use GNAT.Case_Util;
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.HTable;
+
package body Makeutl is
type Mark_Key is record
Value : out Variable_Value;
Is_Default : out Boolean);
-- Compute the switches (Compilation switches for instance) for the given
- -- file. This checks various attributes to see whether there are file
- -- specific switches, or else defaults on the switches for the
- -- corresponding language.
- -- Is_Default is set to False if there were file-specific switches
- -- Source_File can be set to No_File to force retrieval of the default
- -- switches.
+ -- file. This checks various attributes to see if there are file specific
+ -- switches, or else defaults on the switches for the corresponding
+ -- language. Is_Default is set to False if there were file-specific
+ -- switches Source_File can be set to No_File to force retrieval of
+ -- the default switches.
function Linker_Options_Switches
(Project : Project_Id;
-- 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 => <package name>);
+ --
Prj.Attr.Package_Node_Id_Of (Name => <package name>);
-- Att : constant Attribute_Node_Id :=
- -- Prj.Attr.Attribute_Node_Id_Of
- --
(Name => <attribute name>,
- -- Starting_At => First_Attribute_Of (Pkg));
+ -- Prj.Attr.Attribute_Node_Id_Of
+ --
(Name => <attribute name>,
+ -- Starting_At => First_Attribute_Of (Pkg));
-- Kind : constant Attribute_Kind := Attribute_Kind_Of (Att);
--
- -- However, you should 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 ..."), it is simpler to
- -- use
+ -- 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
begin
return Self.Path /= null
and then (Self.Path'Length = 0
- or else Self.Path (Self.Path'First) /= '#');
+ or else Self.Path (Self.Path'First) /= '#');
end Is_Initialized;
----------------------
-------------------------------------
procedure Initialize_Default_Project_Path
- (Self : in out Project_Search_Path; Target_Name : String)
+ (Self : in out Project_Search_Path;
+ Target_Name : String)
is
Add_Default_Dir : Boolean := True;
First : Positive;
-- Get_Path --
--------------
- procedure Get_Path
- (Self : Project_Search_Path;
- Path : out String_Access) is
+ procedure Get_Path (Self : Project_Search_Path; Path : out String_Access) is
begin
pragma Assert (Is_Initialized (Self));
Path := Self.Path;
-- Set_Path --
--------------
- procedure Set_Path
- (Self : in out Project_Search_Path; Path : String) is
+ procedure Set_Path (Self : in out Project_Search_Path; Path : String) is
begin
Free (Self.Path);
Self.Path := new String'(Path);
-- efficiency).
procedure Initialize_Default_Project_Path
- (Self : in out Project_Search_Path; Target_Name : String);
- -- Initialize Self.
- -- It will then contain the default project path on the given target
- -- (including directories specified by the environment variables
- -- ADA_PROJECT_PATH and GPR_PROJECT_PATH).
- -- This does nothing if Self has already been initialized.
+ (Self : in out Project_Search_Path;
+ Target_Name : String);
+ -- Initialize Self. It will then contain the default project path on the
+ -- given target (including directories specified by the environment
+ -- variables ADA_PROJECT_PATH and GPR_PROJECT_PATH). This does nothing if
+ -- Self has already been initialized.
procedure Initialize_Empty (Self : in out Project_Search_Path);
- -- Initialize self with an empty list of directories.
- -- If Self had already been set, it is reset.
+ -- Initialize self with an empty list of directories. If Self had already
+ -- been set, it is reset.
function Is_Initialized (Self : Project_Search_Path) return Boolean;
-- Whether Self has been initialized
-- Calls to this subprogram must be performed before the first call to
-- Find_Project below, or PATH will be added at the end of the search path.
- procedure Get_Path
- (Self : Project_Search_Path;
- Path : out String_Access);
+ procedure Get_Path (Self : Project_Search_Path; Path : out String_Access);
-- Return the current value of the project path, either the value set
-- during elaboration of the package or, if procedure Set_Project_Path has
-- been called, the value set by the last call to Set_Project_Path. The
-- returned value must not be modified.
-- Self must have been initialized first.
- procedure Set_Path
- (Self : in out Project_Search_Path; Path : String);
+ procedure Set_Path (Self : in out Project_Search_Path; Path : String);
-- Override the value of the project path. This also removes the implicit
- -- default search directories
+ -- default search directories.
procedure Find_Project
(Self : in out Project_Search_Path;
-- Search for a project with the given name either in Directory (which
-- often will be the directory contain the project we are currently parsing
-- and which we found a reference to another project), or in the project
- -- path Self.
- --
- -- Self must have been initialized first.
+ -- path Self. Self must have been initialized first.
--
-- Project_File_Name can optionally contain directories, and the extension
-- (.gpr) for the file name is optional.
-- --
------------------------------------------------------------------------------
-with Ada.Unchecked_Deallocation;
with Osint; use Osint;
+with Ada.Unchecked_Deallocation;
+
package body Prj.Ext is
----------------
Value : String)
is
N : Name_To_Name_Ptr;
+
begin
N := new Name_To_Name;
Debug_Output ("Value_Of (" & Get_Name_String (External_Name)
& ") is default", With_Default);
end if;
+
Free (Env_Value);
return With_Default;
end if;
private
- -- Use a Static_HTable, not a Simple_HTable.
+ -- 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.
Prj.Tree.Initialize (Root_Environment, Flags);
Prj.Env.Initialize_Default_Project_Path
- (Root_Environment.Project_Path, Target_Name => "");
+ (Root_Environment.Project_Path, Target_Name => "");
Prj.Tree.Initialize (Tree);
-- Free the memory occupied by Data
procedure Check
- (Project : Project_Id;
- Data : in out Tree_Processing_Data);
+ (Project : Project_Id;
+ Data : in out Tree_Processing_Data);
-- Process the naming scheme for a single project
procedure Initialize
-- 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.
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
+ -- 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
+ -- This alters Name_Buffer.
function Suffix_Matches
(Filename : String;
---------------------------------
procedure Process_Aggregated_Projects
- (Tree : Project_Tree_Ref;
- Project : Project_Id;
- Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Flags : Processing_Flags)
+ (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,
- File_To_Source => Files_Htable.Nil,
- Flags => Flags);
+ (Tree => Tree,
+ Node_Tree => Node_Tree,
+ File_To_Source => Files_Htable.Nil,
+ Flags => Flags);
Project_Files : constant Prj.Variable_Value :=
Prj.Util.Value_Of
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
+ -- parameter. Calls Found_Project_File for each of them.
------------------------
-- Found_Project_File --
-- 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
(Project : Project_Id;
Data : in out Tree_Processing_Data)
is
- Prj_Data : Project_Processing_Data;
+ Prj_Data : Project_Processing_Data;
begin
Debug_Increase_Indent ("Check", Project.Name);
if Current_Verbosity = High then
Debug_Indent;
+
if Source.Path /= No_Path_Information then
Write_Line ("Setting full path for "
& Get_Name_String (Source.File)
-- 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);
+ (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
Env : in out Prj.Tree.Environment);
-- Parse and process a project files and all its imported project files, in
-- the project tree In_Tree.
+ --
-- All the project files are parsed (through Prj.Tree) to create a tree in
-- memory. That tree is then processed (through Prj.Proc) to create a
-- expanded representation of the tree based on the current external
-----------
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 := All_Packages;
- Store_Comments : Boolean := False;
- Current_Directory : String := "";
- Is_Config_File : Boolean;
- Env : in out Prj.Tree.Environment;
- Target_Name : String := "")
+ (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 := All_Packages;
+ Store_Comments : Boolean := False;
+ Current_Directory : String := "";
+ Is_Config_File : Boolean;
+ Env : in out Prj.Tree.Environment;
+ Target_Name : String := "")
is
Dummy : Boolean;
pragma Warnings (Off, Dummy);
-- 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 := All_Packages;
- Store_Comments : Boolean := False;
- Current_Directory : String := "";
- Is_Config_File : Boolean;
- Env : in out Prj.Tree.Environment;
- Target_Name : String := "");
+ (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 := All_Packages;
+ Store_Comments : Boolean := False;
+ Current_Directory : String := "";
+ Is_Config_File : Boolean;
+ Env : in out Prj.Tree.Environment;
+ Target_Name : String := "");
-- 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,
-- Find the package of Project whose name is With_Name
procedure Process_Declarative_Items
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- From_Project_Node : Project_Node_Id;
- Node_Tree : Project_Node_Tree_Ref;
- Env : Prj.Tree.Environment;
- Pkg : Package_Id;
- Item : Project_Node_Id);
+ (Project : Project_Id;
+ In_Tree : Project_Tree_Ref;
+ From_Project_Node : Project_Node_Id;
+ Node_Tree : Project_Node_Tree_Ref;
+ Env : Prj.Tree.Environment;
+ Pkg : Package_Id;
+ Item : Project_Node_Id);
-- Process declarative items starting with From_Project_Node, and put them
-- in declarations Decl. This is a recursive procedure; it calls itself for
-- a package declaration or a case construction.
function Get_Attribute_Index
(Tree : Project_Node_Tree_Ref;
Attr : Project_Node_Id;
- Index : Name_Id) return Name_Id is
+ Index : Name_Id) return Name_Id
+ is
begin
if Index = All_Other_Names
or else not Case_Insensitive (Attr, Tree)
if Present (String_Node) then
-- If String_Node is nil, it is an empty list, there is
- -- nothing to do
+ -- nothing to do.
Value := Expression
(Project => Project,
loop
-- Add the other element of the literal string list
- -- one after the other
+ -- one after the other.
String_Node :=
Next_Expression_In_List
String_Element_Table.Increment_Last
(In_Tree.String_Elements);
- In_Tree.String_Elements.Table
- (Last).Next := String_Element_Table.Last
- (In_Tree.String_Elements);
- Last := String_Element_Table.Last
- (In_Tree.String_Elements);
+ In_Tree.String_Elements.Table (Last).Next :=
+ String_Element_Table.Last (In_Tree.String_Elements);
+ Last :=
+ String_Element_Table.Last (In_Tree.String_Elements);
In_Tree.String_Elements.Table (Last) :=
(Value => Value.Value,
Display_Value => No_Name,
(The_Package).Name /= The_Name
loop
The_Package :=
- In_Tree.Packages.Table
- (The_Package).Next;
+ In_Tree.Packages.Table (The_Package).Next;
end loop;
pragma Assert
- (The_Package /= No_Package,
- "package not found.");
+ (The_Package /= No_Package, "package not found.");
elsif Kind_Of (The_Current_Term, From_Project_Node_Tree) =
- N_Attribute_Reference
+ N_Attribute_Reference
then
The_Package := No_Package;
end if;
Name_Of (The_Current_Term, From_Project_Node_Tree);
if Kind_Of (The_Current_Term, From_Project_Node_Tree) =
- N_Attribute_Reference
+ N_Attribute_Reference
then
Index :=
Associative_Array_Index_Of
-- First, if there is a package, look into the package
if Kind_Of (The_Current_Term, From_Project_Node_Tree) =
- N_Variable_Reference
+ N_Variable_Reference
then
The_Variable_Id :=
In_Tree.Packages.Table
begin
if The_Package /= No_Package then
The_Array :=
- In_Tree.Packages.Table
- (The_Package).Decl.Arrays;
+ In_Tree.Packages.Table (The_Package).Decl.Arrays;
else
The_Array := The_Project.Decl.Arrays;
end if;
and then In_Tree.Arrays.Table
(The_Array).Name /= The_Name
loop
- The_Array := In_Tree.Arrays.Table
- (The_Array).Next;
+ The_Array := In_Tree.Arrays.Table (The_Array).Next;
end loop;
if The_Array /= No_Array then
- The_Element := In_Tree.Arrays.Table
- (The_Array).Value;
+ The_Element :=
+ In_Tree.Arrays.Table (The_Array).Value;
Array_Index :=
Get_Attribute_Index
(From_Project_Node_Tree,
Index);
while The_Element /= No_Array_Element
- and then
- In_Tree.Array_Elements.Table
- (The_Element).Index /= Array_Index
+ and then In_Tree.Array_Elements.Table
+ (The_Element).Index /= Array_Index
loop
The_Element :=
In_Tree.Array_Elements.Table
if The_Element /= No_Array_Element then
The_Variable :=
- In_Tree.Array_Elements.Table
- (The_Element).Value;
+ In_Tree.Array_Elements.Table (The_Element).Value;
else
if Expression_Kind_Of
end if;
Ext_List := Expression_Kind_Of
- (The_Current_Term,
- From_Project_Node_Tree) = List;
+ (The_Current_Term,
+ From_Project_Node_Tree) = List;
if Ext_List then
Value := Prj.Ext.Value_Of (Env.External, Name, No_Name);
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Env : in out Prj.Tree.Environment;
- Reset_Tree : Boolean := True)
+ Reset_Tree : Boolean := True)
is
begin
Process_Project_Tree_Phase_1
procedure Process_Package_Declaration
(Current_Item : Project_Node_Id);
- procedure Process_Attribute_Declaration (Current : Project_Node_Id);
+ procedure Process_Attribute_Declaration
+ (Current : Project_Node_Id);
procedure Process_Case_Construction
(Current_Item : Project_Node_Id);
procedure Process_Associative_Array
-- Loop through all the valid strings for the
-- string type and compare to the string value.
- Current_String := First_Literal_String
- (String_Type_Of (Declaration, Node_Tree), Node_Tree);
+ Current_String :=
+ First_Literal_String
+ (String_Type_Of (Declaration, Node_Tree), Node_Tree);
while Present (Current_String)
and then String_Value_Of (Current_String, Node_Tree) /=
- Value.Value
+ Value.Value
loop
Current_String :=
Next_Literal_String (Current_String, Node_Tree);
---------------------------------
procedure Process_Package_Declaration
- (Current_Item : Project_Node_Id) is
+ (Current_Item : Project_Node_Id)
+ is
begin
-- Do not process a package declaration that should be ignored
if Expression_Kind_Of (Current_Item, Node_Tree) /= Ignored then
+
-- Create the new package
Package_Table.Increment_Last (In_Tree.Packages);
declare
New_Pkg : constant Package_Id :=
- Package_Table.Last (In_Tree.Packages);
+ Package_Table.Last (In_Tree.Packages);
The_New_Package : Package_Element;
Project_Of_Renamed_Package : constant Project_Node_Id :=
- Project_Of_Renamed_Package_Of (Current_Item, Node_Tree);
+ Project_Of_Renamed_Package_Of
+ (Current_Item, Node_Tree);
begin
-- Set the name of the new package
Name_Of (Current_Item, Node_Tree));
begin
- -- For a renamed package, copy the declarations of
- -- the renamed package, but set all the locations
- -- to the location of the package name in the
- -- renaming declaration.
+ -- For a renamed package, copy the declarations of the
+ -- renamed package, but set all the locations to the
+ -- location of the package name in the renaming
+ -- declaration.
Copy_Package_Declarations
(From => In_Tree.Packages.Table (Renamed_Package).Decl,
Project_Level => False);
end if;
- -- Process declarative items (nothing to do when the
- -- package is renaming, as the first declarative item is
- -- null).
+ -- Process declarative items (nothing to do when the package is
+ -- renaming, as the first declarative item is null).
Process_Declarative_Items
(Project => Project,
(Current_Item : Project_Node_Id)
is
Current_Item_Name : constant Name_Id :=
- Name_Of (Current_Item, Node_Tree);
+ Name_Of (Current_Item, Node_Tree);
-- The name of the attribute
Current_Location : constant Source_Ptr :=
- Location_Of (Current_Item, Node_Tree);
+ Location_Of (Current_Item, Node_Tree);
New_Array : Array_Id;
-- The new associative array created
-- value is.
Orig_Package_Name : Name_Id := No_Name;
- -- The name of the package, if any, where the associative
- -- array value is.
+ -- The name of the package, if any, where the associative array value
+ -- is located.
Orig_Package : Package_Id := No_Package;
- -- The id of the package, if any, where the associative
- -- array value is.
+ -- The id of the package, if any, where the associative array value
+ -- is located.
New_Element : Array_Element_Id := No_Array_Element;
-- Id of a new array element created
-- Current array element in original associative array
Next_Element : Array_Element_Id := No_Array_Element;
- -- Id of the array element that follows the new element.
- -- This is not always nil, because values for the
- -- associative array attribute may already have been
- -- declared, and the array elements declared are reused.
+ -- Id of the array element that follows the new element. This is not
+ -- always nil, because values for the associative array attribute may
+ -- already have been declared, and the array elements declared are
+ -- reused.
Prj : Project_List;
begin
- -- First find if the associative array attribute already
- -- has elements declared.
+ -- First find if the associative array attribute already has elements
+ -- declared.
if Pkg /= No_Package then
New_Array := In_Tree.Packages.Table (Pkg).Decl.Arrays;
New_Array := In_Tree.Arrays.Table (New_Array).Next;
end loop;
- -- If the attribute has never been declared add new entry
- -- in the arrays of the project/package and link it.
+ -- If the attribute has never been declared add new entry in the
+ -- arrays of the project/package and link it.
if New_Array = No_Array then
Array_Table.Increment_Last (In_Tree.Arrays);
Orig_Array := Orig_Project.Decl.Arrays;
else
- -- If in a package, find the package where the value
- -- is declared.
+ -- If in a package, find the package where the value is declared
Orig_Package_Name :=
Name_Of
"original package not found");
while In_Tree.Packages.Table
- (Orig_Package).Name /= Orig_Package_Name
+ (Orig_Package).Name /= Orig_Package_Name
loop
Orig_Package := In_Tree.Packages.Table (Orig_Package).Next;
pragma Assert (Orig_Package /= No_Package,
if Prev_Element = No_Array_Element then
- -- And there is no array element declared yet,
- -- create a new first array element.
+ -- And there is no array element declared yet, create a new
+ -- first array element.
if In_Tree.Arrays.Table (New_Array).Value =
No_Array_Element
In_Tree.Array_Elements.Table (Orig_Element).Next;
end loop;
- -- Make sure that the array ends here, in case there
- -- previously a greater number of elements.
+ -- Make sure that the array ends here, in case there previously a
+ -- greater number of elements.
In_Tree.Array_Elements.Table (New_Element).Next :=
No_Array_Element;
(Current : Project_Node_Id;
New_Value : Variable_Value)
is
- Name : constant Name_Id := Name_Of (Current, Node_Tree);
+ Name : constant Name_Id := Name_Of (Current, Node_Tree);
Current_Location : constant Source_Ptr :=
- Location_Of (Current, Node_Tree);
+ Location_Of (Current, Node_Tree);
Index_Name : Name_Id :=
- Associative_Array_Index_Of (Current, Node_Tree);
+ Associative_Array_Index_Of (Current, Node_Tree);
Source_Index : constant Int :=
- Source_Index_Of (Current, Node_Tree);
+ Source_Index_Of (Current, Node_Tree);
The_Array : Array_Id;
Elem : Array_Element_Id := No_Array_Element;
The_Array := In_Tree.Arrays.Table (The_Array).Next;
end loop;
- -- If the array cannot be found, create a new entry
- -- in the list. As The_Array_Element is initialized
- -- to No_Array_Element, a new element will be
- -- created automatically later
+ -- If the array cannot be found, create a new entry in the list.
+ -- As The_Array_Element is initialized to No_Array_Element, a new
+ -- element will be created automatically later
if The_Array = No_Array then
Array_Table.Increment_Last (In_Tree.Arrays);
Elem := In_Tree.Arrays.Table (The_Array).Value;
end if;
- -- Look in the list, if any, to find an element
- -- with the same index and same source index.
+ -- Look in the list, if any, to find an element with the same index
+ -- and same source index.
while Elem /= No_Array_Element
and then
(In_Tree.Array_Elements.Table (Elem).Index /= Index_Name
- or else
- In_Tree.Array_Elements.Table (Elem).Src_Index /= Source_Index)
+ or else
+ In_Tree.Array_Elements.Table (Elem).Src_Index /= Source_Index)
loop
Elem := In_Tree.Array_Elements.Table (Elem).Next;
end loop;
In_Tree.Arrays.Table (The_Array).Value := Elem;
else
- -- An element with the same index already exists,
- -- just replace its value with the new one.
+ -- An element with the same index already exists, just replace its
+ -- value with the new one.
In_Tree.Array_Elements.Table (Elem).Value := New_Value;
end if;
New_Value : Variable_Value)
is
Name : constant Name_Id := Name_Of (Current_Item, Node_Tree);
- Var : Variable_Id := No_Variable;
+ Var : Variable_Id := No_Variable;
+
Is_Attribute : constant Boolean :=
- Kind_Of (Current_Item, Node_Tree) = N_Attribute_Declaration;
+ Kind_Of (Current_Item, Node_Tree) =
+ N_Attribute_Declaration;
begin
-- First, find the list where to find the variable or attribute.
Var := In_Tree.Variable_Elements.Table (Var).Next;
end loop;
- -- If it has not been declared, create a new entry
- -- in the list.
+ -- If it has not been declared, create a new entry in the list
if Var = No_Variable then
- -- All single string attribute should already have
- -- been declared with a default empty string value.
+ -- All single string attribute should already have been declared
+ -- with a default empty string value.
pragma Assert
(not Is_Attribute,
Project.Decl.Variables := Var;
end if;
- -- If the variable/attribute has already been
- -- declared, just change the value.
+ -- If the variable/attribute has already been declared, just
+ -- change the value.
else
In_Tree.Variable_Elements.Table (Var).Value := New_Value;
-- Process_Expression --
------------------------
- procedure Process_Expression
- (Current : Project_Node_Id)
- is
+ procedure Process_Expression (Current : Project_Node_Id) is
New_Value : Variable_Value :=
- Expression
- (Project => Project,
- In_Tree => In_Tree,
- From_Project_Node => From_Project_Node,
- From_Project_Node_Tree => Node_Tree,
- Env => Env,
- Pkg => Pkg,
- First_Term =>
- Tree.First_Term
- (Expression_Of (Current, Node_Tree), Node_Tree),
- Kind => Expression_Kind_Of (Current, Node_Tree));
+ Expression
+ (Project => Project,
+ In_Tree => In_Tree,
+ From_Project_Node => From_Project_Node,
+ From_Project_Node_Tree => Node_Tree,
+ Env => Env,
+ Pkg => Pkg,
+ First_Term =>
+ Tree.First_Term
+ (Expression_Of (Current, Node_Tree), Node_Tree),
+ Kind =>
+ Expression_Kind_Of (Current, Node_Tree));
begin
-- Process a typed variable declaration
- if Kind_Of (Current, Node_Tree) =
- N_Typed_Variable_Declaration
- then
+ if Kind_Of (Current, Node_Tree) = N_Typed_Variable_Declaration then
Check_Or_Set_Typed_Variable (New_Value, Current);
end if;
-------------------------------
procedure Process_Case_Construction
- (Current_Item : Project_Node_Id)
+ (Current_Item : Project_Node_Id)
is
The_Project : Project_Id := Project;
-- The id of the project of the case variable
Name : Name_Id := No_Name;
begin
- -- If a project was specified for the case variable,
- -- get its id.
+ -- If a project was specified for the case variable, get its id
if Present (Project_Node_Of (Variable_Node, Node_Tree)) then
Name :=
Imported_Or_Extended_Project_From (Project, Name);
end if;
- -- If a package were specified for the case variable,
- -- get its id.
+ -- If a package was specified for the case variable, get its id
if Present (Package_Node_Of (Variable_Node, Node_Tree)) then
Name :=
Name := Name_Of (Variable_Node, Node_Tree);
- -- First, look for the case variable into the package,
- -- if any.
+ -- First, look for the case variable into the package, if any
if The_Package /= No_Package then
- Var_Id := In_Tree.Packages.Table (The_Package).Decl.Variables;
Name := Name_Of (Variable_Node, Node_Tree);
+
+ Var_Id := In_Tree.Packages.Table (The_Package).Decl.Variables;
while Var_Id /= No_Variable
and then In_Tree.Variable_Elements.Table (Var_Id).Name /= Name
loop
end loop;
end if;
- -- If not found in the package, or if there is no
- -- package, look at the project level.
+ -- If not found in the package, or if there is no package, look at
+ -- the project level.
if Var_Id = No_Variable
and then No (Package_Node_Of (Variable_Node, Node_Tree))
if Var_Id = No_Variable then
- -- Should never happen, because this has already been
- -- checked during parsing.
+ -- Should never happen, because this has already been checked
+ -- during parsing.
Write_Line
("variable """ & Get_Name_String (Name) & """ not found");
if The_Variable.Kind /= Single then
- -- Should never happen, because this has already been
- -- checked during parsing.
+ -- Should never happen, because this has already been checked
+ -- during parsing.
Write_Line ("variable""" & Get_Name_String (Name) &
""" is not a single string variable");
end if;
-- Get the case variable value
+
Case_Value := The_Variable.Value;
end;
while Present (Case_Item) loop
Choice_String := First_Choice_Of (Case_Item, Node_Tree);
- -- When Choice_String is nil, it means that it is
- -- the "when others =>" alternative.
+ -- When Choice_String is nil, it means that it is the
+ -- "when others =>" alternative.
if No (Choice_String) then
Decl_Item := First_Declarative_Item_Of (Case_Item, Node_Tree);
when N_Package_Declaration =>
Process_Package_Declaration (Current);
+ -- Nothing to process for string type declaration
+
when N_String_Type_Declaration =>
- -- There is nothing to process
null;
when N_Attribute_Declaration |
declare
Object_Dir : constant Path_Information :=
Project.Object_Directory;
+
begin
Prj := In_Tree.Projects;
while Prj /= null loop
if Prj.Project.Virtual then
Prj.Project.Object_Directory := Object_Dir;
end if;
+
Prj := Prj.Next;
end loop;
end;
-- Imported is the id of the last imported project.
procedure Process_Aggregated_Projects;
- -- Process all the projects aggregated in List.
- -- This does nothing if the project is not an aggregate project.
+ -- Process all the projects aggregated in List. This does nothing if the
+ -- project is not an aggregate project.
procedure Process_Extended_Project;
- -- Process the extended project:
- -- inherit all packages from the extended project that are not
- -- explicitly defined or renamed. Also inherit the languages, if
- -- attribute Languages is not explicitly defined.
+ -- Process the extended project: inherit all packages from the extended
+ -- project that are not explicitly defined or renamed. Also inherit the
+ -- languages, if attribute Languages is not explicitly defined.
-------------------------------
-- Process_Imported_Projects --
end loop;
if Current_Pkg = No_Package then
- Package_Table.Increment_Last
- (In_Tree.Packages);
+ Package_Table.Increment_Last (In_Tree.Packages);
Current_Pkg := Package_Table.Last (In_Tree.Packages);
In_Tree.Packages.Table (Current_Pkg) :=
(Name => Element.Name,
Project.Decl.Packages := Current_Pkg;
Copy_Package_Declarations
(From => Element.Decl,
- To =>
- In_Tree.Packages.Table (Current_Pkg).Decl,
+ To => In_Tree.Packages.Table (Current_Pkg).Decl,
New_Loc => No_Location,
Restricted => True,
In_Tree => In_Tree);
Extended_Pkg := Element.Next;
end loop;
- -- Check if attribute Languages is declared in the
- -- extending project.
+ -- Check if attribute Languages is declared in the extending project
Attribute1 := Project.Decl.Attributes;
while Attribute1 /= No_Variable loop
- Attr_Value1 := In_Tree.Variable_Elements.
- Table (Attribute1);
+ Attr_Value1 := In_Tree.Variable_Elements. Table (Attribute1);
exit when Attr_Value1.Name = Snames.Name_Languages;
Attribute1 := Attr_Value1.Next;
end loop;
- if Attribute1 = No_Variable or else
- Attr_Value1.Value.Default
+ if Attribute1 = No_Variable
+ or else Attr_Value1.Value.Default
then
- -- Attribute Languages is not declared in the extending
- -- project. Check if it is declared in the project being
- -- extended.
+ -- Attribute Languages is not declared in the extending project.
+ -- Check if it is declared in the project being extended.
Attribute2 := Project.Extends.Decl.Attributes;
while Attribute2 /= No_Variable loop
- Attr_Value2 := In_Tree.Variable_Elements.
- Table (Attribute2);
+ Attr_Value2 := In_Tree.Variable_Elements.Table (Attribute2);
exit when Attr_Value2.Name = Snames.Name_Languages;
Attribute2 := Attr_Value2.Next;
end loop;
if Attribute2 /= No_Variable and then
not Attr_Value2.Value.Default
then
- -- As attribute Languages is declared in the project
- -- being extended, copy its value for the extending
- -- project.
+ -- As attribute Languages is declared in the project being
+ -- extended, copy its value for the extending project.
if Attribute1 = No_Variable then
Variable_Element_Table.Increment_Last
--------------------
procedure Override_Flags
- (Self : in out Environment; Flags : Prj.Processing_Flags) is
+ (Self : in out Environment;
+ Flags : Prj.Processing_Flags)
+ is
begin
Self.Flags := Flags;
end Override_Flags;
(Self : in 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
+ -- 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);
+
+ -- Why is this line commented out ???
-- Prj.Ext.Reset (Tree.External);
Self.Flags := Flags;
-- 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 : 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
-- particular when using different compilers with different default
-- search directories.
- Flags : Prj.Processing_Flags;
+ Flags : Prj.Processing_Flags;
-- Configure errors and warnings
end record;
- -- This record contains the context in which projects are parsed and
- -- processed (finding importing project, resolving external values,...)
procedure Initialize (Self : in out Environment; Flags : Processing_Flags);
-- Initialize a new environment
The_Empty_String : Name_Id := No_Name;
Debug_Level : Integer := 0;
- -- Current indentation level for debug traces.
+ -- Current indentation level for debug traces
type Cst_String_Access is access constant String;
-------------------
function Empty_Project
- (Qualifier : Project_Qualifier) return Project_Data is
+ (Qualifier : Project_Qualifier) return Project_Data
+ is
begin
Prj.Initialize (Tree => No_Project_Tree);
declare
Data : Project_Data (Qualifier => Qualifier);
+
begin
-- Only the fields for which no default value could be provided in
-- prj.ads are initialized below
procedure Expect (The_Token : Token_Type; Token_Image : String) is
begin
if Token /= The_Token then
+
-- ??? Should pass user flags here instead
+
Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr);
end if;
end Expect;
--------------------------------
procedure For_Every_Project_Imported
- (By : Project_Id;
- With_State : in out State;
+ (By : Project_Id;
+ With_State : in out State;
Include_Aggregated : Boolean := True;
- Imported_First : Boolean := False)
+ Imported_First : Boolean := False)
is
use Project_Boolean_Htable;
Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil;
-- Free the memory used for List
procedure Add_Aggregated_Project
- (Project : Project_Id; Path : Path_Name_Type);
+ (Project : Project_Id;
+ Path : Path_Name_Type);
-- Add a new aggregated project in Project.
-- The aggregated project has not been processed yet. This procedure should
-- the called while processing the aggregate project, and as a result
------------------
-- Project_Data --
------------------
+
-- The following record describes a project file representation
type Project_Data (Qualifier : Project_Qualifier := Unspecified) is record
-- in the project tree.
-----------------------------
- -- qualifier-specific data --
+ -- Qualifier-Specific data --
-----------------------------
- -- The following fields are only valid for specific types of projects.
+
+ -- The following fields are only valid for specific types of projects
case Qualifier is
when Aggregate =>
(Project : Project_Id;
With_State : in out State);
procedure For_Every_Project_Imported
- (By : Project_Id;
- With_State : in out State;
+ (By : Project_Id;
+ With_State : in out State;
Include_Aggregated : Boolean := True;
- Imported_First : Boolean := False);
+ Imported_First : Boolean := False);
-- Call Action for each project imported directly or indirectly by project
-- By, as well as extended projects.
--
for J in 1 .. ALFA_File_Table.Last loop
declare
F : ALFA_File_Record renames ALFA_File_Table.Table (J);
-
Start : Scope_Index;
Stop : Scope_Index;
for J in 1 .. ALFA_File_Table.Last loop
declare
F : ALFA_File_Record renames ALFA_File_Table.Table (J);
-
Start : Scope_Index;
Stop : Scope_Index;
-
File : Nat;
Scope : Nat;
Entity_Line : Nat;
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-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- --
Write_Str (" convention : ");
case Convention (Ent) is
- when Convention_Ada => Write_Line ("Ada");
- when Convention_Intrinsic => Write_Line ("InLineinsic");
- when Convention_Entry => Write_Line ("Entry");
- when Convention_Protected => Write_Line ("Protected");
- when Convention_Assembler => Write_Line ("Assembler");
- when Convention_C => Write_Line ("C");
- when Convention_CIL => Write_Line ("CIL");
- when Convention_COBOL => Write_Line ("COBOL");
- when Convention_CPP => Write_Line ("C++");
- when Convention_Fortran => Write_Line ("Fortran");
- when Convention_Java => Write_Line ("Java");
- when Convention_Stdcall => Write_Line ("Stdcall");
- when Convention_Stubbed => Write_Line ("Stubbed");
+ when Convention_Ada =>
+ Write_Line ("Ada");
+ when Convention_Ada_Pass_By_Copy =>
+ Write_Line ("Ada_Pass_By_Copy");
+ when Convention_Ada_Pass_By_Reference =>
+ Write_Line ("Ada_Pass_By_Reference");
+ when Convention_Intrinsic =>
+ Write_Line ("Intrinsic");
+ when Convention_Entry =>
+ Write_Line ("Entry");
+ when Convention_Protected =>
+ Write_Line ("Protected");
+ when Convention_Assembler =>
+ Write_Line ("Assembler");
+ when Convention_C =>
+ Write_Line ("C");
+ when Convention_CIL =>
+ Write_Line ("CIL");
+ when Convention_COBOL =>
+ Write_Line ("COBOL");
+ when Convention_CPP =>
+ Write_Line ("C++");
+ when Convention_Fortran =>
+ Write_Line ("Fortran");
+ when Convention_Java =>
+ Write_Line ("Java");
+ when Convention_Stdcall =>
+ Write_Line ("Stdcall");
+ when Convention_Stubbed =>
+ Write_Line ("Stubbed");
end case;
-- Find max length of formal name
-- 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);
+ (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_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.
+ -- 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_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
+ -- 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
Set_Etype (N, Aggr_Typ); -- May be overridden later on
- if Pkind = N_Assignment_Statement or else
- (Is_Constrained (Typ) and then
- (Pkind = N_Parameter_Association or else
- Pkind = N_Function_Call or else
- Pkind = N_Procedure_Call_Statement or else
- Pkind = N_Generic_Association or else
- Pkind = N_Formal_Object_Declaration or else
- Pkind = N_Simple_Return_Statement or else
- Pkind = N_Object_Declaration or else
- Pkind = N_Component_Declaration or else
- Pkind = N_Parameter_Specification or else
- Pkind = N_Qualified_Expression or else
- Pkind = N_Aggregate or else
- Pkind = N_Extension_Aggregate or else
- Pkind = N_Component_Association))
+ if Pkind = N_Assignment_Statement
+ or else (Is_Constrained (Typ)
+ and then
+ (Pkind = N_Parameter_Association or else
+ Pkind = N_Function_Call or else
+ Pkind = N_Procedure_Call_Statement or else
+ Pkind = N_Generic_Association or else
+ Pkind = N_Formal_Object_Declaration or else
+ Pkind = N_Simple_Return_Statement or else
+ Pkind = N_Object_Declaration or else
+ Pkind = N_Component_Declaration or else
+ Pkind = N_Parameter_Specification or else
+ Pkind = N_Qualified_Expression or else
+ Pkind = N_Aggregate or else
+ Pkind = N_Extension_Aggregate or else
+ Pkind = N_Component_Association))
then
Aggr_Resolved :=
Resolve_Array_Aggregate
end if;
Aggr_Subtyp := Any_Composite;
+
else
Aggr_Subtyp := Array_Aggr_Subtype (N, Typ);
end if;
Check_E2;
end Check_Floating_Point_Type_2;
- ------------------------------------------
- -- Check_SPARK_Restriction_On_Attribute --
- ------------------------------------------
-
- procedure Check_SPARK_Restriction_On_Attribute is
- begin
- Error_Msg_Name_1 := Aname;
- Check_SPARK_Restriction ("attribute % is not allowed", P);
- end Check_SPARK_Restriction_On_Attribute;
-
------------------------
-- Check_Integer_Type --
------------------------
end if;
end Check_Scalar_Type;
+ ------------------------------------------
+ -- Check_SPARK_Restriction_On_Attribute --
+ ------------------------------------------
+
+ procedure Check_SPARK_Restriction_On_Attribute is
+ begin
+ Error_Msg_Name_1 := Aname;
+ Check_SPARK_Restriction ("attribute % is not allowed", P);
+ end Check_SPARK_Restriction_On_Attribute;
+
---------------------------
-- Check_Standard_Prefix --
---------------------------
else
return Has_Aliased_Components (Base_Type (T1))
- = Has_Aliased_Components (Base_Type (T2));
+ =
+ Has_Aliased_Components (Base_Type (T2));
end if;
end if;
end if;
IR : constant Node_Id := Make_Itype_Reference (Sloc (Nod));
begin
- -- Itype references are only created for use by the back-end.
+ -- Itype references are only created for use by the back-end
if Inside_A_Generic then
return;
if Nkind (N) = N_Simple_Return_Statement then
Expr := Expression (N);
- -- Guard against a malformed expression. The parser may have
- -- tried to recover but the node is not analyzable.
+ -- Guard against a malformed expression. The parser may have tried to
+ -- recover but the node is not analyzable.
if Nkind (Expr) = N_Error then
Set_Etype (Expr, Any_Type);
-- If S is a derived operation for an untagged type then by
-- definition it's not a dispatching operation (even if the parent
- -- operation was dispatching), so we don't call
- -- Check_Dispatching_Operation in that case.
+ -- operation was dispatching), so Check_Dispatching_Operation is not
+ -- called in that case.
if No (Derived_Type)
or else Is_Tagged_Type (Derived_Type)
Subt : Entity_Id;
begin
- if (Nkind (Nam) = N_Function_Call
- or else Nkind (Nam) = N_Explicit_Dereference)
+ if Nkind_In (Nam, N_Function_Call, N_Explicit_Dereference)
and then Is_Composite_Type (Etype (Nam))
and then not Is_Constrained (Etype (Nam))
and then not Has_Unknown_Discriminants (Etype (Nam))
and then Expander_Active
then
- -- If Actual_Sbutype is already set, nothing to do.
+ -- If Actual_Subtype is already set, nothing to do
- if (Ekind (Id) = E_Variable
- or else Ekind (Id) = E_Constant)
+ if Ekind_In (Id, E_Variable, E_Constant)
and then Present (Actual_Subtype (Id))
then
null;
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
null;
end if;
+ -- Special Ada conventions specifying passing mechanism
+
+ when Convention_Ada_Pass_By_Copy =>
+ Set_Mechanism (Formal, By_Copy);
+
+ when Convention_Ada_Pass_By_Reference =>
+ Set_Mechanism (Formal, By_Reference);
+
-------
-- C --
-------
Ent := E;
+ -- Ada_Pass_By_Copy special checking
+
+ if C = Convention_Ada_Pass_By_Copy then
+ if not Is_First_Subtype (E) then
+ Error_Pragma_Arg
+ ("convention `Ada_Pass_By_Copy` only "
+ & "allowed for types", Arg2);
+ end if;
+
+ if Is_By_Reference_Type (E) then
+ Error_Pragma_Arg
+ ("convention `Ada_Pass_By_Copy` not allowed for "
+ & "by-reference type", Arg1);
+ end if;
+ end if;
+
+ -- Ada_Pass_By_Reference special checking
+
+ if C = Convention_Ada_Pass_By_Reference then
+ if not Is_First_Subtype (E) then
+ Error_Pragma_Arg
+ ("convention `Ada_Pass_By_Reference` only "
+ & "allowed for types", Arg2);
+ end if;
+
+ if Is_By_Copy_Type (E) then
+ Error_Pragma_Arg
+ ("convention `Ada_Pass_By_Reference` not allowed for "
+ & "by-copy type", Arg1);
+ end if;
+ end if;
+
-- Go to renamed subprogram if present, since convention applies to
-- the actual renamed entity, not to the renaming entity. If the
-- subprogram is inherited, go to parent subprogram.
function Get_Convention_Id (N : Name_Id) return Convention_Id is
begin
case N is
- when Name_Ada => return Convention_Ada;
- when Name_Assembler => return Convention_Assembler;
- when Name_C => return Convention_C;
- when Name_CIL => return Convention_CIL;
- when Name_COBOL => return Convention_COBOL;
- when Name_CPP => return Convention_CPP;
- when Name_Fortran => return Convention_Fortran;
- when Name_Intrinsic => return Convention_Intrinsic;
- when Name_Java => return Convention_Java;
- when Name_Stdcall => return Convention_Stdcall;
- when Name_Stubbed => return Convention_Stubbed;
+ when Name_Ada => return Convention_Ada;
+ when Name_Ada_Pass_By_Copy => return Convention_Ada_Pass_By_Copy;
+ when Name_Ada_Pass_By_Reference =>
+ return Convention_Ada_Pass_By_Reference;
+ when Name_Assembler => return Convention_Assembler;
+ when Name_C => return Convention_C;
+ when Name_CIL => return Convention_CIL;
+ when Name_COBOL => return Convention_COBOL;
+ when Name_CPP => return Convention_CPP;
+ when Name_Fortran => return Convention_Fortran;
+ when Name_Intrinsic => return Convention_Intrinsic;
+ when Name_Java => return Convention_Java;
+ when Name_Stdcall => return Convention_Stdcall;
+ when Name_Stubbed => return Convention_Stubbed;
-- If no direct match, then we must have a convention
-- identifier pragma that has specified this name.
- when others =>
+ when others =>
for J in 1 .. Convention_Identifiers.Last loop
if N = Convention_Identifiers.Table (J).Name then
return Convention_Identifiers.Table (J).Convention;
function Get_Convention_Name (C : Convention_Id) return Name_Id is
begin
case C is
- when Convention_Ada => return Name_Ada;
- when Convention_Assembler => return Name_Assembler;
- when Convention_C => return Name_C;
- when Convention_CIL => return Name_CIL;
- when Convention_COBOL => return Name_COBOL;
- when Convention_CPP => return Name_CPP;
- when Convention_Entry => return Name_Entry;
- when Convention_Fortran => return Name_Fortran;
- when Convention_Intrinsic => return Name_Intrinsic;
- when Convention_Java => return Name_Java;
- when Convention_Protected => return Name_Protected;
- when Convention_Stdcall => return Name_Stdcall;
- when Convention_Stubbed => return Name_Stubbed;
+ when Convention_Ada => return Name_Ada;
+ when Convention_Ada_Pass_By_Copy => return Name_Ada_Pass_By_Copy;
+ when Convention_Ada_Pass_By_Reference =>
+ return Name_Ada_Pass_By_Reference;
+ when Convention_Assembler => return Name_Assembler;
+ when Convention_C => return Name_C;
+ when Convention_CIL => return Name_CIL;
+ when Convention_COBOL => return Name_COBOL;
+ when Convention_CPP => return Name_CPP;
+ when Convention_Entry => return Name_Entry;
+ when Convention_Fortran => return Name_Fortran;
+ when Convention_Intrinsic => return Name_Intrinsic;
+ when Convention_Java => return Name_Java;
+ when Convention_Protected => return Name_Protected;
+ when Convention_Stdcall => return Name_Stdcall;
+ when Convention_Stubbed => return Name_Stubbed;
end case;
end Get_Convention_Name;
First_Convention_Name : constant Name_Id := N + $;
Name_Ada : constant Name_Id := N + $;
+ Name_Ada_Pass_By_Copy : constant Name_Id := N + $;
+ Name_Ada_Pass_By_Reference : constant Name_Id := N + $;
Name_Assembler : constant Name_Id := N + $;
Name_CIL : constant Name_Id := N + $;
Name_COBOL : constant Name_Id := N + $;
Convention_Protected,
Convention_Stubbed,
+ -- The following conventions are equivalent to Ada for all purposes
+ -- except controlling the way parameters are passed.
+
+ Convention_Ada_Pass_By_Copy,
+ Convention_Ada_Pass_By_Reference,
+
-- The remaining conventions are foreign language conventions
Convention_Assembler, -- also Asm, Assembly
Convention_Java,
Convention_Stdcall); -- also DLL, Win32
- -- Note: Convention C_Pass_By_Copy is allowed only for record
- -- types (where it is treated like C except that the appropriate
- -- flag is set in the record type). Recognizing this convention
- -- is specially handled in Sem_Prag.
+ -- Note: Convention C_Pass_By_Copy is allowed only for record types
+ -- (where it is treated like C except that the appropriate flag is set
+ -- in the record type). Recognizing this convention is specially handled
+ -- in Sem_Prag.
for Convention_Id'Size use 8;
-- Plenty of space for expansion
OSDN Git Service
