Skip to content

R
riscv-gcc-1
Commit c4d67e2d by Arnaud Charlet
Options

[multiple changes] 

2011-08-03  Yannick Moy  <moy@adacore.com>

	* sem_ch6.adb (New_Overloaded_Entity): only issue error for SPARK
	restriction on overloaded entity if the entity is not an operator.

2011-08-03  Yannick Moy  <moy@adacore.com>

	* sem_ch7.adb, sem_res.adb, sem_attr.adb, restrict.adb,
	restrict.ads: Rename remaining Check_Formal_Restriction* into
	Check_SPARK_Restriction*.

2011-08-03  Emmanuel Briot  <briot@adacore.com>

	* prj-proc.adb, prj-part.adb, prj.adb, prj.ads, prj-nmsc.adb,
	prj-nmsc.ads, prj-err.adb (Project_Data): now discriminated on its
	qualifier.
	(Project_Empty): removed
	(Empty_Project): new parameter Qualifier
	This is used to have fields specific to aggregate projects, cleaner
	New field to store the list of aggregated projects.
	(Check_Aggregate_Project): removed
	(Process_Aggregated_Projects, Free): new subprograms.

From-SVN: r177243
parent 3f5a8fee
Showing with 746 additions and 663 deletions
gcc/ada/ChangeLog
2011-08-03 Yannick Moy <moy@adacore.com>
* sem_ch6.adb (New_Overloaded_Entity): only issue error for SPARK
restriction on overloaded entity if the entity is not an operator.
2011-08-03 Yannick Moy <moy@adacore.com>
* sem_ch7.adb, sem_res.adb, sem_attr.adb, restrict.adb,
restrict.ads: Rename remaining Check_Formal_Restriction* into
Check_SPARK_Restriction*.
2011-08-03 Emmanuel Briot <briot@adacore.com>
* prj-proc.adb, prj-part.adb, prj.adb, prj.ads, prj-nmsc.adb,
prj-nmsc.ads, prj-err.adb (Project_Data): now discriminated on its
qualifier.
(Project_Empty): removed
(Empty_Project): new parameter Qualifier
This is used to have fields specific to aggregate projects, cleaner
New field to store the list of aggregated projects.
(Check_Aggregate_Project): removed
(Process_Aggregated_Projects, Free): new subprograms.
2011-08-03 Olivier Hainque <hainque@adacore.com>
* tracebak.c (STOP_FRAME ppc AIX): Stop at null return address as well.
......
gcc/ada/prj-err.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2002-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- --
......@@ -78,7 +78,7 @@ package body Prj.Err is
-- triggered)
if Current_Verbosity = High then
Write_Line ("ERROR: " & Msg);
Debug_Output ("ERROR: " & Msg);
end if;
-- If location of error is unknown, use the location of the project
......@@ -96,7 +96,7 @@ package body Prj.Err is
-- access to in any case.
if Current_Verbosity = High then
Write_Line ("Error in in-memory project, ignored");
Debug_Output ("Error in in-memory project, ignored");
end if;
return;
......
gcc/ada/prj-nmsc.adb
......@@ -30,6 +30,7 @@ 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;
......@@ -247,7 +248,8 @@ package body Prj.Nmsc is
-- 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
-- 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;
......@@ -322,12 +324,6 @@ package body Prj.Nmsc is
-- Check the library attributes of project Project in project tree
-- and modify its data Data accordingly.
procedure Check_Aggregate_Project
(Project : Project_Id;
Data : in out Tree_Processing_Data);
-- Check aggregate projects attributes, and find the list of aggregated
-- projects. They are stored as a "project_files" language in Project.
procedure Check_Abstract_Project
(Project : Project_Id;
Data : in out Tree_Processing_Data);
......@@ -923,19 +919,27 @@ package body Prj.Nmsc is
end if;
end Canonical_Case_File_Name;
-----------------------------
-- Check_Aggregate_Project --
-----------------------------
---------------------------------
-- Process_Aggregated_Projects --
---------------------------------
procedure Check_Aggregate_Project
(Project : Project_Id;
Data : in out Tree_Processing_Data)
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,
File_To_Source => Files_Htable.Nil,
Flags => Flags);
Project_Files : constant Prj.Variable_Value :=
Prj.Util.Value_Of
(Snames.Name_Project_Files,
Project.Decl.Attributes,
Data.Tree);
Tree);
Project_Path_For_Aggregate : Prj.Env.Project_Search_Path;
......@@ -954,7 +958,6 @@ package body Prj.Nmsc is
procedure Found_Project_File (Path : Path_Information; Rank : Natural) is
pragma Unreferenced (Rank);
Full_Path : Path_Name_Type;
begin
Debug_Output ("Aggregates: ", Name_Id (Path.Display_Name));
......@@ -963,30 +966,37 @@ package body Prj.Nmsc is
-- 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
Prj.Env.Find_Project
(Self => Project_Path_For_Aggregate,
Project_File_Name => Get_Name_String (Path.Name),
Directory => Get_Name_String (Project.Path.Name),
Path => Full_Path);
Add_Aggregated_Project (Project, Path => Path.Name);
end Found_Project_File;
-- Start of processing for Check_Aggregate_Project
begin
pragma Assert (Project.Qualifier = Aggregate);
if Project_Files.Default then
Error_Msg_Name_1 := Snames.Name_Project_Files;
Error_Msg
(Data.Flags,
(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
......@@ -1001,7 +1011,7 @@ package body Prj.Nmsc is
Resolve_Links => Opt.Follow_Links_For_Files);
Free (Project_Path_For_Aggregate);
end Check_Aggregate_Project;
end Process_Aggregated_Projects;
----------------------------
-- Check_Abstract_Project --
......@@ -1058,7 +1068,7 @@ package body Prj.Nmsc is
Prj_Data : Project_Processing_Data;
begin
Debug_Increase_Indent ("Check ", Project.Name);
Debug_Increase_Indent ("Check", Project.Name);
Initialize (Prj_Data, Project);
......@@ -1074,7 +1084,6 @@ package body Prj.Nmsc is
end if;
case Project.Qualifier is
when Aggregate => Check_Aggregate_Project (Project, Data);
when Dry => Check_Abstract_Project (Project, Data);
when others => null;
end case;
......@@ -5222,7 +5231,7 @@ package body Prj.Nmsc is
if Current_Verbosity = High then
if Project.Object_Directory = No_Path_Information then
Write_Line ("No object directory");
Debug_Output ("No object directory");
else
Write_Attr
("Object directory",
......@@ -7928,17 +7937,20 @@ package body Prj.Nmsc is
Element : String_Element;
begin
if Project.Source_Dirs = Nil_String then
Debug_Output ("No source dirs");
else
Debug_Increase_Indent ("Source_Dirs:");
Current := Project.Source_Dirs;
while Current /= Nil_String loop
Element := In_Tree.String_Elements.Table (Current);
Write_Str (" ");
Write_Line (Get_Name_String (Element.Display_Value));
Debug_Output (Get_Name_String (Element.Display_Value));
Current := Element.Next;
end loop;
Debug_Decrease_Indent ("end Source_Dirs.");
end if;
end Show_Source_Dirs;
---------------------------
......
gcc/ada/prj-nmsc.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2010, Free Software Foundation, Inc. --
-- 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- --
......@@ -42,4 +42,16 @@ private package Prj.Nmsc is
-- 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;
gcc/ada/prj-part.adb
......@@ -1870,7 +1870,7 @@ package body Prj.Part is
Tree.Restore_And_Free (Project_Comment_State);
Debug_Decrease_Indent ("Done parsing project");
Debug_Decrease_Indent;
end Parse_Single_Project;
-----------------------
......
gcc/ada/prj-proc.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
-- 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- --
......@@ -31,6 +31,7 @@ with Prj.Attr; use Prj.Attr;
with Prj.Err; use Prj.Err;
with Prj.Ext; use Prj.Ext;
with Prj.Nmsc; use Prj.Nmsc;
with Prj.Part;
with Snames;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
......@@ -128,7 +129,7 @@ package body Prj.Proc is
In_Tree : Project_Tree_Ref;
Flags : Processing_Flags;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Node_Tree : Project_Node_Tree_Ref;
Pkg : Package_Id;
Item : Project_Node_Id);
-- Process declarative items starting with From_Project_Node, and put them
......@@ -1421,7 +1422,7 @@ package body Prj.Proc is
In_Tree : Project_Tree_Ref;
Flags : Processing_Flags;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Node_Tree : Project_Node_Tree_Ref;
Pkg : Package_Id;
Item : Project_Node_Id)
is
......@@ -1433,6 +1434,23 @@ package body Prj.Proc is
-- reported, or a warning, or nothing. In the last two cases, the value
-- of the variable is set to a valid value, replacing Value.
procedure Process_Package_Declaration
(Current_Item : Project_Node_Id);
procedure Process_Attribute_Declaration (Current : Project_Node_Id);
procedure Process_Case_Construction
(Current_Item : Project_Node_Id);
procedure Process_Associative_Array
(Current_Item : Project_Node_Id);
procedure Process_Expression
(Current : Project_Node_Id);
procedure Process_Expression_For_Associative_Array
(Current_Item : Project_Node_Id;
New_Value : Variable_Value);
procedure Process_Expression_Variable_Decl
(Current_Item : Project_Node_Id;
New_Value : Variable_Value);
-- Process the various declarative items
---------------------------------
-- Check_Or_Set_Typed_Variable --
---------------------------------
......@@ -1441,8 +1459,7 @@ package body Prj.Proc is
(Value : in out Variable_Value;
Declaration : Project_Node_Id)
is
Loc : constant Source_Ptr :=
Location_Of (Declaration, From_Project_Node_Tree);
Loc : constant Source_Ptr := Location_Of (Declaration, Node_Tree);
Reset_Value : Boolean := False;
Current_String : Project_Node_Id;
......@@ -1451,7 +1468,7 @@ package body Prj.Proc is
-- Report an error for an empty string
if Value.Value = Empty_String then
Error_Msg_Name_1 := Name_Of (Declaration, From_Project_Node_Tree);
Error_Msg_Name_1 := Name_Of (Declaration, Node_Tree);
case Flags.Allow_Invalid_External is
when Error =>
......@@ -1467,24 +1484,22 @@ package body Prj.Proc is
-- 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, From_Project_Node_Tree),
From_Project_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, From_Project_Node_Tree) /= Value.Value
and then String_Value_Of (Current_String, Node_Tree) /=
Value.Value
loop
Current_String :=
Next_Literal_String (Current_String, From_Project_Node_Tree);
Next_Literal_String (Current_String, Node_Tree);
end loop;
-- Report error if string value is not one for the string type
if No (Current_String) then
Error_Msg_Name_1 := Value.Value;
Error_Msg_Name_2 :=
Name_Of (Declaration, From_Project_Node_Tree);
Error_Msg_Name_2 := Name_Of (Declaration, Node_Tree);
case Flags.Allow_Invalid_External is
when Error =>
......@@ -1505,51 +1520,21 @@ package body Prj.Proc is
if Reset_Value then
Current_String :=
First_Literal_String
(String_Type_Of (Declaration, From_Project_Node_Tree),
From_Project_Node_Tree);
Value.Value := String_Value_Of
(Current_String, From_Project_Node_Tree);
(String_Type_Of (Declaration, Node_Tree), Node_Tree);
Value.Value := String_Value_Of (Current_String, Node_Tree);
end if;
end Check_Or_Set_Typed_Variable;
-- Local variables
Current_Declarative_Item : Project_Node_Id;
Current_Item : Project_Node_Id;
-- Start of processing for Process_Declarative_Items
---------------------------------
-- Process_Package_Declaration --
---------------------------------
procedure Process_Package_Declaration
(Current_Item : Project_Node_Id) is
begin
-- Loop through declarative items
Current_Item := Empty_Node;
Current_Declarative_Item := Item;
while Present (Current_Declarative_Item) loop
-- Get its data
Current_Item :=
Current_Item_Node
(Current_Declarative_Item, From_Project_Node_Tree);
-- And set Current_Declarative_Item to the next declarative item
-- ready for the next iteration.
Current_Declarative_Item :=
Next_Declarative_Item
(Current_Declarative_Item, From_Project_Node_Tree);
case Kind_Of (Current_Item, From_Project_Node_Tree) is
when N_Package_Declaration =>
-- Do not process a package declaration that should be ignored
if Expression_Kind_Of
(Current_Item, From_Project_Node_Tree) /= Ignored
then
if Expression_Kind_Of (Current_Item, Node_Tree) /= Ignored then
-- Create the new package
Package_Table.Increment_Last (In_Tree.Packages);
......@@ -1559,32 +1544,27 @@ package body Prj.Proc is
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, From_Project_Node_Tree);
Project_Of_Renamed_Package : constant Project_Node_Id :=
Project_Of_Renamed_Package_Of (Current_Item, Node_Tree);
begin
-- Set the name of the new package
The_New_Package.Name :=
Name_Of (Current_Item, From_Project_Node_Tree);
The_New_Package.Name := Name_Of (Current_Item, Node_Tree);
-- Insert the new package in the appropriate list
if Pkg /= No_Package then
The_New_Package.Next :=
In_Tree.Packages.Table (Pkg).Decl.Packages;
In_Tree.Packages.Table (Pkg).Decl.Packages :=
New_Pkg;
In_Tree.Packages.Table (Pkg).Decl.Packages := New_Pkg;
else
The_New_Package.Next := Project.Decl.Packages;
Project.Decl.Packages := New_Pkg;
end if;
In_Tree.Packages.Table (New_Pkg) :=
The_New_Package;
In_Tree.Packages.Table (New_Pkg) := The_New_Package;
if Present (Project_Of_Renamed_Package) then
......@@ -1592,21 +1572,16 @@ package body Prj.Proc is
declare
Project_Name : constant Name_Id :=
Name_Of
(Project_Of_Renamed_Package,
From_Project_Node_Tree);
Name_Of (Project_Of_Renamed_Package, Node_Tree);
Renamed_Project :
constant Project_Id :=
Renamed_Project : constant Project_Id :=
Imported_Or_Extended_Project_From
(Project, Project_Name);
Renamed_Package : constant Package_Id :=
Package_From
(Renamed_Project, In_Tree,
Name_Of
(Current_Item,
From_Project_Node_Tree));
Name_Of (Current_Item, Node_Tree));
begin
-- For a renamed package, copy the declarations of
......@@ -1615,13 +1590,9 @@ package body Prj.Proc is
-- renaming declaration.
Copy_Package_Declarations
(From =>
In_Tree.Packages.Table (Renamed_Package).Decl,
To =>
In_Tree.Packages.Table (New_Pkg).Decl,
New_Loc =>
Location_Of
(Current_Item, From_Project_Node_Tree),
(From => In_Tree.Packages.Table (Renamed_Package).Decl,
To => In_Tree.Packages.Table (New_Pkg).Decl,
New_Loc => Location_Of (Current_Item, Node_Tree),
Restricted => False,
In_Tree => In_Tree);
end;
......@@ -1636,10 +1607,8 @@ package body Prj.Proc is
In_Tree,
In_Tree.Packages.Table (New_Pkg).Decl,
First_Attribute_Of
(Package_Id_Of
(Current_Item, From_Project_Node_Tree)),
(Package_Id_Of (Current_Item, Node_Tree)),
Project_Level => False);
end if;
-- Process declarative items (nothing to do when the
......@@ -1651,41 +1620,27 @@ package body Prj.Proc is
In_Tree => In_Tree,
Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Node_Tree => Node_Tree,
Pkg => New_Pkg,
Item =>
First_Declarative_Item_Of
(Current_Item, From_Project_Node_Tree));
First_Declarative_Item_Of (Current_Item, Node_Tree));
end;
end if;
end Process_Package_Declaration;
when N_String_Type_Declaration =>
-- There is nothing to process
null;
when N_Attribute_Declaration |
N_Typed_Variable_Declaration |
N_Variable_Declaration =>
if Expression_Of (Current_Item, From_Project_Node_Tree) =
Empty_Node
then
-- It must be a full associative array attribute declaration
-------------------------------
-- Process_Associative_Array --
-------------------------------
declare
procedure Process_Associative_Array
(Current_Item : Project_Node_Id)
is
Current_Item_Name : constant Name_Id :=
Name_Of
(Current_Item,
From_Project_Node_Tree);
Name_Of (Current_Item, Node_Tree);
-- The name of the attribute
Current_Location : constant Source_Ptr :=
Location_Of
(Current_Item,
From_Project_Node_Tree);
Location_Of (Current_Item, Node_Tree);
New_Array : Array_Id;
-- The new associative array created
......@@ -1731,16 +1686,13 @@ package body Prj.Proc is
-- has elements declared.
if Pkg /= No_Package then
New_Array := In_Tree.Packages.Table
(Pkg).Decl.Arrays;
New_Array := In_Tree.Packages.Table (Pkg).Decl.Arrays;
else
New_Array := Project.Decl.Arrays;
end if;
while New_Array /= No_Array
and then In_Tree.Arrays.Table (New_Array).Name /=
Current_Item_Name
and then In_Tree.Arrays.Table (New_Array).Name /= Current_Item_Name
loop
New_Array := In_Tree.Arrays.Table (New_Array).Next;
end loop;
......@@ -1757,11 +1709,9 @@ package body Prj.Proc is
(Name => Current_Item_Name,
Location => Current_Location,
Value => No_Array_Element,
Next => In_Tree.Packages.Table
(Pkg).Decl.Arrays);
Next => In_Tree.Packages.Table (Pkg).Decl.Arrays);
In_Tree.Packages.Table (Pkg).Decl.Arrays :=
New_Array;
In_Tree.Packages.Table (Pkg).Decl.Arrays := New_Array;
else
In_Tree.Arrays.Table (New_Array) :=
......@@ -1778,9 +1728,7 @@ package body Prj.Proc is
Orig_Project_Name :=
Name_Of
(Associative_Project_Of
(Current_Item, From_Project_Node_Tree),
From_Project_Node_Tree);
(Associative_Project_Of (Current_Item, Node_Tree), Node_Tree);
Prj := In_Tree.Projects;
while Prj /= null loop
......@@ -1794,9 +1742,7 @@ package body Prj.Proc is
pragma Assert (Orig_Project /= No_Project,
"original project not found");
if No (Associative_Package_Of
(Current_Item, From_Project_Node_Tree))
then
if No (Associative_Package_Of (Current_Item, Node_Tree)) then
Orig_Array := Orig_Project.Decl.Arrays;
else
......@@ -1805,9 +1751,7 @@ package body Prj.Proc is
Orig_Package_Name :=
Name_Of
(Associative_Package_Of
(Current_Item, From_Project_Node_Tree),
From_Project_Node_Tree);
(Associative_Package_Of (Current_Item, Node_Tree), Node_Tree);
Orig_Package := Orig_Project.Decl.Packages;
pragma Assert (Orig_Package /= No_Package,
......@@ -1816,36 +1760,31 @@ package body Prj.Proc is
while In_Tree.Packages.Table
(Orig_Package).Name /= Orig_Package_Name
loop
Orig_Package := In_Tree.Packages.Table
(Orig_Package).Next;
Orig_Package := In_Tree.Packages.Table (Orig_Package).Next;
pragma Assert (Orig_Package /= No_Package,
"original package not found");
end loop;
Orig_Array :=
In_Tree.Packages.Table (Orig_Package).Decl.Arrays;
Orig_Array := In_Tree.Packages.Table (Orig_Package).Decl.Arrays;
end if;
-- Now look for the array
while Orig_Array /= No_Array
and then In_Tree.Arrays.Table (Orig_Array).Name /=
Current_Item_Name
and then In_Tree.Arrays.Table (Orig_Array).Name /= Current_Item_Name
loop
Orig_Array := In_Tree.Arrays.Table
(Orig_Array).Next;
Orig_Array := In_Tree.Arrays.Table (Orig_Array).Next;
end loop;
if Orig_Array = No_Array then
Error_Msg
(Flags,
"associative array value not found",
Location_Of (Current_Item, From_Project_Node_Tree),
Location_Of (Current_Item, Node_Tree),
Project);
else
Orig_Element :=
In_Tree.Arrays.Table (Orig_Array).Value;
Orig_Element := In_Tree.Arrays.Table (Orig_Array).Value;
-- Copy each array element
......@@ -1865,18 +1804,15 @@ package body Prj.Proc is
(In_Tree.Array_Elements);
New_Element := Array_Element_Table.Last
(In_Tree.Array_Elements);
In_Tree.Arrays.Table
(New_Array).Value := New_Element;
In_Tree.Arrays.Table (New_Array).Value := New_Element;
Next_Element := No_Array_Element;
-- Otherwise, the new element is the first
else
New_Element := In_Tree.Arrays.
Table (New_Array).Value;
New_Element := In_Tree.Arrays. Table (New_Array).Value;
Next_Element :=
In_Tree.Array_Elements.Table
(New_Element).Next;
In_Tree.Array_Elements.Table (New_Element).Next;
end if;
-- Otherwise, reuse an existing element, or create
......@@ -1884,38 +1820,33 @@ package body Prj.Proc is
else
Next_Element :=
In_Tree.Array_Elements.Table
(Prev_Element).Next;
In_Tree.Array_Elements.Table (Prev_Element).Next;
if Next_Element = No_Array_Element then
Array_Element_Table.Increment_Last
(In_Tree.Array_Elements);
New_Element :=
Array_Element_Table.Last
(In_Tree.Array_Elements);
In_Tree.Array_Elements.Table
(Prev_Element).Next := New_Element;
Array_Element_Table.Last (In_Tree.Array_Elements);
In_Tree.Array_Elements.Table (Prev_Element).Next :=
New_Element;
else
New_Element := Next_Element;
Next_Element :=
In_Tree.Array_Elements.Table
(New_Element).Next;
In_Tree.Array_Elements.Table (New_Element).Next;
end if;
end if;
-- Copy the value of the element
In_Tree.Array_Elements.Table
(New_Element) :=
In_Tree.Array_Elements.Table (New_Element) :=
In_Tree.Array_Elements.Table (Orig_Element);
In_Tree.Array_Elements.Table
(New_Element).Value.Project := Project;
In_Tree.Array_Elements.Table (New_Element).Value.Project :=
Project;
-- Adjust the Next link
In_Tree.Array_Elements.Table
(New_Element).Next := Next_Element;
In_Tree.Array_Elements.Table (New_Element).Next := Next_Element;
-- Adjust the previous id for the next element
......@@ -1924,204 +1855,59 @@ package body Prj.Proc is
-- Go to the next element in the original array
Orig_Element :=
In_Tree.Array_Elements.Table
(Orig_Element).Next;
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.
In_Tree.Array_Elements.Table
(New_Element).Next := No_Array_Element;
In_Tree.Array_Elements.Table (New_Element).Next :=
No_Array_Element;
end if;
end;
-- Declarations other that full associative arrays
end Process_Associative_Array;
else
declare
New_Value : Variable_Value :=
Expression
(Project => Project,
In_Tree => In_Tree,
Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Pkg => Pkg,
First_Term =>
Tree.First_Term
(Expression_Of
(Current_Item, From_Project_Node_Tree),
From_Project_Node_Tree),
Kind =>
Expression_Kind_Of
(Current_Item, From_Project_Node_Tree));
-- The expression value
The_Variable : Variable_Id := No_Variable;
----------------------------------------------
-- Process_Expression_For_Associative_Array --
----------------------------------------------
procedure Process_Expression_For_Associative_Array
(Current_Item : Project_Node_Id;
New_Value : Variable_Value)
is
Current_Item_Name : constant Name_Id :=
Name_Of
(Current_Item,
From_Project_Node_Tree);
Name_Of (Current_Item, Node_Tree);
Current_Location : constant Source_Ptr :=
Location_Of
(Current_Item,
From_Project_Node_Tree);
begin
-- Process a typed variable declaration
if Kind_Of (Current_Item, From_Project_Node_Tree) =
N_Typed_Variable_Declaration
then
Check_Or_Set_Typed_Variable
(Value => New_Value,
Declaration => Current_Item);
end if;
-- Comment here ???
if Kind_Of (Current_Item, From_Project_Node_Tree) /=
N_Attribute_Declaration
or else
Associative_Array_Index_Of
(Current_Item, From_Project_Node_Tree) = No_Name
then
-- Case of a variable declaration or of a not
-- associative array attribute.
-- First, find the list where to find the variable
-- or attribute.
if Kind_Of (Current_Item, From_Project_Node_Tree) =
N_Attribute_Declaration
then
if Pkg /= No_Package then
The_Variable :=
In_Tree.Packages.Table
(Pkg).Decl.Attributes;
else
The_Variable := Project.Decl.Attributes;
end if;
else
if Pkg /= No_Package then
The_Variable :=
In_Tree.Packages.Table
(Pkg).Decl.Variables;
else
The_Variable := Project.Decl.Variables;
end if;
end if;
-- Loop through the list, to find if it has already
-- been declared.
while The_Variable /= No_Variable
and then
In_Tree.Variable_Elements.Table
(The_Variable).Name /= Current_Item_Name
loop
The_Variable :=
In_Tree.Variable_Elements.Table
(The_Variable).Next;
end loop;
-- If it has not been declared, create a new entry
-- in the list.
if The_Variable = No_Variable then
-- All single string attribute should already have
-- been declared with a default empty string value.
pragma Assert
(Kind_Of (Current_Item, From_Project_Node_Tree) /=
N_Attribute_Declaration,
"illegal attribute declaration for "
& Get_Name_String (Current_Item_Name));
Variable_Element_Table.Increment_Last
(In_Tree.Variable_Elements);
The_Variable := Variable_Element_Table.Last
(In_Tree.Variable_Elements);
-- Put the new variable in the appropriate list
if Pkg /= No_Package then
In_Tree.Variable_Elements.Table (The_Variable) :=
(Next =>
In_Tree.Packages.Table
(Pkg).Decl.Variables,
Name => Current_Item_Name,
Value => New_Value);
In_Tree.Packages.Table
(Pkg).Decl.Variables := The_Variable;
else
In_Tree.Variable_Elements.Table (The_Variable) :=
(Next => Project.Decl.Variables,
Name => Current_Item_Name,
Value => New_Value);
Project.Decl.Variables := The_Variable;
end if;
-- If the variable/attribute has already been
-- declared, just change the value.
else
In_Tree.Variable_Elements.Table
(The_Variable).Value := New_Value;
end if;
-- Associative array attribute
Location_Of (Current_Item, Node_Tree);
else
declare
Index_Name : Name_Id :=
Associative_Array_Index_Of
(Current_Item,
From_Project_Node_Tree);
Associative_Array_Index_Of (Current_Item, Node_Tree);
Source_Index : constant Int :=
Source_Index_Of
(Current_Item,
From_Project_Node_Tree);
Source_Index_Of (Current_Item, Node_Tree);
The_Array : Array_Id;
The_Array_Element : Array_Element_Id :=
No_Array_Element;
The_Array_Element : Array_Element_Id := No_Array_Element;
begin
if Index_Name /= All_Other_Names then
Index_Name := Get_Attribute_Index
(From_Project_Node_Tree,
(Node_Tree,
Current_Item,
Associative_Array_Index_Of
(Current_Item, From_Project_Node_Tree));
Associative_Array_Index_Of (Current_Item, Node_Tree));
end if;
-- Look for the array in the appropriate list
if Pkg /= No_Package then
The_Array :=
In_Tree.Packages.Table (Pkg).Decl.Arrays;
The_Array := In_Tree.Packages.Table (Pkg).Decl.Arrays;
else
The_Array :=
Project.Decl.Arrays;
The_Array := Project.Decl.Arrays;
end if;
while
The_Array /= No_Array
and then
In_Tree.Arrays.Table (The_Array).Name /=
Current_Item_Name
while The_Array /= No_Array
and then In_Tree.Arrays.Table (The_Array).Name /= Current_Item_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 cannot be found, create a new entry
......@@ -2138,11 +1924,9 @@ package body Prj.Proc is
(Name => Current_Item_Name,
Location => Current_Location,
Value => No_Array_Element,
Next => In_Tree.Packages.Table
(Pkg).Decl.Arrays);
Next => In_Tree.Packages.Table (Pkg).Decl.Arrays);
In_Tree.Packages.Table (Pkg).Decl.Arrays :=
The_Array;
In_Tree.Packages.Table (Pkg).Decl.Arrays := The_Array;
else
In_Tree.Arrays.Table (The_Array) :=
......@@ -2158,8 +1942,7 @@ package body Prj.Proc is
-- head of the element list.
else
The_Array_Element :=
In_Tree.Arrays.Table (The_Array).Value;
The_Array_Element := In_Tree.Arrays.Table (The_Array).Value;
end if;
-- Look in the list, if any, to find an element
......@@ -2167,15 +1950,14 @@ package body Prj.Proc is
while The_Array_Element /= No_Array_Element
and then
(In_Tree.Array_Elements.Table
(The_Array_Element).Index /= Index_Name
(In_Tree.Array_Elements.Table (The_Array_Element).Index /=
Index_Name
or else
In_Tree.Array_Elements.Table
(The_Array_Element).Src_Index /= Source_Index)
In_Tree.Array_Elements.Table (The_Array_Element).Src_Index /=
Source_Index)
loop
The_Array_Element :=
In_Tree.Array_Elements.Table
(The_Array_Element).Next;
In_Tree.Array_Elements.Table (The_Array_Element).Next;
end loop;
-- If no such element were found, create a new one
......@@ -2183,78 +1965,207 @@ package body Prj.Proc is
-- proper value.
if The_Array_Element = No_Array_Element then
Array_Element_Table.Increment_Last
(In_Tree.Array_Elements);
Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
The_Array_Element :=
Array_Element_Table.Last
(In_Tree.Array_Elements);
Array_Element_Table.Last (In_Tree.Array_Elements);
In_Tree.Array_Elements.Table
(The_Array_Element) :=
(Index => Index_Name,
Src_Index => Source_Index,
Index_Case_Sensitive =>
not Case_Insensitive
(Current_Item, From_Project_Node_Tree),
not Case_Insensitive (Current_Item, Node_Tree),
Value => New_Value,
Next =>
In_Tree.Arrays.Table (The_Array).Value);
Next => In_Tree.Arrays.Table (The_Array).Value);
In_Tree.Arrays.Table (The_Array).Value :=
The_Array_Element;
In_Tree.Arrays.Table (The_Array).Value := The_Array_Element;
-- An element with the same index already exists,
-- just replace its value with the new one.
else
In_Tree.Array_Elements.Table
(The_Array_Element).Value := New_Value;
end if;
end;
In_Tree.Array_Elements.Table (The_Array_Element).Value :=
New_Value;
end if;
end;
end if;
when N_Case_Construction =>
declare
The_Project : Project_Id := Project;
-- The id of the project of the case variable
end Process_Expression_For_Associative_Array;
The_Package : Package_Id := Pkg;
-- The id of the package, if any, of the case variable
--------------------------------------
-- Process_Expression_Variable_Decl --
--------------------------------------
The_Variable : Variable_Value := Nil_Variable_Value;
-- The case variable
procedure Process_Expression_Variable_Decl
(Current_Item : Project_Node_Id;
New_Value : Variable_Value)
is
Current_Item_Name : constant Name_Id :=
Name_Of (Current_Item, Node_Tree);
The_Variable : Variable_Id := No_Variable;
Case_Value : Name_Id := No_Name;
-- The case variable value
begin
-- First, find the list where to find the variable or attribute.
Case_Item : Project_Node_Id := Empty_Node;
Choice_String : Project_Node_Id := Empty_Node;
Decl_Item : Project_Node_Id := Empty_Node;
if Kind_Of (Current_Item, Node_Tree) =
N_Attribute_Declaration
then
if Pkg /= No_Package then
The_Variable := In_Tree.Packages.Table (Pkg).Decl.Attributes;
else
The_Variable := Project.Decl.Attributes;
end if;
begin
declare
Variable_Node : constant Project_Node_Id :=
Case_Variable_Reference_Of
(Current_Item,
From_Project_Node_Tree);
else
if Pkg /= No_Package then
The_Variable := In_Tree.Packages.Table (Pkg).Decl.Variables;
else
The_Variable := Project.Decl.Variables;
end if;
end if;
Var_Id : Variable_Id := No_Variable;
Name : Name_Id := No_Name;
-- Loop through the list, to find if it has already been declared.
while The_Variable /= No_Variable
and then In_Tree.Variable_Elements.Table (The_Variable).Name /=
Current_Item_Name
loop
The_Variable :=
In_Tree.Variable_Elements.Table (The_Variable).Next;
end loop;
-- If it has not been declared, create a new entry
-- in the list.
if The_Variable = No_Variable then
-- All single string attribute should already have
-- been declared with a default empty string value.
pragma Assert
(Kind_Of (Current_Item, Node_Tree) /=
N_Attribute_Declaration,
"illegal attribute declaration for "
& Get_Name_String (Current_Item_Name));
Variable_Element_Table.Increment_Last (In_Tree.Variable_Elements);
The_Variable := Variable_Element_Table.Last
(In_Tree.Variable_Elements);
-- Put the new variable in the appropriate list
if Pkg /= No_Package then
In_Tree.Variable_Elements.Table (The_Variable) :=
(Next => In_Tree.Packages.Table (Pkg).Decl.Variables,
Name => Current_Item_Name,
Value => New_Value);
In_Tree.Packages.Table (Pkg).Decl.Variables := The_Variable;
else
In_Tree.Variable_Elements.Table (The_Variable) :=
(Next => Project.Decl.Variables,
Name => Current_Item_Name,
Value => New_Value);
Project.Decl.Variables := The_Variable;
end if;
-- If the variable/attribute has already been
-- declared, just change the value.
else
In_Tree.Variable_Elements.Table (The_Variable).Value := New_Value;
end if;
end Process_Expression_Variable_Decl;
------------------------
-- Process_Expression --
------------------------
procedure Process_Expression
(Current : Project_Node_Id)
is
New_Value : Variable_Value :=
Expression
(Project => Project,
In_Tree => In_Tree,
Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => Node_Tree,
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
Check_Or_Set_Typed_Variable (New_Value, Current);
end if;
if Kind_Of (Current, Node_Tree) /= N_Attribute_Declaration
or else Associative_Array_Index_Of (Current, Node_Tree) = No_Name
then
Process_Expression_Variable_Decl (Current, New_Value);
else
Process_Expression_For_Associative_Array (Current, New_Value);
end if;
end Process_Expression;
-----------------------------------
-- Process_Attribute_Declaration --
-----------------------------------
procedure Process_Attribute_Declaration (Current : Project_Node_Id) is
begin
if Expression_Of (Current, Node_Tree) = Empty_Node then
Process_Associative_Array (Current);
else
Process_Expression (Current);
end if;
end Process_Attribute_Declaration;
-------------------------------
-- Process_Case_Construction --
-------------------------------
procedure Process_Case_Construction
(Current_Item : Project_Node_Id)
is
The_Project : Project_Id := Project;
-- The id of the project of the case variable
The_Package : Package_Id := Pkg;
-- The id of the package, if any, of the case variable
The_Variable : Variable_Value := Nil_Variable_Value;
-- The case variable
Case_Value : Name_Id := No_Name;
-- The case variable value
Case_Item : Project_Node_Id := Empty_Node;
Choice_String : Project_Node_Id := Empty_Node;
Decl_Item : Project_Node_Id := Empty_Node;
begin
declare
Variable_Node : constant Project_Node_Id :=
Case_Variable_Reference_Of
(Current_Item,
Node_Tree);
Var_Id : Variable_Id := No_Variable;
Name : Name_Id := No_Name;
begin
-- If a project was specified for the case variable,
-- get its id.
if Present (Project_Node_Of
(Variable_Node, From_Project_Node_Tree))
then
if Present (Project_Node_Of (Variable_Node, Node_Tree)) then
Name :=
Name_Of
(Project_Node_Of
(Variable_Node, From_Project_Node_Tree),
From_Project_Node_Tree);
(Project_Node_Of (Variable_Node, Node_Tree), Node_Tree);
The_Project :=
Imported_Or_Extended_Project_From (Project, Name);
end if;
......@@ -2262,35 +2173,25 @@ package body Prj.Proc is
-- If a package were specified for the case variable,
-- get its id.
if Present (Package_Node_Of
(Variable_Node, From_Project_Node_Tree))
then
if Present (Package_Node_Of (Variable_Node, Node_Tree)) then
Name :=
Name_Of
(Package_Node_Of
(Variable_Node, From_Project_Node_Tree),
From_Project_Node_Tree);
The_Package :=
Package_From (The_Project, In_Tree, Name);
(Package_Node_Of (Variable_Node, Node_Tree), Node_Tree);
The_Package := Package_From (The_Project, In_Tree, Name);
end if;
Name := Name_Of (Variable_Node, From_Project_Node_Tree);
Name := Name_Of (Variable_Node, Node_Tree);
-- 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, From_Project_Node_Tree);
Var_Id := In_Tree.Packages.Table (The_Package).Decl.Variables;
Name := Name_Of (Variable_Node, Node_Tree);
while Var_Id /= No_Variable
and then
In_Tree.Variable_Elements.Table
(Var_Id).Name /= Name
and then In_Tree.Variable_Elements.Table (Var_Id).Name /= Name
loop
Var_Id := In_Tree.Variable_Elements.
Table (Var_Id).Next;
Var_Id := In_Tree.Variable_Elements.Table (Var_Id).Next;
end loop;
end if;
......@@ -2298,18 +2199,13 @@ package body Prj.Proc is
-- package, look at the project level.
if Var_Id = No_Variable
and then
No (Package_Node_Of
(Variable_Node, From_Project_Node_Tree))
and then No (Package_Node_Of (Variable_Node, Node_Tree))
then
Var_Id := The_Project.Decl.Variables;
while Var_Id /= No_Variable
and then
In_Tree.Variable_Elements.Table
(Var_Id).Name /= Name
and then In_Tree.Variable_Elements.Table (Var_Id).Name /= Name
loop
Var_Id := In_Tree.Variable_Elements.
Table (Var_Id).Next;
Var_Id := In_Tree.Variable_Elements.Table (Var_Id).Next;
end loop;
end if;
......@@ -2318,24 +2214,21 @@ package body Prj.Proc is
-- Should never happen, because this has already been
-- checked during parsing.
Write_Line ("variable """ &
Get_Name_String (Name) &
""" not found");
Write_Line
("variable """ & Get_Name_String (Name) & """ not found");
raise Program_Error;
end if;
-- Get the case variable
The_Variable := In_Tree.Variable_Elements.
Table (Var_Id).Value;
The_Variable := In_Tree.Variable_Elements. Table (Var_Id).Value;
if The_Variable.Kind /= Single then
-- Should never happen, because this has already been
-- checked during parsing.
Write_Line ("variable""" &
Get_Name_String (Name) &
Write_Line ("variable""" & Get_Name_String (Name) &
""" is not a single string variable");
raise Program_Error;
end if;
......@@ -2346,20 +2239,17 @@ package body Prj.Proc is
-- Now look into all the case items of the case construction
Case_Item :=
First_Case_Item_Of (Current_Item, From_Project_Node_Tree);
Case_Item := First_Case_Item_Of (Current_Item, Node_Tree);
Case_Item_Loop :
while Present (Case_Item) loop
Choice_String :=
First_Choice_Of (Case_Item, From_Project_Node_Tree);
Choice_String := First_Choice_Of (Case_Item, Node_Tree);
-- 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, From_Project_Node_Tree);
Decl_Item := First_Declarative_Item_Of (Case_Item, Node_Tree);
exit Case_Item_Loop;
end if;
......@@ -2367,23 +2257,16 @@ package body Prj.Proc is
Choice_Loop :
while Present (Choice_String) loop
if Case_Value =
String_Value_Of
(Choice_String, From_Project_Node_Tree)
then
if Case_Value = String_Value_Of (Choice_String, Node_Tree) then
Decl_Item :=
First_Declarative_Item_Of
(Case_Item, From_Project_Node_Tree);
First_Declarative_Item_Of (Case_Item, Node_Tree);
exit Case_Item_Loop;
end if;
Choice_String :=
Next_Literal_String
(Choice_String, From_Project_Node_Tree);
Choice_String := Next_Literal_String (Choice_String, Node_Tree);
end loop Choice_Loop;
Case_Item :=
Next_Case_Item (Case_Item, From_Project_Node_Tree);
Case_Item := Next_Case_Item (Case_Item, Node_Tree);
end loop Case_Item_Loop;
-- If there is an alternative, then we process it
......@@ -2394,20 +2277,44 @@ package body Prj.Proc is
In_Tree => In_Tree,
Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Node_Tree => Node_Tree,
Pkg => Pkg,
Item => Decl_Item);
end if;
end;
end Process_Case_Construction;
when others =>
-- Local variables
-- Should never happen
Current, Decl : Project_Node_Id;
Kind : Project_Node_Kind;
-- Start of processing for Process_Declarative_Items
begin
Decl := Item;
while Present (Decl) loop
Current := Current_Item_Node (Decl, Node_Tree);
Decl := Next_Declarative_Item (Decl, Node_Tree);
Kind := Kind_Of (Current, Node_Tree);
case Kind is
when N_Package_Declaration =>
Process_Package_Declaration (Current);
when N_String_Type_Declaration =>
-- There is nothing to process
null;
when N_Attribute_Declaration |
N_Typed_Variable_Declaration |
N_Variable_Declaration =>
Process_Attribute_Declaration (Current);
Write_Line ("Illegal declarative item: " &
Project_Node_Kind'Image
(Kind_Of
(Current_Item, From_Project_Node_Tree)));
when N_Case_Construction =>
Process_Case_Construction (Current);
when others =>
Write_Line ("Illegal declarative item: " & Kind'Img);
raise Program_Error;
end case;
end loop;
......@@ -2439,6 +2346,8 @@ package body Prj.Proc is
-- And process the main project and all of the projects it depends on,
-- recursively.
Debug_Increase_Indent ("Process tree, phase 1");
Recursive_Process
(Project => Project,
In_Tree => In_Tree,
......@@ -2451,6 +2360,11 @@ package body Prj.Proc is
Total_Errors_Detected = 0
and then
(Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0);
if Current_Verbosity = High then
Debug_Decrease_Indent ("Done Process tree, phase 1, Success="
& Success'Img);
end if;
end Process_Project_Tree_Phase_1;
----------------------------------
......@@ -2475,6 +2389,8 @@ package body Prj.Proc is
begin
Success := True;
Debug_Increase_Indent ("Process tree, phase 2");
if Project /= No_Project then
Check (In_Tree, Project, From_Project_Node_Tree, Flags);
end if;
......@@ -2554,6 +2470,8 @@ package body Prj.Proc is
end loop;
end if;
Debug_Decrease_Indent ("Done Process tree, phase 2");
Success :=
Total_Errors_Detected = 0
and then
......@@ -2580,6 +2498,16 @@ package body Prj.Proc is
-- only projects imported through a standard "with" are processed.
-- 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.
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_Imported_Projects --
-------------------------------
......@@ -2596,6 +2524,7 @@ package body Prj.Proc is
With_Clause :=
First_With_Clause_Of
(From_Project_Node, From_Project_Node_Tree);
while Present (With_Clause) loop
Proj_Node :=
Non_Limited_Project_Node_Of
......@@ -2637,6 +2566,158 @@ package body Prj.Proc is
end loop;
end Process_Imported_Projects;
---------------------------------
-- Process_Aggregated_Projects --
---------------------------------
procedure Process_Aggregated_Projects is
List : Aggregated_Project_List;
Loaded_Tree : Prj.Tree.Project_Node_Id;
Success : Boolean := True;
begin
if Project.Qualifier /= Aggregate then
return;
end if;
Debug_Increase_Indent ("Process_Aggregated_Projects", Project.Name);
Prj.Nmsc.Process_Aggregated_Projects
(Tree => In_Tree,
Project => Project,
Node_Tree => From_Project_Node_Tree,
Flags => Flags);
List := Project.Aggregated_Projects;
while Success and then List /= null loop
Prj.Part.Parse
(In_Tree => From_Project_Node_Tree,
Project => Loaded_Tree,
Project_File_Name => Get_Name_String (List.Path),
Errout_Handling => Prj.Part.Never_Finalize,
Current_Directory => Get_Name_String (Project.Directory.Name),
Is_Config_File => False,
Flags => Flags);
Success := not Prj.Tree.No (Loaded_Tree);
if Success then
Recursive_Process
(In_Tree => In_Tree,
Project => List.Project,
Flags => Flags,
From_Project_Node => Loaded_Tree,
From_Project_Node_Tree => From_Project_Node_Tree,
Extended_By => No_Project);
else
Debug_Output ("Failed to parse", Name_Id (List.Path));
end if;
List := List.Next;
end loop;
Debug_Decrease_Indent ("Done Process_Aggregated_Projects");
end Process_Aggregated_Projects;
------------------------------
-- Process_Extended_Project --
------------------------------
procedure Process_Extended_Project is
Extended_Pkg : Package_Id;
Current_Pkg : Package_Id;
Element : Package_Element;
First : constant Package_Id := Project.Decl.Packages;
Attribute1 : Variable_Id;
Attribute2 : Variable_Id;
Attr_Value1 : Variable;
Attr_Value2 : Variable;
begin
Extended_Pkg := Project.Extends.Decl.Packages;
while Extended_Pkg /= No_Package loop
Element := In_Tree.Packages.Table (Extended_Pkg);
Current_Pkg := First;
while Current_Pkg /= No_Package
and then In_Tree.Packages.Table (Current_Pkg).Name /=
Element.Name
loop
Current_Pkg :=
In_Tree.Packages.Table (Current_Pkg).Next;
end loop;
if Current_Pkg = No_Package then
Package_Table.Increment_Last
(In_Tree.Packages);
Current_Pkg := Package_Table.Last (In_Tree.Packages);
In_Tree.Packages.Table (Current_Pkg) :=
(Name => Element.Name,
Decl => No_Declarations,
Parent => No_Package,
Next => Project.Decl.Packages);
Project.Decl.Packages := Current_Pkg;
Copy_Package_Declarations
(From => Element.Decl,
To =>
In_Tree.Packages.Table (Current_Pkg).Decl,
New_Loc => No_Location,
Restricted => True,
In_Tree => In_Tree);
end if;
Extended_Pkg := Element.Next;
end loop;
-- 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);
exit when Attr_Value1.Name = Snames.Name_Languages;
Attribute1 := Attr_Value1.Next;
end loop;
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.
Attribute2 := Project.Extends.Decl.Attributes;
while Attribute2 /= No_Variable loop
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.
if Attribute1 = No_Variable then
Variable_Element_Table.Increment_Last
(In_Tree.Variable_Elements);
Attribute1 := Variable_Element_Table.Last
(In_Tree.Variable_Elements);
Attr_Value1.Next := Project.Decl.Attributes;
Project.Decl.Attributes := Attribute1;
end if;
Attr_Value1.Name := Snames.Name_Languages;
Attr_Value1.Value := Attr_Value2.Value;
In_Tree.Variable_Elements.Table
(Attribute1) := Attr_Value1;
end if;
end if;
end Process_Extended_Project;
-- Start of processing for Recursive_Process
begin
......@@ -2672,7 +2753,10 @@ package body Prj.Proc is
return;
end if;
Project := new Project_Data'(Empty_Project);
Project := new Project_Data'
(Empty_Project
(Project_Qualifier_Of
(From_Project_Node, From_Project_Node_Tree)));
In_Tree.Projects := new Project_List_Element'
(Project => Project,
Next => In_Tree.Projects);
......@@ -2681,9 +2765,6 @@ package body Prj.Proc is
Project.Name := Name;
Project.Display_Name := Name_Node.Display_Name;
Project.Qualifier :=
Project_Qualifier_Of (From_Project_Node, From_Project_Node_Tree);
Get_Name_String (Name);
-- If name starts with the virtual prefix, flag the project as
......@@ -2743,117 +2824,21 @@ package body Prj.Proc is
In_Tree => In_Tree,
Flags => Flags,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Node_Tree => From_Project_Node_Tree,
Pkg => No_Package,
Item => First_Declarative_Item_Of
(Declaration_Node,
From_Project_Node_Tree));
-- If it is an extending 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.
if Project.Extends /= No_Project then
declare
Extended_Pkg : Package_Id;
Current_Pkg : Package_Id;
Element : Package_Element;
First : constant Package_Id :=
Project.Decl.Packages;
Attribute1 : Variable_Id;
Attribute2 : Variable_Id;
Attr_Value1 : Variable;
Attr_Value2 : Variable;
begin
Extended_Pkg := Project.Extends.Decl.Packages;
while Extended_Pkg /= No_Package loop
Element := In_Tree.Packages.Table (Extended_Pkg);
Current_Pkg := First;
while Current_Pkg /= No_Package
and then In_Tree.Packages.Table (Current_Pkg).Name /=
Element.Name
loop
Current_Pkg :=
In_Tree.Packages.Table (Current_Pkg).Next;
end loop;
if Current_Pkg = No_Package then
Package_Table.Increment_Last
(In_Tree.Packages);
Current_Pkg := Package_Table.Last (In_Tree.Packages);
In_Tree.Packages.Table (Current_Pkg) :=
(Name => Element.Name,
Decl => No_Declarations,
Parent => No_Package,
Next => Project.Decl.Packages);
Project.Decl.Packages := Current_Pkg;
Copy_Package_Declarations
(From => Element.Decl,
To =>
In_Tree.Packages.Table (Current_Pkg).Decl,
New_Loc => No_Location,
Restricted => True,
In_Tree => In_Tree);
Process_Extended_Project;
end if;
Extended_Pkg := Element.Next;
end loop;
-- 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);
exit when Attr_Value1.Name = Snames.Name_Languages;
Attribute1 := Attr_Value1.Next;
end loop;
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.
Attribute2 := Project.Extends.Decl.Attributes;
while Attribute2 /= No_Variable loop
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.
if Attribute1 = No_Variable then
Variable_Element_Table.Increment_Last
(In_Tree.Variable_Elements);
Attribute1 := Variable_Element_Table.Last
(In_Tree.Variable_Elements);
Attr_Value1.Next := Project.Decl.Attributes;
Project.Decl.Attributes := Attribute1;
end if;
Process_Imported_Projects (Imported, Limited_With => True);
Attr_Value1.Name := Snames.Name_Languages;
Attr_Value1.Value := Attr_Value2.Value;
In_Tree.Variable_Elements.Table
(Attribute1) := Attr_Value1;
if Err_Vars.Total_Errors_Detected = 0 then
Process_Aggregated_Projects;
end if;
end if;
end;
end if;
Process_Imported_Projects (Imported, Limited_With => True);
end;
end if;
end Recursive_Process;
......
gcc/ada/prj.adb
......@@ -62,55 +62,6 @@ package body Prj is
All_Upper_Case => All_Upper_Case_Image'Access,
Mixed_Case => Mixed_Case_Image'Access);
Project_Empty : constant Project_Data :=
(Qualifier => Unspecified,
Externally_Built => False,
Config => Default_Project_Config,
Name => No_Name,
Display_Name => No_Name,
Path => No_Path_Information,
Virtual => False,
Location => No_Location,
Mains => Nil_String,
Directory => No_Path_Information,
Library => False,
Library_Dir => No_Path_Information,
Library_Src_Dir => No_Path_Information,
Library_ALI_Dir => No_Path_Information,
Library_Name => No_Name,
Library_Kind => Static,
Lib_Internal_Name => No_Name,
Standalone_Library => False,
Lib_Interface_ALIs => Nil_String,
Lib_Auto_Init => False,
Libgnarl_Needed => Unknown,
Symbol_Data => No_Symbols,
Interfaces_Defined => False,
Source_Dirs => Nil_String,
Source_Dir_Ranks => No_Number_List,
Object_Directory => No_Path_Information,
Library_TS => Empty_Time_Stamp,
Exec_Directory => No_Path_Information,
Extends => No_Project,
Extended_By => No_Project,
Languages => No_Language_Index,
Decl => No_Declarations,
Imported_Projects => null,
Include_Path_File => No_Path,
All_Imported_Projects => null,
Ada_Include_Path => null,
Ada_Objects_Path => null,
Objects_Path => null,
Objects_Path_File_With_Libs => No_Path,
Objects_Path_File_Without_Libs => No_Path,
Config_File_Name => No_Path,
Config_File_Temp => False,
Config_Checked => False,
Need_To_Build_Lib => False,
Has_Multi_Unit_Sources => False,
Depth => 0,
Unkept_Comments => False);
procedure Free (Project : in out Project_Id);
-- Free memory allocated for Project
......@@ -270,10 +221,20 @@ package body Prj is
-- Empty_Project --
-------------------
function Empty_Project return Project_Data is
function Empty_Project
(Qualifier : Project_Qualifier) return Project_Data is
begin
Prj.Initialize (Tree => No_Project_Tree);
return Project_Empty;
declare
Data : Project_Data (Qualifier => Qualifier);
begin
-- Only the fields for which no default value could be provided in
-- prj.ads are initialized below
Data.Config := Default_Project_Config;
return Data;
end;
end Empty_Project;
------------------
......@@ -440,6 +401,7 @@ package body Prj is
procedure For_Every_Project_Imported
(By : Project_Id;
With_State : in out State;
Include_Aggregated : Boolean := True;
Imported_First : Boolean := False)
is
use Project_Boolean_Htable;
......@@ -455,6 +417,7 @@ package body Prj is
procedure Recursive_Check (Project : Project_Id) is
List : Project_List;
Agg : Aggregated_Project_List;
begin
if not Get (Seen, Project) then
......@@ -464,13 +427,13 @@ package body Prj is
Action (Project, With_State);
end if;
-- Visited all extended projects
-- Visit all extended projects
if Project.Extends /= No_Project then
Recursive_Check (Project.Extends);
end if;
-- Visited all imported projects
-- Visit all imported projects
List := Project.Imported_Projects;
while List /= null loop
......@@ -478,6 +441,19 @@ package body Prj is
List := List.Next;
end loop;
-- Visit all aggregated projects
if Include_Aggregated
and then Project.Qualifier = Aggregate
then
Agg := Project.Aggregated_Projects;
while Agg /= null loop
pragma Assert (Agg.Project /= No_Project);
Recursive_Check (Agg.Project);
Agg := Agg.Next;
end loop;
end if;
if Imported_First then
Action (Project, With_State);
end if;
......@@ -729,6 +705,35 @@ package body Prj is
-- Free --
----------
procedure Free (List : in out Aggregated_Project_List) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Aggregated_Project, Aggregated_Project_List);
Tmp : Aggregated_Project_List;
begin
while List /= null loop
Tmp := List.Next;
Unchecked_Free (List);
List := Tmp;
end loop;
end Free;
----------------------------
-- Add_Aggregated_Project --
----------------------------
procedure Add_Aggregated_Project
(Project : Project_Id; Path : Path_Name_Type) is
begin
Project.Aggregated_Projects := new Aggregated_Project'
(Path => Path,
Project => No_Project,
Next => Project.Aggregated_Projects);
end Add_Aggregated_Project;
----------
-- Free --
----------
procedure Free (Project : in out Project_Id) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Project_Data, Project_Id);
......@@ -742,6 +747,14 @@ package body Prj is
Free_List (Project.All_Imported_Projects, Free_Project => False);
Free_List (Project.Languages);
case Project.Qualifier is
when Aggregate =>
Free (Project.Aggregated_Projects);
when others =>
null;
end case;
Unchecked_Free (Project);
end if;
end Free;
......
gcc/ada/prj.ads
......@@ -1086,13 +1086,34 @@ package Prj is
Lib_Maj_Min_Id_Supported => False,
Auto_Init_Supported => False);
-- The following record describes a project file representation
-------------------------
-- Aggregated projects --
-------------------------
type Aggregated_Project;
type Aggregated_Project_List is access all Aggregated_Project;
type Aggregated_Project is record
Path : Path_Name_Type;
Project : Project_Id;
Next : Aggregated_Project_List;
end record;
-- Note that it is not specified if the path names of directories (source,
-- object, library or exec directories) end with or without a directory
-- separator.
procedure Free (List : in out Aggregated_Project_List);
-- Free the memory used for List
procedure Add_Aggregated_Project
(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
-- Prj.Proc.Process will then automatically process the aggregated projects
------------------
-- Project_Data --
------------------
-- The following record describes a project file representation
type Project_Data is record
type Project_Data (Qualifier : Project_Qualifier := Unspecified) is record
-------------
-- General --
......@@ -1104,9 +1125,6 @@ package Prj is
Display_Name : Name_Id := No_Name;
-- The name of the project with the spelling of its declaration
Qualifier : Project_Qualifier := Unspecified;
-- The eventual qualifier for this project
Externally_Built : Boolean := False;
-- True if the project is externally built. In such case, the Project
-- Manager will not modify anything in this project.
......@@ -1152,10 +1170,10 @@ package Prj is
-- The declarations (variables, attributes and packages) of this project
-- file.
Imported_Projects : Project_List;
Imported_Projects : Project_List := null;
-- The list of all directly imported projects, if any
All_Imported_Projects : Project_List;
All_Imported_Projects : Project_List := null;
-- The list of all projects imported directly or indirectly, if any.
-- This does not include the project itself.
......@@ -1295,9 +1313,21 @@ package Prj is
-- True if there are comments in the project sources that cannot be kept
-- in the project tree.
-----------------------------
-- qualifier-specific data --
-----------------------------
-- The following fields are only valid for specific types of projects.
case Qualifier is
when Aggregate =>
Aggregated_Projects : Aggregated_Project_List := null;
when others =>
null;
end case;
end record;
function Empty_Project return Project_Data;
function Empty_Project (Qualifier : Project_Qualifier) return Project_Data;
-- Return the representation of an empty project
function Is_Extending
......@@ -1432,6 +1462,7 @@ package Prj is
procedure For_Every_Project_Imported
(By : Project_Id;
With_State : in out State;
Include_Aggregated : Boolean := True;
Imported_First : Boolean := False);
-- Call Action for each project imported directly or indirectly by project
-- By, as well as extended projects.
......@@ -1448,6 +1479,10 @@ package Prj is
--
-- With_State may be used by Action to choose a behavior or to report some
-- global result.
--
-- If Include_Aggregated is True, then an aggregate project will recurse
-- into the projects it aggregates. Otherwise, the latter are never
-- returned
function Extend_Name
(File : File_Name_Type;
......
gcc/ada/restrict.adb
......@@ -105,9 +105,9 @@ package body Restrict is
Check_Restriction (No_Elaboration_Code, N);
end Check_Elaboration_Code_Allowed;
------------------------------
-- Check_Formal_Restriction --
------------------------------
-----------------------------
-- Check_SPARK_Restriction --
-----------------------------
procedure Check_SPARK_Restriction
(Msg : String;
......@@ -139,7 +139,7 @@ package body Restrict is
end if;
end Check_SPARK_Restriction;
procedure Check_Formal_Restriction (Msg1, Msg2 : String; N : Node_Id) is
procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is
Msg_Issued : Boolean;
Save_Error_Msg_Sloc : Source_Ptr;
begin
......@@ -166,7 +166,7 @@ package body Restrict is
Error_Msg_F (Msg2, N);
end if;
end if;
end Check_Formal_Restriction;
end Check_SPARK_Restriction;
-----------------------------------------
-- Check_Implicit_Dynamic_Code_Allowed --
......
gcc/ada/restrict.ads
......@@ -265,8 +265,8 @@ package Restrict is
-- SPARK restriction is set, then an error is issued on N. Msg is appended
-- to the restriction failure message.
procedure Check_Formal_Restriction (Msg1, Msg2 : String; N : Node_Id);
-- Same as Check_Formal_Restriction except there is a continuation 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_Implicit_Dynamic_Code_Allowed (N : Node_Id);
......
gcc/ada/sem_attr.adb
......@@ -289,7 +289,7 @@ package body Sem_Attr is
-- Common processing for attributes Definite and Has_Discriminants.
-- Checks that prefix is generic indefinite formal type.
procedure Check_Formal_Restriction_On_Attribute;
procedure Check_SPARK_Restriction_On_Attribute;
-- Issue an error in formal mode because attribute N is allowed
procedure Check_Integer_Type;
......@@ -568,7 +568,7 @@ package body Sem_Attr is
-- Start of processing for Analyze_Access_Attribute
begin
Check_Formal_Restriction_On_Attribute;
Check_SPARK_Restriction_On_Attribute;
Check_E0;
if Nkind (P) = N_Character_Literal then
......@@ -1289,15 +1289,15 @@ package body Sem_Attr is
Check_E2;
end Check_Floating_Point_Type_2;
-------------------------------------------
-- Check_Formal_Restriction_On_Attribute --
-------------------------------------------
------------------------------------------
-- Check_SPARK_Restriction_On_Attribute --
------------------------------------------
procedure Check_Formal_Restriction_On_Attribute is
procedure Check_SPARK_Restriction_On_Attribute is
begin
Error_Msg_Name_1 := Aname;
Check_SPARK_Restriction ("attribute % is not allowed", P);
end Check_Formal_Restriction_On_Attribute;
end Check_SPARK_Restriction_On_Attribute;
------------------------
-- Check_Integer_Type --
......@@ -3266,7 +3266,7 @@ package body Sem_Attr is
when Attribute_Image => Image :
begin
Check_Formal_Restriction_On_Attribute;
Check_SPARK_Restriction_On_Attribute;
Check_Scalar_Type;
Set_Etype (N, Standard_String);
......@@ -4825,7 +4825,7 @@ package body Sem_Attr is
when Attribute_Value => Value :
begin
Check_Formal_Restriction_On_Attribute;
Check_SPARK_Restriction_On_Attribute;
Check_E1;
Check_Scalar_Type;
......@@ -4888,7 +4888,7 @@ package body Sem_Attr is
when Attribute_Wide_Image => Wide_Image :
begin
Check_Formal_Restriction_On_Attribute;
Check_SPARK_Restriction_On_Attribute;
Check_Scalar_Type;
Set_Etype (N, Standard_Wide_String);
Check_E1;
......@@ -4915,7 +4915,7 @@ package body Sem_Attr is
when Attribute_Wide_Value => Wide_Value :
begin
Check_Formal_Restriction_On_Attribute;
Check_SPARK_Restriction_On_Attribute;
Check_E1;
Check_Scalar_Type;
......@@ -4956,7 +4956,7 @@ package body Sem_Attr is
----------------
when Attribute_Wide_Width =>
Check_Formal_Restriction_On_Attribute;
Check_SPARK_Restriction_On_Attribute;
Check_E0;
Check_Scalar_Type;
Set_Etype (N, Universal_Integer);
......@@ -4966,7 +4966,7 @@ package body Sem_Attr is
-----------
when Attribute_Width =>
Check_Formal_Restriction_On_Attribute;
Check_SPARK_Restriction_On_Attribute;
Check_E0;
Check_Scalar_Type;
Set_Etype (N, Universal_Integer);
......
gcc/ada/sem_ch6.adb
......@@ -8593,10 +8593,13 @@ package body Sem_Ch6 is
Check_Overriding_Indicator
(S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
-- Overloading is not allowed in SPARK
-- Overloading is not allowed in SPARK, except for operators
if Nkind (S) /= N_Defining_Operator_Symbol then
Error_Msg_Sloc := Sloc (Homonym (S));
Check_SPARK_Restriction ("overloading not allowed with entity#", S);
Check_SPARK_Restriction
("overloading not allowed with entity#", S);
end if;
-- If S is a derived operation for an untagged type then by
-- definition it's not a dispatching operation (even if the parent
......
gcc/ada/sem_ch7.adb
......@@ -936,7 +936,7 @@ package body Sem_Ch7 is
else
Error_Msg_Sloc := Sloc (Previous);
Check_Formal_Restriction
Check_SPARK_Restriction
("at most one tagged type or type extension allowed",
"\\ previous declaration#",
Decl);
......
gcc/ada/sem_res.adb
......@@ -5748,7 +5748,7 @@ package body Sem_Res is
-- and then Is_Inherited_Operation_For_Type
-- (Entity (Name (N)), Etype (N))
-- then
-- Check_Formal_Restriction ("function not inherited", N);
-- Check_SPARK_Restriction ("function not inherited", N);
-- end if;
-- Implement rule in 12.5.1 (23.3/2): In an instance, if the actual is
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment