+2009-07-13 Robert Dewar <dewar@adacore.com>
+
+ * lib.adb, prj-nmsc.adb, prj-proc.adb, prj-proc.ads, prj.adb,
+ prj.ads: Minor reformatting and code reorganization.
+
+ * par-ch3.adb (Check_Restricted_Expression): New procedure
+
2009-07-13 Ed Schonberg <schonberg@adacore.com>
* exp_attr.adb (Rewrite_Stream_Proc_Call): When rewriting a stream
-- If not in the table, must be a spec created for a main unit that is a
-- child subprogram body which we have not inserted into the table yet.
- if N /= Library_Unit (Cunit (Main_Unit)) then
- -- We do not use a pragma Assert here, since this would not be
- -- enabled in case assertions are not active.
+ if N = Library_Unit (Cunit (Main_Unit)) then
+ return Main_Unit;
+
+ -- If it is anything else, something is seriously wrong, and we really
+ -- don't want to proceed, even if assertions are off, so we explicitly
+ -- raise an exception in this case to terminate compilation.
- raise Program_Error;
else
- return Main_Unit;
+ raise Program_Error;
end if;
end Get_Cunit_Unit_Number;
separate (Par)
+---------
+-- Ch3 --
+---------
+
package body Ch3 is
-----------------------
function P_Variant return Node_Id;
function P_Variant_Part return Node_Id;
+ procedure Check_Restricted_Expression (N : Node_Id);
+ -- Check that the expression N meets the Restricted_Expression syntax.
+ -- The syntax is as follows:
+ --
+ -- RESTRICTED_EXPRESSION ::=
+ -- RESTRICTED_RELATION {and RESTRICTED_RELATION}
+ -- | RESTRICTED_RELATION {and then RESTRICTED_RELATION}
+ -- | RESTRICTED_RELATION {or RESTRICTED_RELATION}
+ -- | RESTRICTED_RELATION {or else RESTRICTED_RELATION}
+ -- | RESTRICTED_RELATION {xor RESTRICTED_RELATION}
+ --
+ -- RESTRICTED_RELATION ::=
+ -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
+ --
+ -- This syntax is used for choices when extensions (and set notations)
+ -- are enabled, to remove the ambiguity of "when X in A | B". We consider
+ -- it very unlikely that this will ever arise in practice.
+
procedure P_Declarative_Items
(Decls : List_Id;
Done : out Boolean;
-- current token, and if this is the first such message issued, saves
-- the message id in Missing_Begin_Msg, for possible later replacement.
+
+ ---------------------------------
+ -- Check_Restricted_Expression --
+ ---------------------------------
+
+ procedure Check_Restricted_Expression (N : Node_Id) is
+ begin
+ if Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor, N_And_Then, N_Or_Else) then
+ Check_Restricted_Expression (Left_Opnd (N));
+ Check_Restricted_Expression (Right_Opnd (N));
+
+ elsif Nkind_In (N, N_In, N_Not_In)
+ and then Paren_Count (N) = 0
+ then
+ Error_Msg_N
+ ("|this expression must be parenthesized!", N);
+ Error_Msg_N
+ ("\|since extensions (and set notation) are allowed", N);
+ end if;
+ end Check_Restricted_Expression;
+
-------------------
-- Init_Expr_Opt --
-------------------
-- when (A in 1 .. 10 | 12) =>
-- when (A in 1 .. 10) | 12 =>
- -- We consider it unlikely that reintroducing the Ada 83
- -- restriction will cause an upwards incompatibility issue.
- -- Historically the only reason for the change in Ada 95 was
- -- for consistency (all cases of Simple_Expression in Ada 83
- -- which could be changed to Expression without causing any
- -- ambiguities were changed).
-
- if Extensions_Allowed and then Expr_Form = EF_Non_Simple then
- Error_Msg_N
- ("|this expression must be parenthesized!",
- Expr_Node);
- Error_Msg_N
- ("\|since extensions (and set notation) are allowed",
- Expr_Node);
+ -- To solve this, if extensins are enabled, we disallow
+ -- the use of membership operations in expressions in
+ -- choices. Technically in the grammar, the expression
+ -- must match the grammar for restricted expression.
+
+ if Extensions_Allowed then
+ Check_Restricted_Expression (Expr_Node);
-- In Ada 83 mode, the syntax required a simple expression
+
else
Check_Simple_Expression_In_Ada_83 (Expr_Node);
end if;
Hash => Hash,
Equal => "=");
-- Mapping from base file names to Source_Id (containing full info about
- -- the source)
+ -- the source).
type Tree_Processing_Data is record
Tree : Project_Tree_Ref;
-- are sources for which this is an alternate language.
if Language.First_Source = No_Source
- and then
- (Data.Flags.Require_Sources_Other_Lang
- or else Language.Name = Name_Ada)
+ and then (Data.Flags.Require_Sources_Other_Lang
+ or else Language.Name = Name_Ada)
then
Iter := For_Each_Source (In_Tree => Data.Tree,
Project => Project);
and then not UData.File_Names (Impl).Locally_Removed
then
if Check_Project
- (UData.File_Names (Impl).Project,
- Project, Extending)
+ (UData.File_Names (Impl).Project,
+ Project, Extending)
then
- -- There is a body for this unit. If there is
- -- no spec, we need to check that it is not a
- -- subunit.
+ -- There is a body for this unit. If there is no
+ -- spec, we need to check that it is not a subunit.
if UData.File_Names (Spec) = null then
declare
(Impl).Path.Name));
if Sinput.P.Source_File_Is_Subunit
- (Src_Ind)
+ (Src_Ind)
then
Error_Msg
(Project,
end;
end if;
- -- The unit is not a subunit, so we add the
- -- ALI file for its body to the Interface ALIs.
+ -- The unit is not a subunit, so we add the ALI
+ -- file for its body to the Interface ALIs.
- Add_ALI_For
- (UData.File_Names (Impl).File);
+ Add_ALI_For (UData.File_Names (Impl).File);
else
Error_Msg
and then UData.File_Names (Spec) /= null
and then not UData.File_Names (Spec).Locally_Removed
and then Check_Project
- (UData.File_Names (Spec).Project,
- Project, Extending)
+ (UData.File_Names (Spec).Project,
+ Project, Extending)
then
-- The unit is part of the project, it has a spec,
-- but no body. We add the ALI for its spec to the
-- Interface ALIs.
- Add_ALI_For
- (UData.File_Names (Spec).File);
+ Add_ALI_For (UData.File_Names (Spec).File);
else
Error_Msg
while Prj.Element (Iter) /= No_Source
and then
(Prj.Element (Iter).Unit = null
- or else Prj.Element (Iter).Unit.Name /= Unit)
+ or else Prj.Element (Iter).Unit.Name /= Unit)
loop
Next (Iter);
end loop;
if Source /= No_Source then
if Source.Kind = Sep then
Source := No_Source;
-
elsif Source.Kind = Spec
and then Other_Part (Source) /= No_Source
then
Source := Other_Part (Source);
end if;
+ -- Can't we use Append here???
+
String_Element_Table.Increment_Last
(Data.Tree.String_Elements);
String_Element_Table.Last
(Data.Tree.String_Elements);
end if;
-
end if;
-
end if;
- Interfaces :=
- Data.Tree.String_Elements.Table (Interfaces).Next;
+ Interfaces := Data.Tree.String_Elements.Table (Interfaces).Next;
end loop;
-- Put the list of Interface ALIs in the project data
-- Report error if it is one of the source directories
if Project.Library_Src_Dir.Name =
- Path_Name_Type (Src_Dir.Value)
+ Path_Name_Type (Src_Dir.Value)
then
Error_Msg
(Project,
Data.Tree.String_Elements.Table (Src_Dirs);
-- Report error if it is one of the source
- -- directories
+ -- directories.
if Project.Library_Src_Dir.Name =
Path_Name_Type (Src_Dir.Value)
begin
if Dir'Length > 1
and then (Dir (Dir'Last - 1) = Directory_Separator
- or else Dir (Dir'Last - 1) = '/')
+ or else
+ Dir (Dir'Last - 1) = '/')
then
return Dir'Last - 1;
else
The_Path : constant String :=
Normalize_Pathname
(Get_Name_String (Path),
- Directory => Get_Name_String
- (Project.Directory.Display_Name),
+ Directory =>
+ Get_Name_String (Project.Directory.Display_Name),
Resolve_Links => Opt.Follow_Links_For_Dirs) &
Directory_Separator;
procedure Initialize
(Data : out Tree_Processing_Data;
Tree : Project_Tree_Ref;
- Flags : Prj.Processing_Flags) is
+ Flags : Prj.Processing_Flags)
+ is
begin
Files_Htable.Reset (Data.File_To_Source);
Data.Tree := Tree;
procedure Initialize
(Data : in out Project_Processing_Data;
- Project : Project_Id) is
+ Project : Project_Id)
+ is
begin
Data.Project := Project;
end Initialize;
else
-- Check if it is a subunit
- Src_Ind := Sinput.P.Load_Project_File
- (Get_Name_String (Src_Id.Path.Name));
+ Src_Ind :=
+ Sinput.P.Load_Project_File
+ (Get_Name_String (Src_Id.Path.Name));
if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
Override_Kind (Src_Id, Sep);
procedure Recursive_Check
(Project : Project_Id;
- Data : in out Tree_Processing_Data) is
+ Data : in out Tree_Processing_Data)
+ is
begin
if Verbose_Mode then
Write_Str ("Processing_Naming_Scheme for project """);
For_Every_Project_Imported (Tree_Processing_Data, Recursive_Check);
Data : Tree_Processing_Data;
+
+ -- Start of processing for Process_Naming_Scheme
begin
Initialize (Data, Tree => Tree, Flags => Flags);
Check_All_Projects (Root_Project, Data, Imported_First => True);
-- the package or project with declarations Decl.
procedure Check
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id;
- Flags : Processing_Flags);
+ (In_Tree : Project_Tree_Ref;
+ Project : Project_Id;
+ Flags : Processing_Flags);
-- Set all projects to not checked, then call Recursive_Check for the
-- main project Project. Project is set to No_Project if errors occurred.
-- Current_Dir is for optimization purposes, avoiding extra system calls.
-----------
procedure Check
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id;
- Flags : Processing_Flags)
+ (In_Tree : Project_Tree_Ref;
+ Project : Project_Id;
+ Flags : Processing_Flags)
is
begin
Process_Naming_Scheme (In_Tree, Project, Flags);
if Source2 = No_Source then
Unit_Htable.Set (K => Name, E => Source1);
-
else
Unit_Htable.Remove (Name);
end if;
if To.Attributes = No_Variable then
To.Attributes :=
Variable_Element_Table.Last (In_Tree.Variable_Elements);
-
else
In_Tree.Variable_Elements.Table (V2).Next :=
Variable_Element_Table.Last (In_Tree.Variable_Elements);
if To.Arrays = No_Array then
To.Arrays := Array_Table.Last (In_Tree.Arrays);
-
else
In_Tree.Arrays.Table (A2).Next :=
Array_Table.Last (In_Tree.Arrays);
First_Term : Project_Node_Id;
Kind : Variable_Kind) return Variable_Value
is
- The_Term : Project_Node_Id := First_Term;
+ The_Term : Project_Node_Id;
-- The term in the expression list
The_Current_Term : Project_Node_Id := Empty_Node;
-- Process each term of the expression, starting with First_Term
+ The_Term := First_Term;
while Present (The_Term) loop
The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree);
Configuration
then
Process_Project_Tree_Phase_2
- (In_Tree => In_Tree,
- Project => Project,
- Success => Success,
- From_Project_Node => From_Project_Node,
- From_Project_Node_Tree => From_Project_Node_Tree,
- Flags => Flags);
+ (In_Tree => In_Tree,
+ Project => Project,
+ Success => Success,
+ From_Project_Node => From_Project_Node,
+ From_Project_Node_Tree => From_Project_Node_Tree,
+ Flags => Flags);
end if;
end Process;
----------------------------------
procedure Process_Project_Tree_Phase_2
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id;
- Success : out Boolean;
- From_Project_Node : Project_Node_Id;
- From_Project_Node_Tree : Project_Node_Tree_Ref;
- Flags : Processing_Flags)
+ (In_Tree : Project_Tree_Ref;
+ Project : Project_Id;
+ Success : out Boolean;
+ From_Project_Node : Project_Node_Id;
+ From_Project_Node_Tree : Project_Node_Tree_Ref;
+ Flags : Processing_Flags)
is
Obj_Dir : Path_Name_Type;
Extending : Project_Id;
-- project table before processing.
procedure Process_Project_Tree_Phase_2
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id;
- Success : out Boolean;
- From_Project_Node : Project_Node_Id;
- From_Project_Node_Tree : Project_Node_Tree_Ref;
- Flags : Processing_Flags);
+ (In_Tree : Project_Tree_Ref;
+ Project : Project_Id;
+ Success : out Boolean;
+ From_Project_Node : Project_Node_Id;
+ From_Project_Node_Tree : Project_Node_Tree_Ref;
+ Flags : Processing_Flags);
-- Perform the second phase of the processing, filling the rest of the
-- project with the information extracted from the project tree. This phase
-- requires that the configuration file has already been parsed (in fact
Require_Sources_Other_Lang : Boolean := True;
Allow_Duplicate_Basenames : Boolean := True;
Compiler_Driver_Mandatory : Boolean := False;
- Error_On_Unknown_Language : Boolean := True)
- return Processing_Flags is
+ Error_On_Unknown_Language : Boolean := True) return Processing_Flags
+ is
begin
return Processing_Flags'
(Report_Error => Report_Error,
-- project file tree. Initialize must be called before the call to Reset.
type Processing_Flags is private;
- -- Flags used while parsing and processing a project tree.
- -- These configure various behavior in the parser, as well as indicate how
- -- to report error messages.
- -- This structure does not allocate memory and never needs to be freed
+ -- Flags used while parsing and processing a project tree to configure the
+ -- behavior of the parser, and indicate how to report error messages. This
+ -- structure does not allocate memory and never needs to be freed
function Create_Flags
(Report_Error : Put_Line_Access;
Require_Sources_Other_Lang : Boolean := True;
Allow_Duplicate_Basenames : Boolean := True;
Compiler_Driver_Mandatory : Boolean := False;
- Error_On_Unknown_Language : Boolean := True)
- return Processing_Flags;
+ Error_On_Unknown_Language : Boolean := True) return Processing_Flags;
+ -- Function used to create Processing_Flags structure
+ --
-- If Allow_Duplicate_Basenames, then files with the same base names are
-- authorized within a project for source-based languages (never for unit
- -- based languages)
+ -- based languages).
+ --
-- If Compiler_Driver_Mandatory is true, then a Compiler.Driver attribute
-- for each language must be defined, or we will not look for its source
-- files.
+ --
-- When_No_Sources indicates what should be done when no sources of a
-- language are found in a project where this language is declared.
-- If Require_Sources_Other_Lang is true, then all languages must have at
-- least one source file, or an error is reported via When_No_Sources. If
-- it is false, this is only required for Ada (and only if it is a language
-- of the project).
+ --
-- If Report_Error is null, use the standard error reporting mechanism
-- (Errout). Otherwise, report errors using Report_Error.
+ --
-- If Error_On_Unknown_Language is true, an error is displayed if some of
-- the source files listed in the project do not match any naming scheme
Gprbuild_Flags : constant Processing_Flags;
Gnatmake_Flags : constant Processing_Flags;
-- Flags used by the various tools. They all display the error messages
- -- through Prj.Err
+ -- through Prj.Err.
package Project_Boolean_Htable is new Simple_HTable
(Header_Num => Header_Num,
projects / gcc.git / commitdiff